Index: trunk/src/phase_space/Makefile.am =================================================================== --- trunk/src/phase_space/Makefile.am (revision 8793) +++ trunk/src/phase_space/Makefile.am (revision 8794) @@ -1,229 +1,266 @@ ## Makefile.am -- Makefile for WHIZARD ## ## Process this file with automake to produce Makefile.in # # Copyright (C) 1999-2022 by # Wolfgang Kilian # Thorsten Ohl # Juergen Reuter # with contributions from # cf. main AUTHORS file # # WHIZARD is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # WHIZARD is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ######################################################################## ## The files in this directory implement quantum field theory concepts ## such as model representation and quantum numbers. ## We create a library which is still to be combined with auxiliary libs. noinst_LTLIBRARIES = libphase_space.la check_LTLIBRARIES = libphase_space_ut.la libphase_space_la_SOURCES = \ + $(PHS_MODULES) \ + $(PHS_SUBMODULES) + +PHS_MODULES = \ phs_base.f90 \ phs_none.f90 \ phs_single.f90 \ phs_rambo.f90 \ resonances.f90 \ - mappings.f90 phs_trees.f90 phs_forests.f90 \ + mappings.f90 \ + phs_trees.f90 \ + phs_forests.f90 \ cascades.f90 \ + cascades2_lexer.f90 \ + cascades2.f90 \ phs_wood.f90 \ phs_fks.f90 \ - dispatch_phase_space.f90 \ - cascades2_lexer.f90 \ - cascades2.f90 + dispatch_phase_space.f90 + +PHS_SUBMODULES = \ + phs_base_sub.f90 \ + phs_none_sub.f90 \ + phs_single_sub.f90 \ + phs_rambo_sub.f90 \ + resonances_sub.f90 \ + mappings_sub.f90 \ + phs_trees_sub.f90 \ + phs_forests_sub.f90 \ + cascades_sub.f90 \ + cascades2_lexer_sub.f90 \ + cascades2_sub.f90 \ + phs_wood_sub.f90 \ + phs_fks_sub.f90 \ + dispatch_phase_space_sub.f90 libphase_space_ut_la_SOURCES = \ phs_base_uti.f90 phs_base_ut.f90 \ phs_none_uti.f90 phs_none_ut.f90 \ phs_single_uti.f90 phs_single_ut.f90 \ phs_rambo_uti.f90 phs_rambo_ut.f90 \ resonances_uti.f90 resonances_ut.f90 \ phs_trees_uti.f90 phs_trees_ut.f90 \ phs_forests_uti.f90 phs_forests_ut.f90 \ cascades_uti.f90 cascades_ut.f90 \ + cascades2_lexer_uti.f90 cascades2_lexer_ut.f90 \ + cascades2_uti.f90 cascades2_ut.f90 \ phs_wood_uti.f90 phs_wood_ut.f90 \ phs_fks_uti.f90 phs_fks_ut.f90 \ - dispatch_phs_uti.f90 dispatch_phs_ut.f90 \ - cascades2_lexer_uti.f90 cascades2_lexer_ut.f90 \ - cascades2_uti.f90 cascades2_ut.f90 + dispatch_phs_uti.f90 dispatch_phs_ut.f90 ## Omitting this would exclude it from the distribution dist_noinst_DATA = phase_space.nw # Modules and installation # Dump module names into file Modules execmoddir = $(fmoddir)/whizard nodist_execmod_HEADERS = \ - ${libphase_space_la_SOURCES:.f90=.$(FCMOD)} + ${PHS_MODULES:.f90=.$(FCMOD)} # Dump module names into file Modules libphase_space_Modules = \ - ${libphase_space_la_SOURCES:.f90=} \ + ${PHS_MODULES:.f90=} \ ${libphase_space_ut_la_SOURCES:.f90=} Modules: Makefile @for module in $(libphase_space_Modules); do \ echo $$module >> $@.new; \ done @if diff $@ $@.new -q >/dev/null; then \ rm $@.new; \ else \ mv $@.new $@; echo "Modules updated"; \ fi BUILT_SOURCES = Modules ## Fortran module dependencies # Get module lists from other directories module_lists = \ ../basics/Modules \ ../utilities/Modules \ ../testing/Modules \ ../system/Modules \ ../combinatorics/Modules \ ../parsing/Modules \ ../physics/Modules \ ../qft/Modules \ ../types/Modules \ ../matrix_elements/Modules \ ../beams/Modules \ ../model_features/Modules \ ../variables/Modules \ ../expr_base/Modules \ ../threshold/Modules $(module_lists): $(MAKE) -C `dirname $@` Modules Module_dependencies.sed: $(libphase_space_la_SOURCES) $(libphase_space_ut_la_SOURCES) Module_dependencies.sed: $(module_lists) @rm -f $@ echo 's/, *only:.*//' >> $@ echo 's/, *&//' >> $@ echo 's/, *.*=>.*//' >> $@ echo 's/$$/.lo/' >> $@ for list in $(module_lists); do \ dir="`dirname $$list`"; \ for mod in `cat $$list`; do \ echo 's!: '$$mod'.lo$$!': $$dir/$$mod'.lo!' >> $@; \ done \ done DISTCLEANFILES = Module_dependencies.sed # The following line just says # include Makefile.depend # but in a portable fashion (depending on automake's AM_MAKE_INCLUDE @am__include@ @am__quote@Makefile.depend@am__quote@ Makefile.depend: Module_dependencies.sed Makefile.depend: $(libphase_space_la_SOURCES) $(libphase_space_ut_la_SOURCES) @rm -f $@ for src in $^; do \ module="`basename $$src | sed 's/\.f[90][0358]//'`"; \ grep '^ *use ' $$src \ | grep -v '!NODEP!' \ | sed -e 's/^ *use */'$$module'.lo: /' \ -f Module_dependencies.sed; \ done > $@ DISTCLEANFILES += Makefile.depend # Fortran90 module files are generated at the same time as object files .lo.$(FCMOD): @: # touch $@ AM_FCFLAGS = -I../basics -I../utilities -I../testing -I../system -I../combinatorics -I../parsing -I../physics -I../fastjet -I../qed_pdf -I../qft -I../matrix_elements -I../types -I../particles -I../beams -I../rng -I../../circe1/src -I../../circe2/src -I../pdf_builtin -I../lhapdf -I../model_features -I../variables -I../expr_base -I../threshold +######################################################################## +phs_base_sub.lo: phs_base.lo +phs_none_sub.lo: phs_none.lo +phs_single_sub.lo: phs_single.lo +phs_rambo_sub.lo: phs_rambo.lo +resonances_sub.lo: resonances.lo +mappings_sub.lo: mappings.lo +phs_trees_sub.lo: phs_trees.lo +phs_forests_sub.lo: phs_forests.lo +cascades_sub.lo: cascades.lo +cascades2_lexer_sub.lo: cascades2_lexer.lo +cascades2_sub.lo: cascades2.lo +phs_wood_sub.lo: phs_wood.lo +phs_fks_sub.lo: phs_fks.lo +dispatch_phase_space_sub.lo: dispatch_phase_space.lo ######################################################################## ## Default Fortran compiler options ## Profiling if FC_USE_PROFILING AM_FCFLAGS += $(FCFLAGS_PROFILING) endif ## OpenMP if FC_USE_OPENMP AM_FCFLAGS += $(FCFLAGS_OPENMP) endif # MPI if FC_USE_MPI AM_FCFLAGS += $(FCFLAGS_MPI) endif ######################################################################## ## Non-standard targets and dependencies ## (Re)create F90 sources from NOWEB source. if NOWEB_AVAILABLE PRELUDE = $(top_srcdir)/src/noweb-frame/whizard-prelude.nw POSTLUDE = $(top_srcdir)/src/noweb-frame/whizard-postlude.nw phase_space.stamp: $(PRELUDE) $(srcdir)/phase_space.nw $(POSTLUDE) @rm -f phase_space.tmp @touch phase_space.tmp for src in \ $(libphase_space_la_SOURCES) \ $(libphase_space_ut_la_SOURCES); do \ $(NOTANGLE) -R[[$$src]] $^ | $(CPIF) $$src; \ done @mv -f phase_space.tmp phase_space.stamp $(libphase_space_la_SOURCES) $(libphase_space_ut_la_SOURCES): phase_space.stamp ## Recover from the removal of $@ @if test -f $@; then :; else \ rm -f phase_space.stamp; \ $(MAKE) $(AM_MAKEFLAGS) phase_space.stamp; \ fi endif ######################################################################## ## Non-standard cleanup tasks ## Remove sources that can be recreated using NOWEB if NOWEB_AVAILABLE maintainer-clean-noweb: -rm -f *.f90 *.c endif .PHONY: maintainer-clean-noweb ## Remove those sources also if builddir and srcdir are different if NOWEB_AVAILABLE clean-noweb: test "$(srcdir)" != "." && rm -f *.f90 *.c || true endif .PHONY: clean-noweb ## Remove F90 module files clean-local: clean-noweb -rm -f phase_space.stamp phase_space.tmp -rm -f *.$(FCMOD) if FC_SUBMODULES - -rm -f *.smod + -rm -f *.smod *.sub endif ## Remove backup files maintainer-clean-backup: -rm -f *~ .PHONY: maintainer-clean-backup ## Register additional clean targets maintainer-clean-local: maintainer-clean-noweb maintainer-clean-backup Index: trunk/src/phase_space/phase_space.nw =================================================================== --- trunk/src/phase_space/phase_space.nw (revision 8793) +++ trunk/src/phase_space/phase_space.nw (revision 8794) @@ -1,27688 +1,31030 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: phase space %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Phase Space} \includemodulegraph{phase_space} The abstract representation of a type that parameterizes phase space, with methods for construction and evaluation. \begin{description} \item[phs\_base] Abstract phase-space representation. \end{description} A simple implementation: \begin{description} \item[phs\_none] This implements a non-functional dummy module for the phase space. A process which uses this module cannot be integrated. The purpose of this module is to provide a placeholder for processes which do not require phase-space evaluation. They may still allow for evaluating matrix elements. \item[phs\_single] Parameterize the phase space of a single particle, i.e., the solid angle. This is useful only for very restricted problems, but it avoids the complexity of a generic approach in those trivial cases. \end{description} The standard implementation is called \emph{wood} phase space. It consists of several auxiliary modules and the actual implementation module. \begin{description} \item[mappings] Generate invariant masses and decay angles from given random numbers (or the inverse operation). Each mapping pertains to a particular node in a phase-space tree. Different mappings account for uniform distributions, resonances, zero-mass behavior, and so on. \item[phs\_trees] Phase space parameterizations for scattering processes are defined recursively as if there was an initial particle decaying. This module sets up a representation in terms of abstract trees, where each node gets a unique binary number. Each tree is stored as an array of branches, where integers indicate the connections. This emulates pointers in a transparent way. Real pointers would also be possible, but seem to be less efficient for this particular case. \item[phs\_forests] The type defined by this module collects the decay trees corresponding to a given process and the applicable mappings. To set this up, a file is read which is either written by the user or by the \textbf{cascades} module functions. The module also contains the routines that evaluate phase space, i.e., generate momenta from random numbers and back. \item[cascades] This module is a pseudo Feynman diagram generator with the particular purpose of finding the phase space parameterizations best suited for a given process. It uses a model file to set up the possible vertices, generates all possible diagrams, identifies resonances and singularities, and simplifies the list by merging equivalent diagrams and dropping irrelevant ones. This process can be controlled at several points by user-defined parameters. Note that it depends on the particular values of particle masses, so it cannot be done before reading the input file. \item[phs\_wood] Make the functionality available in form of an implementation of the abstract phase-space type. \item[phs\_fks] Phase-space parameterization with modifications for the FKS scheme. \end{description} \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Abstract phase-space module} In this module we define an abstract base type (and a trivial test implementation) for multi-channel phase-space parameterizations. <<[[phs_base.f90]]>>= <> module phs_base <> <> - use io_units - use constants, only: TWOPI, TWOPI4 - use string_utils, only: split_string - use format_defs, only: FMT_19 - use numeric_utils - use diagnostics - use md5 - use physics_defs use lorentz use model_data use flavors use process_constants <> <> <> <> + interface +<> + end interface + contains -<> +<> end module phs_base @ %def phs_base @ +<<[[phs_base_sub.f90]]>>= +<> + +submodule (phs_base) phs_base_s + + use io_units + use constants, only: TWOPI, TWOPI4 + use string_utils, only: split_string + use format_defs, only: FMT_19 + use numeric_utils + use diagnostics + use md5 + use physics_defs + + implicit none + +contains + +<> + +end submodule phs_base_s + +@ %def phs_base_s +@ \subsection{Phase-space channels} The kinematics configuration may generate multiple parameterizations of phase space. Some of those have specific properties, such as a resonance in the s channel. \subsubsection{Channel properties} This is the abstract type for the channel properties. We need them as a data transfer container, so everything is public and transparent. <>= public :: channel_prop_t <>= type, abstract :: channel_prop_t contains procedure (channel_prop_to_string), deferred :: to_string generic :: operator (==) => is_equal procedure (channel_eq), deferred :: is_equal end type channel_prop_t @ %def channel_prop_t <>= abstract interface function channel_prop_to_string (object) result (string) import class(channel_prop_t), intent(in) :: object type(string_t) :: string end function channel_prop_to_string end interface @ %def channel_prop_to_string <>= abstract interface function channel_eq (prop1, prop2) result (flag) import class(channel_prop_t), intent(in) :: prop1, prop2 logical :: flag end function channel_eq end interface @ %def channel_prop_to_string @ Here is a resonance as a channel property. Mass and width are stored here in physical units. <>= public :: resonance_t <>= type, extends (channel_prop_t) :: resonance_t real(default) :: mass = 0 real(default) :: width = 0 contains procedure :: to_string => resonance_to_string procedure :: is_equal => resonance_is_equal end type resonance_t @ %def resonance_t @ Print mass and width. +<>= + module function resonance_to_string (object) result (string) + class(resonance_t), intent(in) :: object + type(string_t) :: string + end function resonance_to_string <>= - function resonance_to_string (object) result (string) + module function resonance_to_string (object) result (string) class(resonance_t), intent(in) :: object type(string_t) :: string character(32) :: buffer string = "resonant: m =" write (buffer, "(" // FMT_19 // ")") object%mass string = string // trim (buffer) // " GeV, w =" write (buffer, "(" // FMT_19 // ")") object%width string = string // trim (buffer) // " GeV" end function resonance_to_string @ %def resonance_to_string @ Equality. +<>= + module function resonance_is_equal (prop1, prop2) result (flag) + class(resonance_t), intent(in) :: prop1 + class(channel_prop_t), intent(in) :: prop2 + logical :: flag + end function resonance_is_equal <>= - function resonance_is_equal (prop1, prop2) result (flag) + module function resonance_is_equal (prop1, prop2) result (flag) class(resonance_t), intent(in) :: prop1 class(channel_prop_t), intent(in) :: prop2 logical :: flag select type (prop2) type is (resonance_t) flag = prop1%mass == prop2%mass .and. prop1%width == prop2%width class default flag = .false. end select end function resonance_is_equal @ %def resonance_is_equal @ This is the limiting case of a resonance, namely an on-shell particle. We just store the mass in physical units. <>= public :: on_shell_t <>= type, extends (channel_prop_t) :: on_shell_t real(default) :: mass = 0 contains procedure :: to_string => on_shell_to_string procedure :: is_equal => on_shell_is_equal end type on_shell_t @ %def on_shell_t @ Print mass and width. +<>= + module function on_shell_to_string (object) result (string) + class(on_shell_t), intent(in) :: object + type(string_t) :: string + end function on_shell_to_string <>= - function on_shell_to_string (object) result (string) + module function on_shell_to_string (object) result (string) class(on_shell_t), intent(in) :: object type(string_t) :: string character(32) :: buffer string = "on shell: m =" write (buffer, "(" // FMT_19 // ")") object%mass string = string // trim (buffer) // " GeV" end function on_shell_to_string @ %def on_shell_to_string @ Equality. +<>= + module function on_shell_is_equal (prop1, prop2) result (flag) + class(on_shell_t), intent(in) :: prop1 + class(channel_prop_t), intent(in) :: prop2 + logical :: flag + end function on_shell_is_equal <>= - function on_shell_is_equal (prop1, prop2) result (flag) + module function on_shell_is_equal (prop1, prop2) result (flag) class(on_shell_t), intent(in) :: prop1 class(channel_prop_t), intent(in) :: prop2 logical :: flag select type (prop2) type is (on_shell_t) flag = prop1%mass == prop2%mass class default flag = .false. end select end function on_shell_is_equal @ %def on_shell_is_equal @ \subsubsection{Channel equivalences} This type describes an equivalence. The current channel is equivalent to channel [[c]]. The equivalence involves a permutation [[perm]] of integration dimensions and, within each integration dimension, a mapping [[mode]]. <>= type :: phs_equivalence_t integer :: c = 0 integer, dimension(:), allocatable :: perm integer, dimension(:), allocatable :: mode contains <> end type phs_equivalence_t @ %def phs_equivalence_t @ The mapping modes are <>= integer, parameter, public :: & EQ_IDENTITY = 0, EQ_INVERT = 1, EQ_SYMMETRIC = 2, EQ_INVARIANT = 3 @ %def EQ_IDENTITY EQ_INVERT EQ_SYMMETRIC @ In particular, if a channel is equivalent to itself in the [[EQ_SYMMETRIC]] mode, the integrand can be assumed to be symmetric w.r.t.\ a reflection $x\to 1 - x$ of the correponding integration variable. These are the associated tags, for output: <>= character, dimension(0:3), parameter :: TAG = ["+", "-", ":", "x"] @ %def TAG @ Write an equivalence. <>= procedure :: write => phs_equivalence_write +<>= + module subroutine phs_equivalence_write (object, unit) + class(phs_equivalence_t), intent(in) :: object + integer, intent(in), optional :: unit + end subroutine phs_equivalence_write <>= - subroutine phs_equivalence_write (object, unit) + module subroutine phs_equivalence_write (object, unit) class(phs_equivalence_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, j u = given_output_unit (unit) write (u, "(5x,'=',1x,I0,1x)", advance = "no") object%c if (allocated (object%perm)) then write (u, "(A)", advance = "no") "(" do j = 1, size (object%perm) if (j > 1) write (u, "(1x)", advance = "no") write (u, "(I0,A1)", advance = "no") & object%perm(j), TAG(object%mode(j)) end do write (u, "(A)") ")" else write (u, "(A)") end if end subroutine phs_equivalence_write @ %def phs_equivalence_write @ Initialize an equivalence. This allocates the [[perm]] and [[mode]] arrays with equal size. <>= procedure :: init => phs_equivalence_init +<>= + module subroutine phs_equivalence_init (eq, n_dim) + class(phs_equivalence_t), intent(out) :: eq + integer, intent(in) :: n_dim + end subroutine phs_equivalence_init <>= - subroutine phs_equivalence_init (eq, n_dim) + module subroutine phs_equivalence_init (eq, n_dim) class(phs_equivalence_t), intent(out) :: eq integer, intent(in) :: n_dim allocate (eq%perm (n_dim), source = 0) allocate (eq%mode (n_dim), source = EQ_IDENTITY) end subroutine phs_equivalence_init @ %def phs_equivalence_init @ \subsubsection{Channel objects} The channel entry holds (optionally) specific properties. [[sf_channel]] is the structure-function channel that corresponds to this phase-space channel. The structure-function channel may be set up with a specific mapping that depends on the phase-space channel properties. (The default setting is to leave the properties empty.) <>= public :: phs_channel_t <>= type :: phs_channel_t class(channel_prop_t), allocatable :: prop integer :: sf_channel = 1 type(phs_equivalence_t), dimension(:), allocatable :: eq contains <> end type phs_channel_t @ %def phs_channel_t @ Output. <>= procedure :: write => phs_channel_write +<>= + module subroutine phs_channel_write (object, unit) + class(phs_channel_t), intent(in) :: object + integer, intent(in), optional :: unit + end subroutine phs_channel_write <>= - subroutine phs_channel_write (object, unit) + module subroutine phs_channel_write (object, unit) class(phs_channel_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, j u = given_output_unit (unit) write (u, "(1x,I0)", advance="no") object%sf_channel if (allocated (object%prop)) then write (u, "(1x,A)") char (object%prop%to_string ()) else write (u, *) end if if (allocated (object%eq)) then do j = 1, size (object%eq) call object%eq(j)%write (u) end do end if end subroutine phs_channel_write @ %def phs_channel_write @ Identify the channel with an s-channel resonance. +Gfortran 7/8/9 bug: has to remain in the main module. <>= procedure :: set_resonant => channel_set_resonant -<>= +<>= subroutine channel_set_resonant (channel, mass, width) class(phs_channel_t), intent(inout) :: channel real(default), intent(in) :: mass, width allocate (resonance_t :: channel%prop) select type (prop => channel%prop) type is (resonance_t) prop%mass = mass prop%width = width end select end subroutine channel_set_resonant @ %def channel_set_resonant -@ Identify the channel with an on-shell particle. +@ Identify the channel with an on-shell particle. +Gfortran 7/8/9 bug: has to remain in the main module. <>= procedure :: set_on_shell => channel_set_on_shell -<>= +<>= subroutine channel_set_on_shell (channel, mass) class(phs_channel_t), intent(inout) :: channel real(default), intent(in) :: mass allocate (on_shell_t :: channel%prop) select type (prop => channel%prop) type is (on_shell_t) prop%mass = mass end select end subroutine channel_set_on_shell @ %def channel_set_on_shell @ \subsection{Property collection} We can set up a list of all distinct channel properties for a given set of channels. <>= public :: phs_channel_collection_t <>= type :: prop_entry_t integer :: i = 0 class(channel_prop_t), allocatable :: prop type(prop_entry_t), pointer :: next => null () end type prop_entry_t type :: phs_channel_collection_t integer :: n = 0 type(prop_entry_t), pointer :: first => null () contains <> end type phs_channel_collection_t @ %def prop_entry_t @ %def phs_channel_collection_t @ Finalizer for the list. <>= procedure :: final => phs_channel_collection_final +<>= + module subroutine phs_channel_collection_final (object) + class(phs_channel_collection_t), intent(inout) :: object + end subroutine phs_channel_collection_final <>= - subroutine phs_channel_collection_final (object) + module subroutine phs_channel_collection_final (object) class(phs_channel_collection_t), intent(inout) :: object type(prop_entry_t), pointer :: entry do while (associated (object%first)) entry => object%first object%first => entry%next deallocate (entry) end do end subroutine phs_channel_collection_final @ %def phs_channel_collection_final @ Output. <>= procedure :: write => phs_channel_collection_write +<>= + module subroutine phs_channel_collection_write (object, unit) + class(phs_channel_collection_t), intent(in) :: object + integer, intent(in), optional :: unit + end subroutine phs_channel_collection_write <>= - subroutine phs_channel_collection_write (object, unit) + module subroutine phs_channel_collection_write (object, unit) class(phs_channel_collection_t), intent(in) :: object integer, intent(in), optional :: unit type(prop_entry_t), pointer :: entry integer :: u u = given_output_unit (unit) entry => object%first do while (associated (entry)) if (allocated (entry%prop)) then write (u, "(1x,I0,1x,A)") entry%i, char (entry%prop%to_string ()) else write (u, "(1x,I0)") entry%i end if entry => entry%next end do end subroutine phs_channel_collection_write @ %def phs_channel_collection_write @ Push a new property to the stack if it is not yet included. Simultaneously, set the [[sf_channel]] entry in the phase-space channel object to the index of the matching entry, or the new entry if there was no match. <>= procedure :: push => phs_channel_collection_push +<>= + module subroutine phs_channel_collection_push (coll, channel) + class(phs_channel_collection_t), intent(inout) :: coll + type(phs_channel_t), intent(inout) :: channel + end subroutine phs_channel_collection_push <>= - subroutine phs_channel_collection_push (coll, channel) + module subroutine phs_channel_collection_push (coll, channel) class(phs_channel_collection_t), intent(inout) :: coll type(phs_channel_t), intent(inout) :: channel type(prop_entry_t), pointer :: entry, new if (associated (coll%first)) then entry => coll%first do if (allocated (entry%prop)) then if (allocated (channel%prop)) then if (entry%prop == channel%prop) then channel%sf_channel = entry%i return end if end if else if (.not. allocated (channel%prop)) then channel%sf_channel = entry%i return end if if (associated (entry%next)) then entry => entry%next else exit end if end do allocate (new) entry%next => new else allocate (new) coll%first => new end if coll%n = coll%n + 1 new%i = coll%n channel%sf_channel = new%i if (allocated (channel%prop)) then allocate (new%prop, source = channel%prop) end if end subroutine phs_channel_collection_push @ %def phs_channel_collection_push @ Return the number of collected distinct channels. <>= procedure :: get_n => phs_channel_collection_get_n +<>= + module function phs_channel_collection_get_n (coll) result (n) + class(phs_channel_collection_t), intent(in) :: coll + integer :: n + end function phs_channel_collection_get_n <>= - function phs_channel_collection_get_n (coll) result (n) + module function phs_channel_collection_get_n (coll) result (n) class(phs_channel_collection_t), intent(in) :: coll integer :: n n = coll%n end function phs_channel_collection_get_n @ %def phs_channel_collection_get_n @ Return a specific channel (property object). <>= procedure :: get_entry => phs_channel_collection_get_entry +<>= + module subroutine phs_channel_collection_get_entry (coll, i, prop) + class(phs_channel_collection_t), intent(in) :: coll + integer, intent(in) :: i + class(channel_prop_t), intent(out), allocatable :: prop + end subroutine phs_channel_collection_get_entry <>= - subroutine phs_channel_collection_get_entry (coll, i, prop) + module subroutine phs_channel_collection_get_entry (coll, i, prop) class(phs_channel_collection_t), intent(in) :: coll integer, intent(in) :: i class(channel_prop_t), intent(out), allocatable :: prop type(prop_entry_t), pointer :: entry integer :: k if (i > 0 .and. i <= coll%n) then entry => coll%first do k = 2, i entry => entry%next end do if (allocated (entry%prop)) then if (allocated (prop)) deallocate (prop) allocate (prop, source = entry%prop) end if else call msg_bug ("PHS channel collection: get entry: illegal index") end if end subroutine phs_channel_collection_get_entry @ %def phs_channel_collection_get_entry @ \subsection{Kinematics configuration} Here, we store the universal information that is specifically relevant for phase-space generation. It is a subset of the process data, supplemented by basic information on phase-space parameterization channels. A concrete implementation will contain more data, that describe the phase space in detail. MD5 sums: the phase space setup depends on the process, it depends on the model parameters (the masses, that is), and on the configuration parameters. (It does not depend on the QCD setup.) <>= public :: phs_config_t <>= type, abstract :: phs_config_t ! private type(string_t) :: id integer :: n_in = 0 integer :: n_out = 0 integer :: n_tot = 0 integer :: n_state = 0 integer :: n_par = 0 integer :: n_channel = 0 real(default) :: sqrts = 0 logical :: sqrts_fixed = .true. logical :: lab_is_cm = .true. logical :: azimuthal_dependence = .false. integer, dimension(:), allocatable :: dim_flat logical :: provides_equivalences = .false. logical :: provides_chains = .false. logical :: vis_channels = .false. integer, dimension(:), allocatable :: chain class(model_data_t), pointer :: model => null () type(flavor_t), dimension(:,:), allocatable :: flv type(phs_channel_t), dimension(:), allocatable :: channel character(32) :: md5sum_process = "" character(32) :: md5sum_model_par = "" character(32) :: md5sum_phs_config = "" integer :: nlo_type contains <> end type phs_config_t @ %def phs_config_t @ Finalizer, deferred. <>= procedure (phs_config_final), deferred :: final <>= abstract interface subroutine phs_config_final (object) import class(phs_config_t), intent(inout) :: object end subroutine phs_config_final end interface @ %def phs_config_final @ Output. We provide an implementation for the output of the base-type contents and an interface for the actual write method. <>= procedure (phs_config_write), deferred :: write procedure :: base_write => phs_config_write +<>= + module subroutine phs_config_write (object, unit, include_id) + class(phs_config_t), intent(in) :: object + integer, intent(in), optional :: unit + logical, intent(in), optional :: include_id + end subroutine phs_config_write <>= - subroutine phs_config_write (object, unit, include_id) + module subroutine phs_config_write (object, unit, include_id) class(phs_config_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: include_id integer :: u, i, j integer :: n_tot_flv logical :: use_id n_tot_flv = object%n_tot u = given_output_unit (unit) use_id = .true.; if (present (include_id)) use_id = include_id if (use_id) write (u, "(3x,A,A,A)") "ID = '", char (object%id), "'" write (u, "(3x,A,I0)") "n_in = ", object%n_in write (u, "(3x,A,I0)") "n_out = ", object%n_out write (u, "(3x,A,I0)") "n_tot = ", object%n_tot write (u, "(3x,A,I0)") "n_state = ", object%n_state write (u, "(3x,A,I0)") "n_par = ", object%n_par write (u, "(3x,A,I0)") "n_channel = ", object%n_channel write (u, "(3x,A," // FMT_19 // ")") "sqrts = ", object%sqrts write (u, "(3x,A,L1)") "s_fixed = ", object%sqrts_fixed write (u, "(3x,A,L1)") "lab_is_cm = ", object%lab_is_cm write (u, "(3x,A,L1)") "azim.dep. = ", object%azimuthal_dependence if (allocated (object%dim_flat)) then write (u, "(3x,A,I0)") "flat dim. = ", object%dim_flat end if write (u, "(1x,A)") "Flavor combinations:" do i = 1, object%n_state write (u, "(3x,I0,':')", advance="no") i ! do j = 1, object%n_tot do j = 1, n_tot_flv write (u, "(1x,A)", advance="no") char (object%flv(j,i)%get_name ()) end do write (u, "(A)") end do if (allocated (object%channel)) then write (u, "(1x,A)") "Phase-space / structure-function channels:" do i = 1, object%n_channel write (u, "(3x,I0,':')", advance="no") i call object%channel(i)%write (u) end do end if if (object%md5sum_process /= "") then write (u, "(3x,A,A,A)") "MD5 sum (process) = '", & object%md5sum_process, "'" end if if (object%md5sum_model_par /= "") then write (u, "(3x,A,A,A)") "MD5 sum (model par) = '", & object%md5sum_model_par, "'" end if if (object%md5sum_phs_config /= "") then write (u, "(3x,A,A,A)") "MD5 sum (phs config) = '", & object%md5sum_phs_config, "'" end if end subroutine phs_config_write @ %def phs_config_write @ Similarly, a basic initializer and an interface. The model pointer is taken as an argument; we may verify that this has the expected model name. The intent is [[inout]]. We want to be able to set parameters in advance. <>= procedure :: init => phs_config_init +<>= + module subroutine phs_config_init (phs_config, data, model) + class(phs_config_t), intent(inout) :: phs_config + type(process_constants_t), intent(in) :: data + class(model_data_t), intent(in), target :: model + end subroutine phs_config_init <>= - subroutine phs_config_init (phs_config, data, model) + module subroutine phs_config_init (phs_config, data, model) class(phs_config_t), intent(inout) :: phs_config type(process_constants_t), intent(in) :: data class(model_data_t), intent(in), target :: model integer :: i, j phs_config%id = data%id phs_config%n_in = data%n_in phs_config%n_out = data%n_out phs_config%n_tot = data%n_in + data%n_out phs_config%n_state = data%n_flv if (data%model_name == model%get_name ()) then phs_config%model => model else call msg_bug ("phs_config_init: model name mismatch") end if allocate (phs_config%flv (phs_config%n_tot, phs_config%n_state)) do i = 1, phs_config%n_state do j = 1, phs_config%n_tot call phs_config%flv(j,i)%init (data%flv_state(j,i), & phs_config%model) end do end do phs_config%md5sum_process = data%md5sum end subroutine phs_config_init @ %def phs_config_init @ WK 2018-04-05: This procedure appears to be redundant? <>= procedure :: set_component_index => phs_config_set_component_index <>= subroutine phs_config_set_component_index (phs_config, index) class(phs_config_t), intent(inout) :: phs_config integer, intent(in) :: index type(string_t), dimension(:), allocatable :: id type(string_t) :: suffix integer :: i, n suffix = var_str ('i') // int2string (index) call split_string (phs_config%id, var_str ('_'), id) phs_config%id = var_str ('') n = size (id) - 1 do i = 1, n phs_config%id = phs_config%id // id(i) // var_str ('_') end do phs_config%id = phs_config%id // suffix end subroutine phs_config_set_component_index @ %def phs_config_set_component_index @ This procedure should complete the phase-space configuration. We need the [[sqrts]] value as overall scale, which is known only after the beams have been defined. The procedure should determine the number of channels, their properties (if any), and allocate and fill the [[channel]] array accordingly. <>= procedure (phs_config_configure), deferred :: configure <>= abstract interface subroutine phs_config_configure (phs_config, sqrts, & sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, ignore_mismatch, & nlo_type, subdir) import class(phs_config_t), intent(inout) :: phs_config real(default), intent(in) :: sqrts logical, intent(in), optional :: sqrts_fixed logical, intent(in), optional :: lab_is_cm logical, intent(in), optional :: azimuthal_dependence logical, intent(in), optional :: rebuild logical, intent(in), optional :: ignore_mismatch integer, intent(in), optional :: nlo_type type(string_t), intent(in), optional :: subdir end subroutine phs_config_configure end interface @ %def phs_config_configure @ Manually assign structure-function channel indices to the phase-space channel objects. (Used by a test routine.) <>= procedure :: set_sf_channel => phs_config_set_sf_channel +<>= + module subroutine phs_config_set_sf_channel (phs_config, sf_channel) + class(phs_config_t), intent(inout) :: phs_config + integer, dimension(:), intent(in) :: sf_channel + end subroutine phs_config_set_sf_channel <>= - subroutine phs_config_set_sf_channel (phs_config, sf_channel) + module subroutine phs_config_set_sf_channel (phs_config, sf_channel) class(phs_config_t), intent(inout) :: phs_config integer, dimension(:), intent(in) :: sf_channel phs_config%channel%sf_channel = sf_channel end subroutine phs_config_set_sf_channel @ %def phs_config_set_sf_channel @ Collect new channels not yet in the collection from this phase-space configuration object. At the same time, assign structure-function channels. <>= procedure :: collect_channels => phs_config_collect_channels +<>= + module subroutine phs_config_collect_channels (phs_config, coll) + class(phs_config_t), intent(inout) :: phs_config + type(phs_channel_collection_t), intent(inout) :: coll + end subroutine phs_config_collect_channels <>= - subroutine phs_config_collect_channels (phs_config, coll) + module subroutine phs_config_collect_channels (phs_config, coll) class(phs_config_t), intent(inout) :: phs_config type(phs_channel_collection_t), intent(inout) :: coll integer :: c do c = 1, phs_config%n_channel call coll%push (phs_config%channel(c)) end do end subroutine phs_config_collect_channels @ %def phs_config_collect_channels @ Compute the MD5 sum. We abuse the [[write]] method. In type implementations, [[write]] should only display information that is relevant for the MD5 sum. The data include the process MD5 sum which is taken from the process constants, and the MD5 sum of the model parameters. This may change, so it is computed here. <>= procedure :: compute_md5sum => phs_config_compute_md5sum +<>= + module subroutine phs_config_compute_md5sum (phs_config, include_id) + class(phs_config_t), intent(inout) :: phs_config + logical, intent(in), optional :: include_id + end subroutine phs_config_compute_md5sum <>= - subroutine phs_config_compute_md5sum (phs_config, include_id) + module subroutine phs_config_compute_md5sum (phs_config, include_id) class(phs_config_t), intent(inout) :: phs_config logical, intent(in), optional :: include_id integer :: u phs_config%md5sum_model_par = phs_config%model%get_parameters_md5sum () phs_config%md5sum_phs_config = "" u = free_unit () open (u, status = "scratch", action = "readwrite") call phs_config%write (u, include_id) rewind (u) phs_config%md5sum_phs_config = md5sum (u) close (u) end subroutine phs_config_compute_md5sum @ %def phs_config_compute_md5sum @ Print an informative message after phase-space configuration. <>= procedure (phs_startup_message), deferred :: startup_message procedure :: base_startup_message => phs_startup_message +<>= + module subroutine phs_startup_message (phs_config, unit) + class(phs_config_t), intent(in) :: phs_config + integer, intent(in), optional :: unit + end subroutine phs_startup_message <>= - subroutine phs_startup_message (phs_config, unit) + module subroutine phs_startup_message (phs_config, unit) class(phs_config_t), intent(in) :: phs_config integer, intent(in), optional :: unit write (msg_buffer, "(A,3(1x,I0,1x,A))") & "Phase space:", & phs_config%n_channel, "channels,", & phs_config%n_par, "dimensions" call msg_message (unit = unit) end subroutine phs_startup_message @ %def phs_startup_message @ This procedure should be implemented such that the phase-space configuration object allocates a phase-space instance of matching type. <>= procedure (phs_config_allocate_instance), nopass, deferred :: & allocate_instance <>= abstract interface subroutine phs_config_allocate_instance (phs) import class(phs_t), intent(inout), pointer :: phs end subroutine phs_config_allocate_instance end interface @ %def phs_config_allocate_instance @ \subsection{Extract data} Return the number of MC input parameters. <>= procedure :: get_n_par => phs_config_get_n_par +<>= + module function phs_config_get_n_par (phs_config) result (n) + class(phs_config_t), intent(in) :: phs_config + integer :: n + end function phs_config_get_n_par <>= - function phs_config_get_n_par (phs_config) result (n) + module function phs_config_get_n_par (phs_config) result (n) class(phs_config_t), intent(in) :: phs_config integer :: n n = phs_config%n_par end function phs_config_get_n_par @ %def phs_config_get_n_par @ Return dimensions (parameter indices) for which the phase-space dimension is flat, so integration and event generation can be simplified. <>= procedure :: get_flat_dimensions => phs_config_get_flat_dimensions +<>= + module function phs_config_get_flat_dimensions & + (phs_config) result (dim_flat) + class(phs_config_t), intent(in) :: phs_config + integer, dimension(:), allocatable :: dim_flat + end function phs_config_get_flat_dimensions <>= - function phs_config_get_flat_dimensions (phs_config) result (dim_flat) + module function phs_config_get_flat_dimensions & + (phs_config) result (dim_flat) class(phs_config_t), intent(in) :: phs_config integer, dimension(:), allocatable :: dim_flat if (allocated (phs_config%dim_flat)) then allocate (dim_flat (size (phs_config%dim_flat))) dim_flat = phs_config%dim_flat else allocate (dim_flat (0)) end if end function phs_config_get_flat_dimensions @ %def phs_config_get_flat_dimensions @ Return the number of phase-space channels. <>= procedure :: get_n_channel => phs_config_get_n_channel +<>= + module function phs_config_get_n_channel (phs_config) result (n) + class(phs_config_t), intent(in) :: phs_config + integer :: n + end function phs_config_get_n_channel <>= - function phs_config_get_n_channel (phs_config) result (n) + module function phs_config_get_n_channel (phs_config) result (n) class(phs_config_t), intent(in) :: phs_config integer :: n n = phs_config%n_channel end function phs_config_get_n_channel @ %def phs_config_get_n_channel @ Return the structure-function channel that corresponds to the phase-space channel [[c]]. If the channel array is not allocated (which happens if there is no structure function), return zero. <>= procedure :: get_sf_channel => phs_config_get_sf_channel +<>= + module function phs_config_get_sf_channel (phs_config, c) result (c_sf) + class(phs_config_t), intent(in) :: phs_config + integer, intent(in) :: c + integer :: c_sf + end function phs_config_get_sf_channel <>= - function phs_config_get_sf_channel (phs_config, c) result (c_sf) + module function phs_config_get_sf_channel (phs_config, c) result (c_sf) class(phs_config_t), intent(in) :: phs_config integer, intent(in) :: c integer :: c_sf if (allocated (phs_config%channel)) then c_sf = phs_config%channel(c)%sf_channel else c_sf = 0 end if end function phs_config_get_sf_channel @ %def phs_config_get_sf_channel @ Return the mass(es) of the incoming particle(s). We take the first flavor combination in the array, assuming that masses must be degenerate among flavors. <>= procedure :: get_masses_in => phs_config_get_masses_in +<>= + module subroutine phs_config_get_masses_in (phs_config, m) + class(phs_config_t), intent(in) :: phs_config + real(default), dimension(:), intent(out) :: m + end subroutine phs_config_get_masses_in <>= - subroutine phs_config_get_masses_in (phs_config, m) + module subroutine phs_config_get_masses_in (phs_config, m) class(phs_config_t), intent(in) :: phs_config real(default), dimension(:), intent(out) :: m integer :: i do i = 1, phs_config%n_in m(i) = phs_config%flv(i,1)%get_mass () end do end subroutine phs_config_get_masses_in @ %def phs_config_get_masses_in @ Return the MD5 sum of the configuration. <>= procedure :: get_md5sum => phs_config_get_md5sum +<>= + module function phs_config_get_md5sum (phs_config) result (md5sum) + class(phs_config_t), intent(in) :: phs_config + character(32) :: md5sum + end function phs_config_get_md5sum <>= - function phs_config_get_md5sum (phs_config) result (md5sum) + module function phs_config_get_md5sum (phs_config) result (md5sum) class(phs_config_t), intent(in) :: phs_config character(32) :: md5sum md5sum = phs_config%md5sum_phs_config end function phs_config_get_md5sum @ %def phs_config_get_md5sum @ \subsection{Phase-space point instance} The [[phs_t]] object holds the workspace for phase-space generation. In the base object, we have the MC input parameters [[r]] and the Jacobian factor [[f]], for each channel, and the incoming and outgoing momenta. Note: The [[active_channel]] array is not used yet, all elements are initialized with [[.true.]]. It should be touched by the integrator if it decides to drop irrelevant channels. <>= public :: phs_t <>= type, abstract :: phs_t class(phs_config_t), pointer :: config => null () logical :: r_defined = .false. integer :: selected_channel = 0 logical, dimension(:), allocatable :: active_channel real(default), dimension(:,:), allocatable :: r real(default), dimension(:), allocatable :: f real(default), dimension(:), allocatable :: m_in real(default), dimension(:), allocatable :: m_out real(default) :: flux = 0 real(default) :: volume = 0 type(lorentz_transformation_t) :: lt_cm_to_lab logical :: p_defined = .false. real(default) :: sqrts_hat = 0 type(vector4_t), dimension(:), allocatable :: p logical :: q_defined = .false. type(vector4_t), dimension(:), allocatable :: q contains <> end type phs_t @ %def phs_t @ Output. Since phase space may get complicated, we include a [[verbose]] option for the abstract [[write]] procedure. <>= procedure (phs_write), deferred :: write <>= abstract interface subroutine phs_write (object, unit, verbose) import class(phs_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: verbose end subroutine phs_write end interface @ %def phs_write @ This procedure can be called to print the contents of the base type. <>= procedure :: base_write => phs_base_write +<>= + module subroutine phs_base_write (object, unit) + class(phs_t), intent(in) :: object + integer, intent(in), optional :: unit + end subroutine phs_base_write <>= - subroutine phs_base_write (object, unit) + module subroutine phs_base_write (object, unit) class(phs_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, c, i u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "Partonic phase space: parameters" if (object%r_defined) then write (u, *) else write (u, "(1x,A)") "[undefined]" end if write (u, "(3x,A,999(1x," // FMT_19 // "))") "m_in =", object%m_in write (u, "(3x,A,999(1x," // FMT_19 // "))") "m_out =", object%m_out write (u, "(3x,A," // FMT_19 // ")") "Flux = ", object%flux write (u, "(3x,A," // FMT_19 // ")") "Volume = ", object%volume if (allocated (object%f)) then do c = 1, size (object%r, 2) write (u, "(1x,A,I0,A)", advance="no") "Channel #", c, ":" if (c == object%selected_channel) then write (u, "(1x,A)") "[selected]" else write (u, *) end if write (u, "(3x,A)", advance="no") "r =" do i = 1, size (object%r, 1) write (u, "(1x,F9.7)", advance="no") object%r(i,c) end do write (u, *) write (u, "(3x,A,1x,ES13.7)") "f =", object%f(c) end do end if write (u, "(1x,A)") "Partonic phase space: momenta" if (object%p_defined) then write (u, "(3x,A," // FMT_19 // ")") "sqrts = ", object%sqrts_hat end if write (u, "(1x,A)", advance="no") "Incoming:" if (object%p_defined) then write (u, *) else write (u, "(1x,A)") "[undefined]" end if if (allocated (object%p)) then do i = 1, size (object%p) call vector4_write (object%p(i), u) end do end if write (u, "(1x,A)", advance="no") "Outgoing:" if (object%q_defined) then write (u, *) else write (u, "(1x,A)") "[undefined]" end if if (allocated (object%q)) then do i = 1, size (object%q) call vector4_write (object%q(i), u) end do end if if (object%p_defined .and. .not. object%config%lab_is_cm) then write (u, "(1x,A)") "Transformation c.m -> lab frame" call lorentz_transformation_write (object%lt_cm_to_lab, u) end if end subroutine phs_base_write @ %def phs_base_write @ Finalizer. The base type does not need it, but extensions may. <>= procedure (phs_final), deferred :: final <>= abstract interface subroutine phs_final (object) import class(phs_t), intent(inout) :: object end subroutine phs_final end interface @ %def phs_final @ Initializer. Everything should be contained in the [[process_data]] configuration object, so we can require a universal interface. <>= procedure (phs_init), deferred :: init <>= abstract interface subroutine phs_init (phs, phs_config) import class(phs_t), intent(out) :: phs class(phs_config_t), intent(in), target :: phs_config end subroutine phs_init end interface @ %def phs_init @ The base version will just allocate the arrays. It should be called at the beginning of the implementation of [[phs_init]]. <>= procedure :: base_init => phs_base_init +<>= + module subroutine phs_base_init (phs, phs_config) + class(phs_t), intent(out) :: phs + class(phs_config_t), intent(in), target :: phs_config + end subroutine phs_base_init <>= - subroutine phs_base_init (phs, phs_config) + module subroutine phs_base_init (phs, phs_config) class(phs_t), intent(out) :: phs class(phs_config_t), intent(in), target :: phs_config - real(default), dimension(phs_config%n_in) :: m_in - real(default), dimension(phs_config%n_out) :: m_out phs%config => phs_config allocate (phs%active_channel (phs%config%n_channel)) phs%active_channel = .true. allocate (phs%r (phs%config%n_par, phs%config%n_channel)); phs%r = 0 allocate (phs%f (phs%config%n_channel)); phs%f = 0 allocate (phs%p (phs%config%n_in)) - !!! !!! !!! Workaround for gfortran 5.0 ICE - m_in = phs_config%flv(:phs_config%n_in, 1)%get_mass () - m_out = phs_config%flv(phs_config%n_in+1:, 1)%get_mass () - allocate (phs%m_in (phs%config%n_in), source = m_in) - !!! allocate (phs%m_in (phs%config%n_in), & - !!! source = phs_config%flv(:phs_config%n_in, 1)%get_mass ()) + allocate (phs%m_in (phs%config%n_in), & + source = phs_config%flv(:phs_config%n_in, 1)%get_mass ()) allocate (phs%q (phs%config%n_out)) - allocate (phs%m_out (phs%config%n_out), source = m_out) - !!! allocate (phs%m_out (phs%config%n_out), & - !!! source = phs_config%flv(phs_config%n_in+1:, 1)%get_mass ()) + allocate (phs%m_out (phs%config%n_out), & + source = phs_config%flv(phs_config%n_in+1:, 1)%get_mass ()) call phs%compute_flux () end subroutine phs_base_init @ %def phs_base_init @ Manually select a channel. <>= procedure :: select_channel => phs_base_select_channel +<>= + module subroutine phs_base_select_channel (phs, channel) + class(phs_t), intent(inout) :: phs + integer, intent(in), optional :: channel + end subroutine phs_base_select_channel <>= - subroutine phs_base_select_channel (phs, channel) + module subroutine phs_base_select_channel (phs, channel) class(phs_t), intent(inout) :: phs integer, intent(in), optional :: channel if (present (channel)) then phs%selected_channel = channel else phs%selected_channel = 0 end if end subroutine phs_base_select_channel @ %def phs_base_select_channel @ Set incoming momenta. Assume that array shapes match. If requested, compute the Lorentz transformation from the c.m.\ to the lab frame and apply that transformation to the incoming momenta. In the c.m.\ frame, the sum of three-momenta is zero. In a scattering process, the $z$ axis is the direction of the first beam, the second beam is along the negative $z$ axis. The transformation from the c.m.\ to the lab frame is a rotation from the $z$ axis to the boost axis followed by a boost, such that the c.m.\ momenta are transformed into the lab-frame momenta. In a decay process, we just boost along the flight direction, without rotation. <>= procedure :: set_incoming_momenta => phs_set_incoming_momenta +<>= + module subroutine phs_set_incoming_momenta (phs, p) + class(phs_t), intent(inout) :: phs + type(vector4_t), dimension(:), intent(in) :: p + end subroutine phs_set_incoming_momenta <>= - subroutine phs_set_incoming_momenta (phs, p) + module subroutine phs_set_incoming_momenta (phs, p) class(phs_t), intent(inout) :: phs type(vector4_t), dimension(:), intent(in) :: p type(vector4_t) :: p0, p1 type(lorentz_transformation_t) :: lt0 integer :: i phs%p = p if (phs%config%lab_is_cm) then phs%sqrts_hat = phs%config%sqrts phs%p = p phs%lt_cm_to_lab = identity else p0 = sum (p) if (phs%config%sqrts_fixed) then phs%sqrts_hat = phs%config%sqrts else phs%sqrts_hat = p0 ** 1 end if lt0 = boost (p0, phs%sqrts_hat) select case (phs%config%n_in) case (1) phs%lt_cm_to_lab = lt0 case (2) p1 = inverse (lt0) * p(1) phs%lt_cm_to_lab = lt0 * rotation_to_2nd (3, space_part (p1)) end select phs%p = inverse (phs%lt_cm_to_lab) * p end if phs%p_defined = .true. end subroutine phs_set_incoming_momenta @ %def phs_set_incoming_momenta @ Set outgoing momenta. Assume that array shapes match. The incoming momenta must be known, so we can apply the Lorentz transformation from c.m.\ to lab (inverse) to the momenta. <>= procedure :: set_outgoing_momenta => phs_set_outgoing_momenta +<>= + module subroutine phs_set_outgoing_momenta (phs, q) + class(phs_t), intent(inout) :: phs + type(vector4_t), dimension(:), intent(in) :: q + end subroutine phs_set_outgoing_momenta <>= - subroutine phs_set_outgoing_momenta (phs, q) + module subroutine phs_set_outgoing_momenta (phs, q) class(phs_t), intent(inout) :: phs type(vector4_t), dimension(:), intent(in) :: q integer :: i if (phs%p_defined) then if (phs%config%lab_is_cm) then phs%q = q else phs%q = inverse (phs%lt_cm_to_lab) * q end if phs%q_defined = .true. end if end subroutine phs_set_outgoing_momenta @ %def phs_set_outgoing_momenta @ Return outgoing momenta. Apply the c.m.\ to lab transformation if necessary. <>= procedure :: get_outgoing_momenta => phs_get_outgoing_momenta +<>= + module subroutine phs_get_outgoing_momenta (phs, q) + class(phs_t), intent(in) :: phs + type(vector4_t), dimension(:), intent(out) :: q + end subroutine phs_get_outgoing_momenta <>= - subroutine phs_get_outgoing_momenta (phs, q) + module subroutine phs_get_outgoing_momenta (phs, q) class(phs_t), intent(in) :: phs type(vector4_t), dimension(:), intent(out) :: q if (phs%p_defined .and. phs%q_defined) then if (phs%config%lab_is_cm) then q = phs%q else q = phs%lt_cm_to_lab * phs%q end if else q = vector4_null end if end subroutine phs_get_outgoing_momenta @ %def phs_get_outgoing_momenta @ <>= procedure :: lab_is_cm => phs_lab_is_cm +<>= + module function phs_lab_is_cm (phs) result (lab_is_cm) + logical :: lab_is_cm + class(phs_t), intent(in) :: phs + end function phs_lab_is_cm <>= - function phs_lab_is_cm (phs) result (lab_is_cm) + module function phs_lab_is_cm (phs) result (lab_is_cm) logical :: lab_is_cm class(phs_t), intent(in) :: phs lab_is_cm = phs%config%lab_is_cm end function phs_lab_is_cm @ %def phs_lab_is_cm @ <>= procedure :: get_n_tot => phs_get_n_tot +<>= + elemental module function phs_get_n_tot (phs) result (n_tot) + integer :: n_tot + class(phs_t), intent(in) :: phs + end function phs_get_n_tot <>= - elemental function phs_get_n_tot (phs) result (n_tot) + elemental module function phs_get_n_tot (phs) result (n_tot) integer :: n_tot class(phs_t), intent(in) :: phs n_tot = phs%config%n_tot end function phs_get_n_tot @ %def phs_get_n_tot @ <>= procedure :: set_lorentz_transformation => phs_set_lorentz_transformation +<>= + module subroutine phs_set_lorentz_transformation (phs, lt) + class(phs_t), intent(inout) :: phs + type(lorentz_transformation_t), intent(in) :: lt + end subroutine phs_set_lorentz_transformation <>= - subroutine phs_set_lorentz_transformation (phs, lt) + module subroutine phs_set_lorentz_transformation (phs, lt) class(phs_t), intent(inout) :: phs type(lorentz_transformation_t), intent(in) :: lt phs%lt_cm_to_lab = lt end subroutine phs_set_lorentz_transformation @ %def phs_set_lorentz_transformation @ <>= procedure :: get_lorentz_transformation => phs_get_lorentz_transformation +<>= + module function phs_get_lorentz_transformation (phs) result (lt) + type(lorentz_transformation_t) :: lt + class(phs_t), intent(in) :: phs + end function phs_get_lorentz_transformation <>= - function phs_get_lorentz_transformation (phs) result (lt) + module function phs_get_lorentz_transformation (phs) result (lt) type(lorentz_transformation_t) :: lt class(phs_t), intent(in) :: phs lt = phs%lt_cm_to_lab end function phs_get_lorentz_transformation @ %def phs_get_lorentz_transformation @ Return the input parameter array for a channel. <>= procedure :: get_mcpar => phs_get_mcpar +<>= + module subroutine phs_get_mcpar (phs, c, r) + class(phs_t), intent(in) :: phs + integer, intent(in) :: c + real(default), dimension(:), intent(out) :: r + end subroutine phs_get_mcpar <>= - subroutine phs_get_mcpar (phs, c, r) + module subroutine phs_get_mcpar (phs, c, r) class(phs_t), intent(in) :: phs integer, intent(in) :: c real(default), dimension(:), intent(out) :: r if (phs%r_defined) then r = phs%r(:,c) else r = 0 end if end subroutine phs_get_mcpar @ %def phs_get_mcpar @ Return the Jacobian factor for a channel. <>= procedure :: get_f => phs_get_f +<>= + module function phs_get_f (phs, c) result (f) + class(phs_t), intent(in) :: phs + integer, intent(in) :: c + real(default) :: f + end function phs_get_f <>= - function phs_get_f (phs, c) result (f) + module function phs_get_f (phs, c) result (f) class(phs_t), intent(in) :: phs integer, intent(in) :: c real(default) :: f if (phs%r_defined) then f = phs%f(c) else f = 0 end if end function phs_get_f @ %def phs_get_f @ Return the overall factor, which is the product of the flux factor for the incoming partons and the phase-space volume for the outgoing partons. <>= procedure :: get_overall_factor => phs_get_overall_factor +<>= + module function phs_get_overall_factor (phs) result (f) + class(phs_t), intent(in) :: phs + real(default) :: f + end function phs_get_overall_factor <>= - function phs_get_overall_factor (phs) result (f) + module function phs_get_overall_factor (phs) result (f) class(phs_t), intent(in) :: phs real(default) :: f f = phs%flux * phs%volume end function phs_get_overall_factor @ %def phs_get_overall_factor @ Compute flux factor. We do this during initialization (when the incoming momenta [[p]] are undefined), unless [[sqrts]] is variable. We do this again once for each phase-space point, but then we skip the calculation if [[sqrts]] is fixed. There are three different flux factors. \begin{enumerate} \item For a decaying massive particle, the factor is \begin{equation} f = (2\pi)^4 / (2M) \end{equation} \item For a $2\to n$ scattering process with $n>1$, the factor is \begin{equation} f = (2\pi)^4 / (2\sqrt{\lambda}) \end{equation} where for massless incoming particles, $\sqrt{\lambda} = s$. \item For a $2\to 1$ on-shell production process, the factor includes an extra $1/(2\pi)^3$ factor and a $1/m^2$ factor from the phase-space delta function $\delta (x_1x_2 - m^2/s)$, which originate from the one-particle phase space that we integrate out. \begin{equation} f = 2\pi / (2s m^2) \end{equation} The delta function is handled by the structure-function parameterization. \end{enumerate} <>= procedure :: compute_flux => phs_compute_flux procedure :: compute_base_flux => phs_compute_flux +<>= + module subroutine phs_compute_flux (phs) + class(phs_t), intent(inout) :: phs + end subroutine phs_compute_flux <>= - subroutine phs_compute_flux (phs) + module subroutine phs_compute_flux (phs) class(phs_t), intent(inout) :: phs real(default) :: s_hat, lda select case (phs%config%n_in) case (1) if (.not. phs%p_defined) then phs%flux = twopi4 / (2 * phs%m_in(1)) end if case (2) if (phs%p_defined) then if (phs%config%sqrts_fixed) then return else s_hat = sum (phs%p) ** 2 end if else if (phs%config%sqrts_fixed) then s_hat = phs%config%sqrts ** 2 else return end if end if select case (phs%config%n_out) case (2:) lda = lambda (s_hat, phs%m_in(1) ** 2, phs%m_in(2) ** 2) if (lda > 0) then phs%flux = conv * twopi4 / (2 * sqrt (lda)) else phs%flux = 0 end if case (1) phs%flux = conv * twopi & / (2 * phs%config%sqrts ** 2 * phs%m_out(1) ** 2) case default phs%flux = 0 end select end select end subroutine phs_compute_flux @ %def phs_compute_flux @ Evaluate the phase-space point for a particular channel and compute momenta, Jacobian, and phase-space volume. This is, of course, deferred to the implementation. <>= procedure (phs_evaluate_selected_channel), deferred :: & evaluate_selected_channel <>= abstract interface subroutine phs_evaluate_selected_channel (phs, c_in, r_in) import class(phs_t), intent(inout) :: phs integer, intent(in) :: c_in real(default), dimension(:), intent(in) :: r_in end subroutine phs_evaluate_selected_channel end interface @ %def phs_evaluate_selected_channel @ Compute the inverse mappings to completely fill the [[r]] and [[f]] arrays, for the non-selected channels. <>= procedure (phs_evaluate_other_channels), deferred :: & evaluate_other_channels <>= abstract interface subroutine phs_evaluate_other_channels (phs, c_in) import class(phs_t), intent(inout) :: phs integer, intent(in) :: c_in end subroutine phs_evaluate_other_channels end interface @ %def phs_evaluate_other_channels @ Inverse evaluation. If all momenta are known, we compute the inverse mappings to fill the [[r]] and [[f]] arrays. <>= procedure (phs_inverse), deferred :: inverse <>= abstract interface subroutine phs_inverse (phs) import class(phs_t), intent(inout) :: phs end subroutine phs_inverse end interface @ %def phs_inverse @ <>= procedure :: get_sqrts => phs_get_sqrts +<>= + module function phs_get_sqrts (phs) result (sqrts) + real(default) :: sqrts + class(phs_t), intent(in) :: phs + end function phs_get_sqrts <>= - function phs_get_sqrts (phs) result (sqrts) + module function phs_get_sqrts (phs) result (sqrts) real(default) :: sqrts class(phs_t), intent(in) :: phs sqrts = phs%config%sqrts end function phs_get_sqrts @ %def phs_get_sqrts @ \subsubsection{Uniform angular distribution} These procedures implement the uniform angular distribution, generated from two parameters $x_1$ and $x_2$: \begin{equation} \cos\theta = 1 - 2x_1, \qquad \phi = 2\pi x_2 \end{equation} We generate a rotation (Lorentz transformation) which rotates the positive $z$ axis into this point on the unit sphere. This rotation is applied to the [[p]] momenta, which are assumed to be back-to-back, on-shell, and with the correct mass. We do not compute a Jacobian (constant). The uniform distribution is assumed to be normalized. <>= public :: compute_kinematics_solid_angle +<>= + module subroutine compute_kinematics_solid_angle (p, q, x) + type(vector4_t), dimension(2), intent(in) :: p + type(vector4_t), dimension(2), intent(out) :: q + real(default), dimension(2), intent(in) :: x + end subroutine compute_kinematics_solid_angle <>= - subroutine compute_kinematics_solid_angle (p, q, x) + module subroutine compute_kinematics_solid_angle (p, q, x) type(vector4_t), dimension(2), intent(in) :: p type(vector4_t), dimension(2), intent(out) :: q real(default), dimension(2), intent(in) :: x real(default) :: ct, st, phi type(lorentz_transformation_t) :: rot integer :: i ct = 1 - 2*x(1) st = sqrt (1 - ct**2) phi = twopi * x(2) rot = rotation (phi, 3) * rotation (ct, st, 2) do i = 1, 2 q(i) = rot * p(i) end do end subroutine compute_kinematics_solid_angle @ %def compute_kinematics_solid_angle @ This is the inverse transformation. We assume that the outgoing momenta are rotated versions of the incoming momenta, back-to-back. Thus, we determine the angles from $q(1)$ alone. [[p]] is unused. <>= public :: inverse_kinematics_solid_angle +<>= + module subroutine inverse_kinematics_solid_angle (p, q, x) + type(vector4_t), dimension(:), intent(in) :: p + type(vector4_t), dimension(2), intent(in) :: q + real(default), dimension(2), intent(out) :: x + end subroutine inverse_kinematics_solid_angle <>= - subroutine inverse_kinematics_solid_angle (p, q, x) + module subroutine inverse_kinematics_solid_angle (p, q, x) type(vector4_t), dimension(:), intent(in) :: p type(vector4_t), dimension(2), intent(in) :: q real(default), dimension(2), intent(out) :: x real(default) :: ct, phi ct = polar_angle_ct (q(1)) phi = azimuthal_angle (q(1)) x(1) = (1 - ct) / 2 x(2) = phi / twopi end subroutine inverse_kinematics_solid_angle @ %def inverse_kinematics_solid_angle @ \subsection{Auxiliary stuff} The [[pacify]] subroutine, which is provided by the Lorentz module, has the purpose of setting numbers to zero which are (by comparing with a [[tolerance]] parameter) considered equivalent with zero. This is useful for numerical checks. <>= public :: pacify <>= interface pacify module procedure pacify_phs end interface pacify +<>= + module subroutine pacify_phs (phs) + class(phs_t), intent(inout) :: phs + end subroutine pacify_phs <>= - subroutine pacify_phs (phs) + module subroutine pacify_phs (phs) class(phs_t), intent(inout) :: phs if (phs%p_defined) then call pacify (phs%p, 30 * epsilon (1._default) * phs%config%sqrts) call pacify (phs%lt_cm_to_lab, 30 * epsilon (1._default)) end if if (phs%q_defined) then call pacify (phs%q, 30 * epsilon (1._default) * phs%config%sqrts) end if end subroutine pacify_phs @ %def pacify @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[phs_base_ut.f90]]>>= <> module phs_base_ut use unit_tests use phs_base_uti <> <> <> contains <> end module phs_base_ut @ %def phs_base_ut @ <<[[phs_base_uti.f90]]>>= <> module phs_base_uti <> <> use diagnostics use io_units use format_defs, only: FMT_19 use physics_defs, only: BORN use lorentz use flavors use model_data use process_constants use phs_base <> <> <> <> contains <> <> end module phs_base_uti @ %def phs_base_ut @ API: driver for the unit tests below. <>= public :: phs_base_test <>= subroutine phs_base_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine phs_base_test @ %def phs_base_test @ \subsubsection{Test process data} We provide a procedure that initializes a test case for the process constants. This set of process data contains just the minimal contents that we need for the phase space. The rest is left uninitialized. <>= public :: init_test_process_data <>= subroutine init_test_process_data (id, data) type(process_constants_t), intent(out) :: data type(string_t), intent(in), optional :: id if (present (id)) then data%id = id else data%id = "testproc" end if data%model_name = "Test" data%n_in = 2 data%n_out = 2 data%n_flv = 1 allocate (data%flv_state (data%n_in + data%n_out, data%n_flv)) data%flv_state = 25 end subroutine init_test_process_data @ %def init_test_process_data @ This is the variant for a decay process. <>= public :: init_test_decay_data <>= subroutine init_test_decay_data (id, data) type(process_constants_t), intent(out) :: data type(string_t), intent(in), optional :: id if (present (id)) then data%id = id else data%id = "testproc" end if data%model_name = "Test" data%n_in = 1 data%n_out = 2 data%n_flv = 1 allocate (data%flv_state (data%n_in + data%n_out, data%n_flv)) data%flv_state(:,1) = [25, 6, -6] end subroutine init_test_decay_data @ %def init_test_decay_data @ \subsubsection{Test kinematics configuration} This is a trivial implementation of the [[phs_config_t]] configuration object. <>= public :: phs_test_config_t <>= type, extends (phs_config_t) :: phs_test_config_t logical :: create_equivalences = .false. contains procedure :: final => phs_test_config_final procedure :: write => phs_test_config_write procedure :: configure => phs_test_config_configure procedure :: startup_message => phs_test_config_startup_message procedure, nopass :: allocate_instance => phs_test_config_allocate_instance end type phs_test_config_t @ %def phs_test_config_t @ The finalizer is empty. <>= subroutine phs_test_config_final (object) class(phs_test_config_t), intent(inout) :: object end subroutine phs_test_config_final @ %def phs_test_config_final @ The [[lab_is_cm]] parameter is not tested here; we defer this to the [[phs_single]] implementation. <>= subroutine phs_test_config_write (object, unit, include_id) class(phs_test_config_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: include_id integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Partonic phase-space configuration:" call object%base_write (unit) end subroutine phs_test_config_write subroutine phs_test_config_configure (phs_config, sqrts, & sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, & ignore_mismatch, nlo_type, subdir) class(phs_test_config_t), intent(inout) :: phs_config real(default), intent(in) :: sqrts logical, intent(in), optional :: sqrts_fixed logical, intent(in), optional :: lab_is_cm logical, intent(in), optional :: azimuthal_dependence logical, intent(in), optional :: rebuild logical, intent(in), optional :: ignore_mismatch integer, intent(in), optional :: nlo_type type(string_t), intent(in), optional :: subdir phs_config%n_channel = 2 phs_config%n_par = 2 phs_config%sqrts = sqrts if (.not. present (nlo_type)) & phs_config%nlo_type = BORN if (present (sqrts_fixed)) then phs_config%sqrts_fixed = sqrts_fixed end if if (present (lab_is_cm)) then phs_config%lab_is_cm = lab_is_cm end if if (present (azimuthal_dependence)) then phs_config%azimuthal_dependence = azimuthal_dependence end if if (allocated (phs_config%channel)) deallocate (phs_config%channel) allocate (phs_config%channel (phs_config%n_channel)) if (phs_config%create_equivalences) then call setup_test_equivalences (phs_config) call setup_test_channel_props (phs_config) end if call phs_config%compute_md5sum () end subroutine phs_test_config_configure @ %def phs_test_config_write @ %def phs_test_config_configure @ If requested, we make up an arbitrary set of equivalences. <>= subroutine setup_test_equivalences (phs_config) class(phs_test_config_t), intent(inout) :: phs_config integer :: i associate (channel => phs_config%channel(1)) allocate (channel%eq (2)) do i = 1, size (channel%eq) call channel%eq(i)%init (phs_config%n_par) end do associate (eq => channel%eq(1)) eq%c = 1; eq%perm = [1, 2]; eq%mode = [EQ_IDENTITY, EQ_SYMMETRIC] end associate associate (eq => channel%eq(2)) eq%c = 2; eq%perm = [2, 1]; eq%mode = [EQ_INVARIANT, EQ_IDENTITY] end associate end associate end subroutine setup_test_equivalences @ %def setup_test_equivalences @ Ditto, for channel properties. <>= subroutine setup_test_channel_props (phs_config) class(phs_test_config_t), intent(inout) :: phs_config associate (channel => phs_config%channel(2)) call channel%set_resonant (140._default, 3.1415_default) end associate end subroutine setup_test_channel_props @ %def setup_test_channel_props @ Startup message <>= subroutine phs_test_config_startup_message (phs_config, unit) class(phs_test_config_t), intent(in) :: phs_config integer, intent(in), optional :: unit call phs_config%base_startup_message (unit) write (msg_buffer, "(A)") "Phase space: Test" call msg_message (unit = unit) end subroutine phs_test_config_startup_message @ %def phs_test_config_startup_message @ The instance type that matches [[phs_test_config_t]] is [[phs_test_t]]. <>= subroutine phs_test_config_allocate_instance (phs) class(phs_t), intent(inout), pointer :: phs allocate (phs_test_t :: phs) end subroutine phs_test_config_allocate_instance @ %def phs_test_config_allocate_instance @ \subsubsection{Test kinematics implementation} This implementation of kinematics generates a simple two-particle configuration from the incoming momenta. The incoming momenta must be in the c.m.\ system, all masses equal. There are two channels: one generates $\cos\theta$ and $\phi$ uniformly, in the other channel we map the $r_1$ parameter which belongs to $\cos\theta$. We should store the mass parameter that we need. <>= public :: phs_test_t <>= type, extends (phs_t) :: phs_test_t real(default) :: m = 0 real(default), dimension(:), allocatable :: x contains <> end type phs_test_t @ %def phs_test_t @ Output. The specific data are displayed only if [[verbose]] is set. <>= procedure :: write => phs_test_write <>= subroutine phs_test_write (object, unit, verbose) class(phs_test_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u logical :: verb u = given_output_unit (unit) verb = .false.; if (present (verbose)) verb = verbose if (verb) then write (u, "(1x,A)") "Partonic phase space: data" write (u, "(3x,A," // FMT_19 // ")") "m = ", object%m end if call object%base_write (u) end subroutine phs_test_write @ %def phs_test_write @ The finalizer is empty. <>= procedure :: final => phs_test_final <>= subroutine phs_test_final (object) class(phs_test_t), intent(inout) :: object end subroutine phs_test_final @ %def phs_test_final @ Initialization: set the mass value. <>= procedure :: init => phs_test_init <>= subroutine phs_test_init (phs, phs_config) class(phs_test_t), intent(out) :: phs class(phs_config_t), intent(in), target :: phs_config call phs%base_init (phs_config) phs%m = phs%config%flv(1,1)%get_mass () allocate (phs%x (phs_config%n_par), source = 0._default) end subroutine phs_test_init @ %def phs_test_init @ Evaluation. In channel 1, we uniformly generate $\cos\theta$ and $\phi$, with Jacobian normalized to one. In channel 2, we prepend a mapping $r_1 \to r_1^(1/3)$ with Jacobian $f=3r_1^2$. The component [[x]] is allocated in the first subroutine, used and deallocated in the second one. <>= procedure :: evaluate_selected_channel => phs_test_evaluate_selected_channel procedure :: evaluate_other_channels => phs_test_evaluate_other_channels <>= subroutine phs_test_evaluate_selected_channel (phs, c_in, r_in) class(phs_test_t), intent(inout) :: phs integer, intent(in) :: c_in real(default), intent(in), dimension(:) :: r_in if (phs%p_defined) then call phs%select_channel (c_in) phs%r(:,c_in) = r_in select case (c_in) case (1) phs%x = r_in case (2) phs%x(1) = r_in(1) ** (1 / 3._default) phs%x(2) = r_in(2) end select call compute_kinematics_solid_angle (phs%p, phs%q, phs%x) phs%volume = 1 phs%q_defined = .true. end if end subroutine phs_test_evaluate_selected_channel subroutine phs_test_evaluate_other_channels (phs, c_in) class(phs_test_t), intent(inout) :: phs integer, intent(in) :: c_in integer :: c, n_channel if (phs%p_defined) then n_channel = phs%config%n_channel do c = 1, n_channel if (c /= c_in) then call inverse_kinematics_solid_angle (phs%p, phs%q, phs%x) select case (c) case (1) phs%r(:,c) = phs%x case (2) phs%r(1,c) = phs%x(1) ** 3 phs%r(2,c) = phs%x(2) end select end if end do phs%f(1) = 1 if (phs%r(1,2) /= 0) then phs%f(2) = 1 / (3 * phs%r(1,2) ** (2/3._default)) else phs%f(2) = 0 end if phs%r_defined = .true. end if end subroutine phs_test_evaluate_other_channels @ %def phs_test_evaluate_selected_channels @ %def phs_test_evaluate_other_channels @ Inverse evaluation. <>= procedure :: inverse => phs_test_inverse <>= subroutine phs_test_inverse (phs) class(phs_test_t), intent(inout) :: phs integer :: c, n_channel real(default), dimension(:), allocatable :: x if (phs%p_defined .and. phs%q_defined) then call phs%select_channel () n_channel = phs%config%n_channel allocate (x (phs%config%n_par)) do c = 1, n_channel call inverse_kinematics_solid_angle (phs%p, phs%q, x) select case (c) case (1) phs%r(:,c) = x case (2) phs%r(1,c) = x(1) ** 3 phs%r(2,c) = x(2) end select end do phs%f(1) = 1 if (phs%r(1,2) /= 0) then phs%f(2) = 1 / (3 * phs%r(1,2) ** (2/3._default)) else phs%f(2) = 0 end if phs%volume = 1 phs%r_defined = .true. end if end subroutine phs_test_inverse @ %def phs_test_inverse @ \subsubsection{Phase-space configuration data} Construct and display a test phase-space configuration object. <>= call test (phs_base_1, "phs_base_1", & "phase-space configuration", & u, results) <>= public :: phs_base_1 <>= subroutine phs_base_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(process_constants_t) :: process_data class(phs_config_t), allocatable :: phs_data write (u, "(A)") "* Test output: phs_base_1" write (u, "(A)") "* Purpose: initialize and display & &test phase-space configuration data" write (u, "(A)") call model%init_test () write (u, "(A)") "* Initialize a process and a matching & &phase-space configuration" write (u, "(A)") call init_test_process_data (var_str ("phs_base_1"), process_data) allocate (phs_test_config_t :: phs_data) call phs_data%init (process_data, model) call phs_data%write (u) call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_base_1" end subroutine phs_base_1 @ %def phs_base_1 @ \subsubsection{Phase space evaluation} Compute kinematics for given parameters, also invert the calculation. <>= call test (phs_base_2, "phs_base_2", & "phase-space evaluation", & u, results) <>= public :: phs_base_2 <>= subroutine phs_base_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(process_constants_t) :: process_data real(default) :: sqrts, E class(phs_config_t), allocatable, target :: phs_data class(phs_t), pointer :: phs => null () type(vector4_t), dimension(2) :: p, q write (u, "(A)") "* Test output: phs_base_2" write (u, "(A)") "* Purpose: test simple two-channel phase space" write (u, "(A)") call model%init_test () call flv%init (25, model) write (u, "(A)") "* Initialize a process and a matching & &phase-space configuration" write (u, "(A)") call init_test_process_data (var_str ("phs_base_2"), process_data) allocate (phs_test_config_t :: phs_data) call phs_data%init (process_data, model) sqrts = 1000._default call phs_data%configure (sqrts) call phs_data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize the phase-space instance" write (u, "(A)") call phs_data%allocate_instance (phs) select type (phs) type is (phs_test_t) call phs%init (phs_data) end select call phs%write (u, verbose=.true.) write (u, "(A)") write (u, "(A)") "* Set incoming momenta" write (u, "(A)") E = sqrts / 2 p(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) p(2) = vector4_moving (E,-sqrt (E**2 - flv%get_mass ()**2), 3) call phs%set_incoming_momenta (p) call phs%compute_flux () call phs%write (u) write (u, "(A)") write (u, "(A)") "* Compute phase-space point in channel 1 & &for x = 0.5, 0.125" write (u, "(A)") call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default]) call phs%evaluate_other_channels (1) call phs%write (u) write (u, "(A)") write (u, "(A)") "* Compute phase-space point in channel 2 & &for x = 0.125, 0.125" write (u, "(A)") call phs%evaluate_selected_channel (2, [0.125_default, 0.125_default]) call phs%evaluate_other_channels (2) call phs%write (u) write (u, "(A)") write (u, "(A)") "* Inverse kinematics" write (u, "(A)") call phs%get_outgoing_momenta (q) deallocate (phs) call phs_data%allocate_instance (phs) call phs%init (phs_data) sqrts = 1000._default select type (phs_data) type is (phs_test_config_t) call phs_data%configure (sqrts) end select call phs%set_incoming_momenta (p) call phs%compute_flux () call phs%set_outgoing_momenta (q) call phs%inverse () call phs%write (u) call phs%final () deallocate (phs) call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_base_2" end subroutine phs_base_2 @ %def phs_base_2 @ \subsubsection{Phase-space equivalences} Construct a test phase-space configuration which contains channel equivalences. <>= call test (phs_base_3, "phs_base_3", & "channel equivalences", & u, results) <>= public :: phs_base_3 <>= subroutine phs_base_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(process_constants_t) :: process_data class(phs_config_t), allocatable :: phs_data write (u, "(A)") "* Test output: phs_base_3" write (u, "(A)") "* Purpose: construct phase-space configuration data & &with equivalences" write (u, "(A)") call model%init_test () write (u, "(A)") "* Initialize a process and a matching & &phase-space configuration" write (u, "(A)") call init_test_process_data (var_str ("phs_base_3"), process_data) allocate (phs_test_config_t :: phs_data) call phs_data%init (process_data, model) select type (phs_data) type is (phs_test_config_t) phs_data%create_equivalences = .true. end select call phs_data%configure (1000._default) call phs_data%write (u) call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_base_3" end subroutine phs_base_3 @ %def phs_base_3 @ \subsubsection{MD5 sum checks} Construct a test phase-space configuration, compute and compare MD5 sums. <>= call test (phs_base_4, "phs_base_4", & "MD5 sum", & u, results) <>= public :: phs_base_4 <>= subroutine phs_base_4 (u) integer, intent(in) :: u type(model_data_t), target :: model type(process_constants_t) :: process_data class(phs_config_t), allocatable :: phs_data write (u, "(A)") "* Test output: phs_base_4" write (u, "(A)") "* Purpose: compute and compare MD5 sums" write (u, "(A)") call model%init_test () write (u, "(A)") "* Model parameters" write (u, "(A)") call model%write (unit = u, & show_parameters = .true., & show_particles = .false., show_vertices = .false.) write (u, "(A)") write (u, "(A)") "* Initialize a process and a matching & &phase-space configuration" write (u, "(A)") call init_test_process_data (var_str ("phs_base_4"), process_data) process_data%md5sum = "test_process_data_m6sum_12345678" allocate (phs_test_config_t :: phs_data) call phs_data%init (process_data, model) call phs_data%compute_md5sum () call phs_data%write (u) write (u, "(A)") write (u, "(A)") "* Modify model parameter" write (u, "(A)") call model%set_par (var_str ("ms"), 100._default) call model%write (show_parameters = .true., & show_particles = .false., show_vertices = .false.) write (u, "(A)") write (u, "(A)") "* PHS configuration" write (u, "(A)") call phs_data%compute_md5sum () call phs_data%write (u) call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_base_4" end subroutine phs_base_4 @ %def phs_base_4 @ \subsubsection{Phase-space channel collection} Set up an array of various phase-space channels and collect them in a list. <>= call test (phs_base_5, "phs_base_5", & "channel collection", & u, results) <>= public :: phs_base_5 <>= subroutine phs_base_5 (u) integer, intent(in) :: u type(phs_channel_t), dimension(:), allocatable :: channel type(phs_channel_collection_t) :: coll integer :: i, n write (u, "(A)") "* Test output: phs_base_5" write (u, "(A)") "* Purpose: collect channel properties" write (u, "(A)") write (u, "(A)") "* Set up an array of channels" write (u, "(A)") n = 6 allocate (channel (n)) call channel(2)%set_resonant (75._default, 3._default) call channel(4)%set_resonant (130._default, 1._default) call channel(5)%set_resonant (75._default, 3._default) call channel(6)%set_on_shell (33._default) do i = 1, n write (u, "(1x,I0)", advance="no") i call channel(i)%write (u) end do write (u, "(A)") write (u, "(A)") "* Collect distinct properties" write (u, "(A)") do i = 1, n call coll%push (channel(i)) end do write (u, "(1x,A,I0)") "n = ", coll%get_n () write (u, "(A)") call coll%write (u) write (u, "(A)") write (u, "(A)") "* Channel array with collection index assigned" write (u, "(A)") do i = 1, n write (u, "(1x,I0)", advance="no") i call channel(i)%write (u) end do write (u, "(A)") write (u, "(A)") "* Cleanup" call coll%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_base_5" end subroutine phs_base_5 @ %def phs_base_5 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \clearpage \section{Dummy phase space} This module implements a dummy phase space module for cases where the program structure demands the existence of a phase-space module, but no phase space integration is performed. <<[[phs_none.f90]]>>= <> module phs_none <> <> - use io_units, only: given_output_unit - use diagnostics, only: msg_message, msg_fatal use phs_base, only: phs_config_t, phs_t <> <> <> + interface +<> + end interface + contains -<> +<> end module phs_none @ %def phs_none @ +<<[[phs_none_sub.f90]]>>= +<> + +submodule (phs_none) phs_none_s + + use io_units, only: given_output_unit + use diagnostics, only: msg_message, msg_fatal + + implicit none + +contains + +<> + +end submodule phs_none_s + +@ %def phs_none_s +@ \subsection{Configuration} Nothing to configure, but we provide the type and methods. <>= public :: phs_none_config_t <>= type, extends (phs_config_t) :: phs_none_config_t contains <> end type phs_none_config_t @ %def phs_none_config_t @ The finalizer is empty. <>= procedure :: final => phs_none_config_final +<>= + module subroutine phs_none_config_final (object) + class(phs_none_config_t), intent(inout) :: object + end subroutine phs_none_config_final <>= - subroutine phs_none_config_final (object) + module subroutine phs_none_config_final (object) class(phs_none_config_t), intent(inout) :: object end subroutine phs_none_config_final @ %def phs_none_final @ Output. No contents, just an informative line. <>= procedure :: write => phs_none_config_write +<>= + module subroutine phs_none_config_write (object, unit, include_id) + class(phs_none_config_t), intent(in) :: object + integer, intent(in), optional :: unit + logical, intent(in), optional :: include_id + end subroutine phs_none_config_write <>= - subroutine phs_none_config_write (object, unit, include_id) + module subroutine phs_none_config_write (object, unit, include_id) class(phs_none_config_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: include_id integer :: u u = given_output_unit (unit) - write (u, "(1x,A)") "Partonic phase-space configuration: non-functional dummy" + write (u, "(1x,A)") & + "Partonic phase-space configuration: non-functional dummy" end subroutine phs_none_config_write @ %def phs_none_config_write -@ Configuration: we have to implement this method, but it obviously does nothing. +@ Configuration: we have to implement this method, but it obviously +does nothing. <>= procedure :: configure => phs_none_config_configure +<>= + module subroutine phs_none_config_configure (phs_config, sqrts, & + sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, & + ignore_mismatch, nlo_type, subdir) + class(phs_none_config_t), intent(inout) :: phs_config + real(default), intent(in) :: sqrts + logical, intent(in), optional :: sqrts_fixed + logical, intent(in), optional :: lab_is_cm + logical, intent(in), optional :: azimuthal_dependence + logical, intent(in), optional :: rebuild + logical, intent(in), optional :: ignore_mismatch + integer, intent(in), optional :: nlo_type + type(string_t), intent(in), optional :: subdir + end subroutine phs_none_config_configure <>= - subroutine phs_none_config_configure (phs_config, sqrts, & - sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, ignore_mismatch, & - nlo_type, subdir) + module subroutine phs_none_config_configure (phs_config, sqrts, & + sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, & + ignore_mismatch, nlo_type, subdir) class(phs_none_config_t), intent(inout) :: phs_config real(default), intent(in) :: sqrts logical, intent(in), optional :: sqrts_fixed logical, intent(in), optional :: lab_is_cm logical, intent(in), optional :: azimuthal_dependence logical, intent(in), optional :: rebuild logical, intent(in), optional :: ignore_mismatch integer, intent(in), optional :: nlo_type type(string_t), intent(in), optional :: subdir end subroutine phs_none_config_configure @ %def phs_none_config_configure @ Startup message, after configuration is complete. <>= procedure :: startup_message => phs_none_config_startup_message +<>= + module subroutine phs_none_config_startup_message (phs_config, unit) + class(phs_none_config_t), intent(in) :: phs_config + integer, intent(in), optional :: unit + end subroutine phs_none_config_startup_message <>= - subroutine phs_none_config_startup_message (phs_config, unit) + module subroutine phs_none_config_startup_message (phs_config, unit) class(phs_none_config_t), intent(in) :: phs_config integer, intent(in), optional :: unit call msg_message ("Phase space: none") end subroutine phs_none_config_startup_message @ %def phs_none_config_startup_message @ Allocate an instance: the actual phase-space object. +Gfortran 7/8/9 bug: has to remain in the main module. <>= procedure, nopass :: allocate_instance => phs_none_config_allocate_instance -<>= +<>= subroutine phs_none_config_allocate_instance (phs) class(phs_t), intent(inout), pointer :: phs allocate (phs_none_t :: phs) end subroutine phs_none_config_allocate_instance @ %def phs_none_config_allocate_instance @ \subsection{Kinematics implementation} This is considered as empty, but we have to implement the minimal set of methods. <>= public :: phs_none_t <>= type, extends (phs_t) :: phs_none_t contains <> end type phs_none_t @ %def phs_none_t @ Output. <>= procedure :: write => phs_none_write +<>= + module subroutine phs_none_write (object, unit, verbose) + class(phs_none_t), intent(in) :: object + integer, intent(in), optional :: unit + logical, intent(in), optional :: verbose + end subroutine phs_none_write <>= - subroutine phs_none_write (object, unit, verbose) + module subroutine phs_none_write (object, unit, verbose) class(phs_none_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit) write (u, "(A)") "Partonic phase space: none" end subroutine phs_none_write @ %def phs_none_write @ The finalizer is empty. <>= procedure :: final => phs_none_final +<>= + module subroutine phs_none_final (object) + class(phs_none_t), intent(inout) :: object + end subroutine phs_none_final <>= - subroutine phs_none_final (object) + module subroutine phs_none_final (object) class(phs_none_t), intent(inout) :: object end subroutine phs_none_final @ %def phs_none_final @ Initialization, trivial. <>= procedure :: init => phs_none_init +<>= + module subroutine phs_none_init (phs, phs_config) + class(phs_none_t), intent(out) :: phs + class(phs_config_t), intent(in), target :: phs_config + end subroutine phs_none_init <>= - subroutine phs_none_init (phs, phs_config) + module subroutine phs_none_init (phs, phs_config) class(phs_none_t), intent(out) :: phs class(phs_config_t), intent(in), target :: phs_config call phs%base_init (phs_config) end subroutine phs_none_init @ %def phs_none_init @ Evaluation. This must not be called at all. <>= procedure :: evaluate_selected_channel => phs_none_evaluate_selected_channel procedure :: evaluate_other_channels => phs_none_evaluate_other_channels +<>= + module subroutine phs_none_evaluate_selected_channel (phs, c_in, r_in) + class(phs_none_t), intent(inout) :: phs + integer, intent(in) :: c_in + real(default), intent(in), dimension(:) :: r_in + end subroutine phs_none_evaluate_selected_channel + module subroutine phs_none_evaluate_other_channels (phs, c_in) + class(phs_none_t), intent(inout) :: phs + integer, intent(in) :: c_in + end subroutine phs_none_evaluate_other_channels <>= - subroutine phs_none_evaluate_selected_channel (phs, c_in, r_in) + module subroutine phs_none_evaluate_selected_channel (phs, c_in, r_in) class(phs_none_t), intent(inout) :: phs integer, intent(in) :: c_in real(default), intent(in), dimension(:) :: r_in - call msg_fatal ("Phase space: attempt to evaluate with the 'phs_none' method") + call msg_fatal & + ("Phase space: attempt to evaluate with the 'phs_none' method") end subroutine phs_none_evaluate_selected_channel - subroutine phs_none_evaluate_other_channels (phs, c_in) + module subroutine phs_none_evaluate_other_channels (phs, c_in) class(phs_none_t), intent(inout) :: phs integer, intent(in) :: c_in end subroutine phs_none_evaluate_other_channels @ %def phs_none_evaluate_selected_channel @ %def phs_none_evaluate_other_channels @ Inverse evaluation, likewise. <>= procedure :: inverse => phs_none_inverse +<>= + module subroutine phs_none_inverse (phs) + class(phs_none_t), intent(inout) :: phs + end subroutine phs_none_inverse <>= - subroutine phs_none_inverse (phs) + module subroutine phs_none_inverse (phs) class(phs_none_t), intent(inout) :: phs - call msg_fatal ("Phase space: attempt to evaluate inverse with the 'phs_none' method") + call msg_fatal ("Phase space: attempt to evaluate inverse " // & + "with the 'phs_none' method") end subroutine phs_none_inverse @ %def phs_none_inverse @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[phs_none_ut.f90]]>>= <> module phs_none_ut use unit_tests use phs_none_uti <> <> contains <> end module phs_none_ut @ %def phs_none_ut @ <<[[phs_none_uti.f90]]>>= <> module phs_none_uti <> <> use flavors use lorentz use model_data use process_constants use phs_base use phs_none use phs_base_ut, only: init_test_process_data, init_test_decay_data <> <> contains <> end module phs_none_uti @ %def phs_none_ut @ API: driver for the unit tests below. <>= public :: phs_none_test <>= subroutine phs_none_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine phs_none_test @ %def phs_none_test @ \subsubsection{Phase-space configuration data} Construct and display a test phase-space configuration object. Also check the [[azimuthal_dependence]] flag. <>= call test (phs_none_1, "phs_none_1", & "phase-space configuration dummy", & u, results) <>= public :: phs_none_1 <>= subroutine phs_none_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(process_constants_t) :: process_data class(phs_config_t), allocatable :: phs_data real(default) :: sqrts write (u, "(A)") "* Test output: phs_none_1" write (u, "(A)") "* Purpose: display & &phase-space configuration data" write (u, "(A)") allocate (phs_none_config_t :: phs_data) call phs_data%init (process_data, model) sqrts = 1000._default call phs_data%configure (sqrts, azimuthal_dependence=.false.) call phs_data%write (u) call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_none_1" end subroutine phs_none_1 @ %def phs_none_1 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \clearpage \section{Single-particle phase space} This module implements the phase space for a single particle, i.e., the solid angle, in a straightforward parameterization with a single channel. The phase-space implementation may be used either for $1\to 2$ decays or for $2\to 2$ scattering processes, so the number of incoming particles is the only free parameter in the configuration. In the latter case, we should restrict its use to non-resonant s-channel processes, because there is no mapping of the scattering angle. (We might extend this later to account for generic $2\to 2$ situations, e.g., account for a Coulomb singularity or detect an s-channel resonance structure that requires matching structure-function mappings.) This is derived from the [[phs_test]] implementation in the [[phs_base]] module above, even more simplified, but intended for actual use. <<[[phs_single.f90]]>>= <> module phs_single <> <> - use io_units - use constants - use numeric_utils - use diagnostics - use os_interface use lorentz - use physics_defs - use model_data - use flavors - use process_constants use phs_base <> <> <> + interface +<> + end interface + contains -<> +<> end module phs_single @ %def phs_single @ +<<[[phs_single_sub.f90]]>>= +<> + +submodule (phs_single) phs_single_s + + use io_units + use constants + use numeric_utils + use diagnostics + use physics_defs + + implicit none + +contains + +<> + +end submodule phs_single_s + +@ %def phs_single_s +@ \subsection{Configuration} <>= public :: phs_single_config_t <>= type, extends (phs_config_t) :: phs_single_config_t contains <> end type phs_single_config_t @ %def phs_single_config_t @ The finalizer is empty. <>= procedure :: final => phs_single_config_final +<>= + module subroutine phs_single_config_final (object) + class(phs_single_config_t), intent(inout) :: object + end subroutine phs_single_config_final <>= - subroutine phs_single_config_final (object) + module subroutine phs_single_config_final (object) class(phs_single_config_t), intent(inout) :: object end subroutine phs_single_config_final @ %def phs_single_final @ Output. <>= procedure :: write => phs_single_config_write +<>= + module subroutine phs_single_config_write (object, unit, include_id) + class(phs_single_config_t), intent(in) :: object + integer, intent(in), optional :: unit + logical, intent(in), optional :: include_id + end subroutine phs_single_config_write <>= - subroutine phs_single_config_write (object, unit, include_id) + module subroutine phs_single_config_write (object, unit, include_id) class(phs_single_config_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: include_id integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Partonic phase-space configuration (single-particle):" call object%base_write (unit) end subroutine phs_single_config_write @ %def phs_single_config_write @ Configuration: there is only one channel and two parameters. The second parameter is the azimuthal angle, which may be a flat dimension. <>= procedure :: configure => phs_single_config_configure +<>= + module subroutine phs_single_config_configure (phs_config, sqrts, & + sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, & + ignore_mismatch, nlo_type, subdir) + class(phs_single_config_t), intent(inout) :: phs_config + real(default), intent(in) :: sqrts + logical, intent(in), optional :: sqrts_fixed + logical, intent(in), optional :: lab_is_cm + logical, intent(in), optional :: azimuthal_dependence + logical, intent(in), optional :: rebuild + logical, intent(in), optional :: ignore_mismatch + integer, intent(in), optional :: nlo_type + type(string_t), intent(in), optional :: subdir + end subroutine phs_single_config_configure <>= - subroutine phs_single_config_configure (phs_config, sqrts, & - sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, ignore_mismatch, & - nlo_type, subdir) + module subroutine phs_single_config_configure (phs_config, sqrts, & + sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, & + ignore_mismatch, nlo_type, subdir) class(phs_single_config_t), intent(inout) :: phs_config real(default), intent(in) :: sqrts logical, intent(in), optional :: sqrts_fixed logical, intent(in), optional :: lab_is_cm logical, intent(in), optional :: azimuthal_dependence logical, intent(in), optional :: rebuild logical, intent(in), optional :: ignore_mismatch integer, intent(in), optional :: nlo_type type(string_t), intent(in), optional :: subdir if (.not. present (nlo_type)) & phs_config%nlo_type = BORN if (phs_config%n_out == 2) then phs_config%n_channel = 1 phs_config%n_par = 2 phs_config%sqrts = sqrts if (present (sqrts_fixed)) phs_config%sqrts_fixed = sqrts_fixed if (present (lab_is_cm)) phs_config%lab_is_cm = lab_is_cm if (present (azimuthal_dependence)) then phs_config%azimuthal_dependence = azimuthal_dependence if (.not. azimuthal_dependence) then allocate (phs_config%dim_flat (1)) phs_config%dim_flat(1) = 2 end if end if if (allocated (phs_config%channel)) deallocate (phs_config%channel) allocate (phs_config%channel (1)) call phs_config%compute_md5sum () else call msg_fatal ("Single-particle phase space requires n_out = 2") end if end subroutine phs_single_config_configure @ %def phs_single_config_configure @ Startup message, after configuration is complete. <>= procedure :: startup_message => phs_single_config_startup_message +<>= + module subroutine phs_single_config_startup_message (phs_config, unit) + class(phs_single_config_t), intent(in) :: phs_config + integer, intent(in), optional :: unit + end subroutine phs_single_config_startup_message <>= - subroutine phs_single_config_startup_message (phs_config, unit) + module subroutine phs_single_config_startup_message (phs_config, unit) class(phs_single_config_t), intent(in) :: phs_config integer, intent(in), optional :: unit call phs_config%base_startup_message (unit) write (msg_buffer, "(A,2(1x,I0,1x,A))") & "Phase space: single-particle" call msg_message (unit = unit) end subroutine phs_single_config_startup_message @ %def phs_single_config_startup_message @ Allocate an instance: the actual phase-space object. +Gfortran 7/8/9 bug, has to remain in the main module. <>= procedure, nopass :: allocate_instance => phs_single_config_allocate_instance -<>= +<>= subroutine phs_single_config_allocate_instance (phs) class(phs_t), intent(inout), pointer :: phs allocate (phs_single_t :: phs) end subroutine phs_single_config_allocate_instance @ %def phs_single_config_allocate_instance @ \subsection{Kinematics implementation} We generate $\cos\theta$ and $\phi$ uniformly, covering the solid angle. Note: The incoming momenta must be in the c.m. system. <>= public :: phs_single_t <>= type, extends (phs_t) :: phs_single_t contains <> end type phs_single_t @ %def phs_single_t @ Output. The [[verbose]] setting is irrelevant, we just display the contents of the base object. <>= procedure :: write => phs_single_write +<>= + module subroutine phs_single_write (object, unit, verbose) + class(phs_single_t), intent(in) :: object + integer, intent(in), optional :: unit + logical, intent(in), optional :: verbose + end subroutine phs_single_write <>= - subroutine phs_single_write (object, unit, verbose) + module subroutine phs_single_write (object, unit, verbose) class(phs_single_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit) call object%base_write (u) end subroutine phs_single_write @ %def phs_single_write @ The finalizer is empty. <>= procedure :: final => phs_single_final +<>= + module subroutine phs_single_final (object) + class(phs_single_t), intent(inout) :: object + end subroutine phs_single_final <>= - subroutine phs_single_final (object) + module subroutine phs_single_final (object) class(phs_single_t), intent(inout) :: object end subroutine phs_single_final @ %def phs_single_final @ Initialization. We allocate arrays ([[base_init]]) and adjust the phase-space volume. The massless two-particle phase space volume is \begin{equation} \Phi_2 = \frac{1}{4(2\pi)^5} = 2.55294034614 \times 10^{-5} \end{equation} For a decay with nonvanishing masses ($m_3$, $m_4$), there is a correction factor \begin{equation} \Phi_2(m) / \Phi_2(0) = \frac{1}{\hat s} \lambda^{1/2}(\hat s, m_3^2, m_4^2). \end{equation} For a scattering process with nonvanishing masses, the correction factor is \begin{equation} \Phi_2(m) / \Phi_2(0) = \frac{1}{\hat s ^ 2} \lambda^{1/2}(\hat s, m_1^2, m_2^2)\, \lambda^{1/2}(\hat s, m_3^2, m_4^2). \end{equation} If the energy is fixed, this is constant. Otherwise, we have to account for varying $\hat s$. <>= procedure :: init => phs_single_init +<>= + module subroutine phs_single_init (phs, phs_config) + class(phs_single_t), intent(out) :: phs + class(phs_config_t), intent(in), target :: phs_config + end subroutine phs_single_init <>= - subroutine phs_single_init (phs, phs_config) + module subroutine phs_single_init (phs, phs_config) class(phs_single_t), intent(out) :: phs class(phs_config_t), intent(in), target :: phs_config call phs%base_init (phs_config) phs%volume = 1 / (4 * twopi5) call phs%compute_factor () end subroutine phs_single_init @ %def phs_single_init @ Compute the correction factor for nonzero masses. We do this during initialization (when the incoming momenta [[p]] are undefined), unless [[sqrts]] is variable. We do this again once for each phase-space point, but then we skip the calculation if [[sqrts]] is fixed. <>= procedure :: compute_factor => phs_single_compute_factor +<>= + module subroutine phs_single_compute_factor (phs) + class(phs_single_t), intent(inout) :: phs + end subroutine phs_single_compute_factor <>= - subroutine phs_single_compute_factor (phs) + module subroutine phs_single_compute_factor (phs) class(phs_single_t), intent(inout) :: phs real(default) :: s_hat select case (phs%config%n_in) case (1) if (.not. phs%p_defined) then if (sum (phs%m_out) < phs%m_in(1)) then s_hat = phs%m_in(1) ** 2 phs%f(1) = 1 / s_hat & * sqrt (lambda (s_hat, phs%m_out(1)**2, phs%m_out(2)**2)) else print *, "m_in = ", phs%m_in print *, "m_out = ", phs%m_out call msg_fatal ("Decay is kinematically forbidden") end if end if case (2) if (phs%config%sqrts_fixed) then if (phs%p_defined) return s_hat = phs%config%sqrts ** 2 else if (.not. phs%p_defined) return s_hat = sum (phs%p) ** 2 end if if (sum (phs%m_in)**2 < s_hat .and. sum (phs%m_out)**2 < s_hat) then phs%f(1) = 1 / s_hat * & ( lambda (s_hat, phs%m_in (1)**2, phs%m_in (2)**2) & * lambda (s_hat, phs%m_out(1)**2, phs%m_out(2)**2) ) & ** 0.25_default else phs%f(1) = 0 end if end select end subroutine phs_single_compute_factor @ %def phs_single_compute_factor @ Evaluation. We uniformly generate $\cos\theta$ and $\phi$, with Jacobian normalized to one. There is only a single channel, so the second subroutine does nothing. Note: the current implementation works for elastic scattering only. <>= procedure :: evaluate_selected_channel => phs_single_evaluate_selected_channel procedure :: evaluate_other_channels => phs_single_evaluate_other_channels +<>= + module subroutine phs_single_evaluate_selected_channel (phs, c_in, r_in) + class(phs_single_t), intent(inout) :: phs + integer, intent(in) :: c_in + real(default), intent(in), dimension(:) :: r_in + end subroutine phs_single_evaluate_selected_channel + module subroutine phs_single_evaluate_other_channels (phs, c_in) + class(phs_single_t), intent(inout) :: phs + integer, intent(in) :: c_in + end subroutine phs_single_evaluate_other_channels <>= - subroutine phs_single_evaluate_selected_channel (phs, c_in, r_in) + module subroutine phs_single_evaluate_selected_channel (phs, c_in, r_in) class(phs_single_t), intent(inout) :: phs integer, intent(in) :: c_in real(default), intent(in), dimension(:) :: r_in if (phs%p_defined) then call phs%select_channel (c_in) phs%r(:,c_in) = r_in select case (phs%config%n_in) case (2) if (all (phs%m_in == phs%m_out)) then call compute_kinematics_solid_angle (phs%p, phs%q, r_in) else call msg_bug ("PHS single: inelastic scattering not implemented") end if case (1) call compute_kinematics_solid_angle (phs%decay_p (), phs%q, r_in) end select call phs%compute_factor () phs%q_defined = .true. phs%r_defined = .true. end if end subroutine phs_single_evaluate_selected_channel - subroutine phs_single_evaluate_other_channels (phs, c_in) + module subroutine phs_single_evaluate_other_channels (phs, c_in) class(phs_single_t), intent(inout) :: phs integer, intent(in) :: c_in end subroutine phs_single_evaluate_other_channels @ %def phs_single_evaluate_selected_channel @ %def phs_single_evaluate_other_channels @ Auxiliary: split a decaying particle at rest into the decay products, aligned along the $z$ axis. <>= procedure :: decay_p => phs_single_decay_p +<>= + module function phs_single_decay_p (phs) result (p) + class(phs_single_t), intent(in) :: phs + type(vector4_t), dimension(2) :: p + end function phs_single_decay_p <>= - function phs_single_decay_p (phs) result (p) + module function phs_single_decay_p (phs) result (p) class(phs_single_t), intent(in) :: phs type(vector4_t), dimension(2) :: p real(default) :: k real(default), dimension(2) :: E k = sqrt (lambda (phs%m_in(1) ** 2, phs%m_out(1) ** 2, phs%m_out(2) ** 2)) & / (2 * phs%m_in(1)) E = sqrt (phs%m_out ** 2 + k ** 2) p(1) = vector4_moving (E(1), k, 3) p(2) = vector4_moving (E(2),-k, 3) end function phs_single_decay_p @ %def phs_single_decay_p @ Inverse evaluation. <>= procedure :: inverse => phs_single_inverse +<>= + module subroutine phs_single_inverse (phs) + class(phs_single_t), intent(inout) :: phs + end subroutine phs_single_inverse <>= - subroutine phs_single_inverse (phs) + module subroutine phs_single_inverse (phs) class(phs_single_t), intent(inout) :: phs real(default), dimension(:), allocatable :: x if (phs%p_defined .and. phs%q_defined) then call phs%select_channel () allocate (x (phs%config%n_par)) call inverse_kinematics_solid_angle (phs%p, phs%q, x) phs%r(:,1) = x call phs%compute_factor () phs%r_defined = .true. end if end subroutine phs_single_inverse @ %def phs_single_inverse @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[phs_single_ut.f90]]>>= <> module phs_single_ut use unit_tests use phs_single_uti <> <> contains <> end module phs_single_ut @ %def phs_single_ut @ <<[[phs_single_uti.f90]]>>= <> module phs_single_uti <> <> use flavors use lorentz use model_data use process_constants use phs_base use phs_single use phs_base_ut, only: init_test_process_data, init_test_decay_data <> <> contains <> end module phs_single_uti @ %def phs_single_ut @ API: driver for the unit tests below. <>= public :: phs_single_test <>= subroutine phs_single_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine phs_single_test @ %def phs_single_test @ \subsubsection{Phase-space configuration data} Construct and display a test phase-space configuration object. Also check the [[azimuthal_dependence]] flag. <>= call test (phs_single_1, "phs_single_1", & "phase-space configuration", & u, results) <>= public :: phs_single_1 <>= subroutine phs_single_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(process_constants_t) :: process_data class(phs_config_t), allocatable :: phs_data real(default) :: sqrts write (u, "(A)") "* Test output: phs_single_1" write (u, "(A)") "* Purpose: initialize and display & &phase-space configuration data" write (u, "(A)") call model%init_test () write (u, "(A)") "* Initialize a process and a matching & &phase-space configuration" write (u, "(A)") call init_test_process_data (var_str ("phs_single_1"), process_data) allocate (phs_single_config_t :: phs_data) call phs_data%init (process_data, model) sqrts = 1000._default call phs_data%configure (sqrts, azimuthal_dependence=.false.) call phs_data%write (u) call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_single_1" end subroutine phs_single_1 @ %def phs_single_1 @ \subsubsection{Phase space evaluation} Compute kinematics for given parameters, also invert the calculation. <>= call test (phs_single_2, "phs_single_2", & "phase-space evaluation", & u, results) <>= public :: phs_single_2 <>= subroutine phs_single_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(process_constants_t) :: process_data real(default) :: sqrts, E class(phs_config_t), allocatable, target :: phs_data class(phs_t), pointer :: phs => null () type(vector4_t), dimension(2) :: p, q write (u, "(A)") "* Test output: phs_single_2" write (u, "(A)") "* Purpose: test simple two-channel phase space" write (u, "(A)") call model%init_test () call flv%init (25, model) write (u, "(A)") "* Initialize a process and a matching & &phase-space configuration" write (u, "(A)") call init_test_process_data (var_str ("phs_single_2"), process_data) allocate (phs_single_config_t :: phs_data) call phs_data%init (process_data, model) sqrts = 1000._default call phs_data%configure (sqrts) call phs_data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize the phase-space instance" write (u, "(A)") call phs_data%allocate_instance (phs) call phs%init (phs_data) call phs%write (u, verbose=.true.) write (u, "(A)") write (u, "(A)") "* Set incoming momenta" write (u, "(A)") E = sqrts / 2 p(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) p(2) = vector4_moving (E,-sqrt (E**2 - flv%get_mass ()**2), 3) call phs%set_incoming_momenta (p) call phs%compute_flux () call phs%write (u) write (u, "(A)") write (u, "(A)") "* Compute phase-space point & &for x = 0.5, 0.125" write (u, "(A)") call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default]) call phs%evaluate_other_channels (1) call phs%write (u) write (u, "(A)") write (u, "(A)") "* Inverse kinematics" write (u, "(A)") call phs%get_outgoing_momenta (q) deallocate (phs) call phs_data%allocate_instance (phs) call phs%init (phs_data) sqrts = 1000._default call phs_data%configure (sqrts) call phs%set_incoming_momenta (p) call phs%compute_flux () call phs%set_outgoing_momenta (q) call phs%inverse () call phs%write (u) call phs%final () deallocate (phs) call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_single_2" end subroutine phs_single_2 @ %def phs_single_2 @ \subsubsection{Phase space for non-c.m. system} Compute kinematics for given parameters, also invert the calculation. Since this will involve cancellations, we call [[pacify]] to eliminate numerical noise. <>= call test (phs_single_3, "phs_single_3", & "phase-space evaluation in lab frame", & u, results) <>= public :: phs_single_3 <>= subroutine phs_single_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(process_constants_t) :: process_data real(default) :: sqrts, E class(phs_config_t), allocatable, target :: phs_data class(phs_t), pointer :: phs => null () type(vector4_t), dimension(2) :: p, q type(lorentz_transformation_t) :: lt write (u, "(A)") "* Test output: phs_single_3" write (u, "(A)") "* Purpose: test simple two-channel phase space" write (u, "(A)") "* without c.m. kinematics assumption" write (u, "(A)") call model%init_test () call flv%init (25, model) write (u, "(A)") "* Initialize a process and a matching & &phase-space configuration" write (u, "(A)") call init_test_process_data (var_str ("phs_single_3"), process_data) allocate (phs_single_config_t :: phs_data) call phs_data%init (process_data, model) sqrts = 1000._default call phs_data%configure (sqrts, lab_is_cm=.false., sqrts_fixed=.false.) call phs_data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize the phase-space instance" write (u, "(A)") call phs_data%allocate_instance (phs) call phs%init (phs_data) call phs%write (u, verbose=.true.) write (u, "(A)") write (u, "(A)") "* Set incoming momenta in lab system" write (u, "(A)") lt = boost (0.1_default, 1) * boost (0.3_default, 3) E = sqrts / 2 p(1) = lt * vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) p(2) = lt * vector4_moving (E,-sqrt (E**2 - flv%get_mass ()**2), 3) call vector4_write (p(1), u) call vector4_write (p(2), u) write (u, "(A)") write (u, "(A)") "* Compute phase-space point & &for x = 0.5, 0.125" write (u, "(A)") call phs%set_incoming_momenta (p) call phs%compute_flux () call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default]) call phs%evaluate_other_channels (1) call pacify (phs) call phs%write (u) write (u, "(A)") write (u, "(A)") "* Extract outgoing momenta in lab system" write (u, "(A)") call phs%get_outgoing_momenta (q) call vector4_write (q(1), u) call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "* Inverse kinematics" write (u, "(A)") deallocate (phs) call phs_data%allocate_instance (phs) call phs%init (phs_data) sqrts = 1000._default call phs_data%configure (sqrts) call phs%set_incoming_momenta (p) call phs%compute_flux () call phs%set_outgoing_momenta (q) call phs%inverse () call pacify (phs) call phs%write (u) call phs%final () deallocate (phs) call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_single_3" end subroutine phs_single_3 @ %def phs_single_3 @ \subsubsection{Decay Phase space evaluation} Compute kinematics for given parameters, also invert the calculation. This time, implement a decay process. <>= call test (phs_single_4, "phs_single_4", & "decay phase-space evaluation", & u, results) <>= public :: phs_single_4 <>= subroutine phs_single_4 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(process_constants_t) :: process_data class(phs_config_t), allocatable, target :: phs_data class(phs_t), pointer :: phs => null () type(vector4_t), dimension(1) :: p type(vector4_t), dimension(2) :: q write (u, "(A)") "* Test output: phs_single_4" write (u, "(A)") "* Purpose: test simple two-channel phase space" write (u, "(A)") call model%init_test () call model%set_par (var_str ("ff"), 0.4_default) call model%set_par (var_str ("mf"), & model%get_real (var_str ("ff")) * model%get_real (var_str ("ms"))) call flv%init (25, model) write (u, "(A)") "* Initialize a decay and a matching & &phase-space configuration" write (u, "(A)") call init_test_decay_data (var_str ("phs_single_4"), process_data) allocate (phs_single_config_t :: phs_data) call phs_data%init (process_data, model) call phs_data%configure (flv%get_mass ()) call phs_data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize the phase-space instance" write (u, "(A)") call phs_data%allocate_instance (phs) call phs%init (phs_data) call phs%write (u, verbose=.true.) write (u, "(A)") write (u, "(A)") "* Set incoming momenta" write (u, "(A)") p(1) = vector4_at_rest (flv%get_mass ()) call phs%set_incoming_momenta (p) call phs%compute_flux () call phs%write (u) write (u, "(A)") write (u, "(A)") "* Compute phase-space point & &for x = 0.5, 0.125" write (u, "(A)") call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default]) call phs%evaluate_other_channels (1) call phs%write (u) write (u, "(A)") write (u, "(A)") "* Inverse kinematics" write (u, "(A)") call phs%get_outgoing_momenta (q) deallocate (phs) call phs_data%allocate_instance (phs) call phs%init (phs_data) call phs_data%configure (flv%get_mass ()) call phs%set_incoming_momenta (p) call phs%compute_flux () call phs%set_outgoing_momenta (q) call phs%inverse () call phs%write (u) call phs%final () deallocate (phs) call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_single_4" end subroutine phs_single_4 @ %def phs_single_4 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Flat RAMBO phase space} -This module implements the flat \texttt{RAMBO} phase space for massless and massive particles using the minimal d.o.f $3n - 4$ in a straightforward parameterization with a single channel. -We generate $n$ mass systems $M_i$ with $M_0 = \sqrt{s}$ and $M_{n} = 0$. -We let each mass system decay $1 \rightarrow 2$ in a four-momentum conserving way. -The four-momenta of the two particles are generated back-to-back where we map the d.o.f. to energy, azimuthal and polar angle. -The particle momenta are then boosted to CMS by an appriopriate boost using the kinematics of the parent mass system. +This module implements the flat \texttt{RAMBO} phase space for +massless and massive particles using the minimal d.o.f $3n - 4$ in a +straightforward parameterization with a single channel. +We generate $n$ mass systems $M_i$ with $M_0 = \sqrt{s}$ and $M_{n} = +0$. We let each mass system decay $1 \rightarrow 2$ in a four-momentum +conserving way. The four-momenta of the two particles are generated +back-to-back where we map the d.o.f. to energy, azimuthal and polar +angle. The particle momenta are then boosted to CMS by an appriopriate +boost using the kinematics of the parent mass system. <<[[phs_rambo.f90]]>>= <> module phs_rambo <> <> + use lorentz + use phs_base + +<> + +<> + +<> + + interface +<> + end interface + +contains + +<> + +end module phs_rambo +@ %def phs_rambo +@ +<<[[phs_rambo_sub.f90]]>>= +<> + +submodule (phs_rambo) phs_rambo_s + use io_units use constants use numeric_utils use format_defs, only: FMT_19 use permutations, only: factorial use diagnostics - use os_interface - use lorentz use physics_defs - use model_data - use flavors - use process_constants - use phs_base -<> + implicit none <> -<> - -<> - contains <> -end module phs_rambo -@ %def phs_rambo +end submodule phs_rambo_s + +@ %def phs_rambo_s @ \subsection{Configuration} <>= public :: phs_rambo_config_t <>= type, extends (phs_config_t) :: phs_rambo_config_t contains <> end type phs_rambo_config_t @ %def phs_rambo_config_t @ The finalizer is empty. <>= procedure :: final => phs_rambo_config_final +<>= + module subroutine phs_rambo_config_final (object) + class(phs_rambo_config_t), intent(inout) :: object + end subroutine phs_rambo_config_final <>= - subroutine phs_rambo_config_final (object) + module subroutine phs_rambo_config_final (object) class(phs_rambo_config_t), intent(inout) :: object end subroutine phs_rambo_config_final @ %def phs_rambo_final @ Output. <>= procedure :: write => phs_rambo_config_write +<>= + module subroutine phs_rambo_config_write (object, unit, include_id) + class(phs_rambo_config_t), intent(in) :: object + integer, intent(in), optional :: unit + logical, intent(in), optional :: include_id + end subroutine phs_rambo_config_write <>= - subroutine phs_rambo_config_write (object, unit, include_id) + module subroutine phs_rambo_config_write (object, unit, include_id) class(phs_rambo_config_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: include_id integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Partonic, flat phase-space configuration (RAMBO):" call object%base_write (unit) end subroutine phs_rambo_config_write @ %def phs_rambo_config_write @ Configuration: there is only one channel and $3n - 4$ parameters. <>= procedure :: configure => phs_rambo_config_configure +<>= + module subroutine phs_rambo_config_configure (phs_config, sqrts, & + sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, & + ignore_mismatch, nlo_type, subdir) + class(phs_rambo_config_t), intent(inout) :: phs_config + real(default), intent(in) :: sqrts + logical, intent(in), optional :: sqrts_fixed + logical, intent(in), optional :: lab_is_cm + logical, intent(in), optional :: azimuthal_dependence + logical, intent(in), optional :: rebuild + logical, intent(in), optional :: ignore_mismatch + integer, intent(in), optional :: nlo_type + type(string_t), intent(in), optional :: subdir + end subroutine phs_rambo_config_configure <>= - subroutine phs_rambo_config_configure (phs_config, sqrts, & - sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, ignore_mismatch, & - nlo_type, subdir) + module subroutine phs_rambo_config_configure (phs_config, sqrts, & + sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, & + ignore_mismatch, nlo_type, subdir) class(phs_rambo_config_t), intent(inout) :: phs_config real(default), intent(in) :: sqrts logical, intent(in), optional :: sqrts_fixed logical, intent(in), optional :: lab_is_cm logical, intent(in), optional :: azimuthal_dependence logical, intent(in), optional :: rebuild logical, intent(in), optional :: ignore_mismatch integer, intent(in), optional :: nlo_type type(string_t), intent(in), optional :: subdir if (.not. present (nlo_type)) & phs_config%nlo_type = BORN if (phs_config%n_out < 2) then call msg_fatal ("RAMBO phase space requires n_out >= 2") end if phs_config%n_channel = 1 phs_config%n_par = 3 * phs_config%n_out - 4 phs_config%sqrts = sqrts if (present (sqrts_fixed)) phs_config%sqrts_fixed = sqrts_fixed if (present (lab_is_cm)) phs_config%lab_is_cm = lab_is_cm if (allocated (phs_config%channel)) deallocate (phs_config%channel) allocate (phs_config%channel (1)) call phs_config%compute_md5sum () end subroutine phs_rambo_config_configure @ %def phs_rambo_config_configure @ Startup message, after configuration is complete. <>= procedure :: startup_message => phs_rambo_config_startup_message +<>= + module subroutine phs_rambo_config_startup_message (phs_config, unit) + class(phs_rambo_config_t), intent(in) :: phs_config + integer, intent(in), optional :: unit + end subroutine phs_rambo_config_startup_message <>= - subroutine phs_rambo_config_startup_message (phs_config, unit) + module subroutine phs_rambo_config_startup_message (phs_config, unit) class(phs_rambo_config_t), intent(in) :: phs_config integer, intent(in), optional :: unit call phs_config%base_startup_message (unit) write (msg_buffer, "(A,2(1x,I0,1x,A))") & "Phase space: flat (RAMBO)" call msg_message (unit = unit) end subroutine phs_rambo_config_startup_message @ %def phs_rambo_config_startup_message @ Allocate an instance: the actual phase-space object. +Gfortran 7/8/9 bug, has to remain in the main module. <>= procedure, nopass :: allocate_instance => phs_rambo_config_allocate_instance -<>= +<>= subroutine phs_rambo_config_allocate_instance (phs) class(phs_t), intent(inout), pointer :: phs allocate (phs_rambo_t :: phs) end subroutine phs_rambo_config_allocate_instance @ %def phs_rambo_config_allocate_instance @ \subsection{Kinematics implementation} We generate $n - 2$ mass systems $M_i$ with $M_0 = \sqrt{s}$ and $M_n = 0$... Note: The incoming momenta must be in the c.m. system. <>= public :: phs_rambo_t <>= type, extends (phs_t) :: phs_rambo_t real(default), dimension(:), allocatable :: k real(default), dimension(:), allocatable :: m contains - <> + <> end type phs_rambo_t @ %def phs_rambo_t @ Output. <>= -procedure :: write => phs_rambo_write + procedure :: write => phs_rambo_write +<>= + module subroutine phs_rambo_write (object, unit, verbose) + class(phs_rambo_t), intent(in) :: object + integer, intent(in), optional :: unit + logical, intent(in), optional :: verbose + end subroutine phs_rambo_write <>= - subroutine phs_rambo_write (object, unit, verbose) + module subroutine phs_rambo_write (object, unit, verbose) class(phs_rambo_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit) call object%base_write (u) write (u, "(1X,A)") "Intermediate masses (massless):" write (u, "(3X,999(" // FMT_19 // "))") object%k write (u, "(1X,A)") "Intermediate masses (massive):" write (u, "(3X,999(" // FMT_19 // "))") object%m end subroutine phs_rambo_write @ %def phs_rambo_write @ The finalizer is empty. <>= procedure :: final => phs_rambo_final +<>= + module subroutine phs_rambo_final (object) + class(phs_rambo_t), intent(inout) :: object + end subroutine phs_rambo_final <>= - subroutine phs_rambo_final (object) + module subroutine phs_rambo_final (object) class(phs_rambo_t), intent(inout) :: object end subroutine phs_rambo_final @ %def phs_rambo_final @ Initialization. We allocate arrays ([[base_init]]) and adjust the phase-space volume. The energy dependent factor of $s^{n - 2}$ is applied later. <>= procedure :: init => phs_rambo_init +<>= + module subroutine phs_rambo_init (phs, phs_config) + class(phs_rambo_t), intent(out) :: phs + class(phs_config_t), intent(in), target :: phs_config + end subroutine phs_rambo_init <>= - subroutine phs_rambo_init (phs, phs_config) + module subroutine phs_rambo_init (phs, phs_config) class(phs_rambo_t), intent(out) :: phs class(phs_config_t), intent(in), target :: phs_config call phs%base_init (phs_config) associate (n => phs%config%n_out) select case (n) case (1) if (sum (phs%m_out) > phs%m_in (1)) then print *, "m_in = ", phs%m_in print *, "m_out = ", phs%m_out - call msg_fatal ("[phs_rambo_init] Decay is kinematically forbidden.") + call msg_fatal & + ("[phs_rambo_init] Decay is kinematically forbidden.") end if end select allocate (phs%k(n), source = 0._default) allocate (phs%m(n), source = 0._default) phs%volume = 1. / (twopi)**(3 * n) & * (pi / 2.)**(n - 1) / (factorial(n - 1) * factorial(n - 2)) end associate end subroutine phs_rambo_init @ %def phs_rambo_init @ Evaluation. There is only one channel for RAMBO, so the second subroutine does nothing. Note: the current implementation works for elastic scattering only. <>= procedure :: evaluate_selected_channel => phs_rambo_evaluate_selected_channel procedure :: evaluate_other_channels => phs_rambo_evaluate_other_channels +<>= + module subroutine phs_rambo_evaluate_selected_channel (phs, c_in, r_in) + class(phs_rambo_t), intent(inout) :: phs + integer, intent(in) :: c_in + real(default), intent(in), dimension(:) :: r_in + end subroutine phs_rambo_evaluate_selected_channel + module subroutine phs_rambo_evaluate_other_channels (phs, c_in) + class(phs_rambo_t), intent(inout) :: phs + integer, intent(in) :: c_in + end subroutine phs_rambo_evaluate_other_channels <>= - subroutine phs_rambo_evaluate_selected_channel (phs, c_in, r_in) + module subroutine phs_rambo_evaluate_selected_channel (phs, c_in, r_in) class(phs_rambo_t), intent(inout) :: phs integer, intent(in) :: c_in real(default), intent(in), dimension(:) :: r_in type(vector4_t), dimension(2) :: p_rest, p_boosted type(vector4_t) :: q real(default), dimension(2) :: r_angle integer :: i if (.not. phs%p_defined) return call phs%select_channel (c_in) phs%r(:,c_in) = r_in associate (n => phs%config%n_out, m => phs%m) call phs%generate_intermediates (r_in(:n - 2)) q = sum (phs%p) do i = 2, n r_angle(1) = r_in(n - 5 + 2 * i) r_angle(2) = r_in(n - 4 + 2 * i) call phs%decay_intermediate (i, r_angle, p_rest) p_boosted = boost(q, m(i - 1)) * p_rest q = p_boosted(1) phs%q(i - 1) = p_boosted(2) end do phs%q(n) = q end associate phs%q_defined = .true. phs%r_defined = .true. end subroutine phs_rambo_evaluate_selected_channel - subroutine phs_rambo_evaluate_other_channels (phs, c_in) + module subroutine phs_rambo_evaluate_other_channels (phs, c_in) class(phs_rambo_t), intent(inout) :: phs integer, intent(in) :: c_in end subroutine phs_rambo_evaluate_other_channels @ %def phs_rambo_evaluate_selected_channel @ %def phs_rambo_evaluate_other_channels @ Decay intermediate mass system $M_{i - 1}$ into a on-shell particle with mass $m_{i - 1}$ and subsequent intermediate mass system with fixed $M_i$. <>= procedure, private :: decay_intermediate => phs_rambo_decay_intermediate +<>= + module subroutine phs_rambo_decay_intermediate (phs, i, r_angle, p) + class(phs_rambo_t), intent(in) :: phs + integer, intent(in) :: i + real(default), dimension(2), intent(in) :: r_angle + type(vector4_t), dimension(2), intent(out) :: p + end subroutine phs_rambo_decay_intermediate <>= - subroutine phs_rambo_decay_intermediate (phs, i, r_angle, p) + module subroutine phs_rambo_decay_intermediate (phs, i, r_angle, p) class(phs_rambo_t), intent(in) :: phs integer, intent(in) :: i real(default), dimension(2), intent(in) :: r_angle type(vector4_t), dimension(2), intent(out) :: p real(default) :: k_abs, cos_theta, phi type(vector3_t):: k real(default), dimension(2) :: E cos_theta = 2. * r_angle(1) - 1. phi = twopi * r_angle(2) if (phi > pi) phi = phi - twopi k_abs = sqrt (lambda (phs%m(i - 1)**2, phs%m(i)**2, phs%m_out(i - 1)**2)) & / (2. * phs%m(i - 1)) k = k_abs * [cos(phi) * sqrt(1. - cos_theta**2), & sin(phi) * sqrt(1. - cos_theta**2), cos_theta] E(1) = sqrt (phs%m(i)**2 + k_abs**2) E(2) = sqrt (phs%m_out(i - 1)**2 + k_abs**2) p(1) = vector4_moving (E(1), -k) p(2) = vector4_moving (E(2), k) end subroutine phs_rambo_decay_intermediate @ %def phs_rambo_decay_intermediate @ Generate intermediate masses. <>= integer, parameter :: BISECT_MAX_ITERATIONS = 1000 real(default), parameter :: BISECT_MIN_PRECISION = tiny_10 <>= - procedure, private :: generate_intermediates => phs_rambo_generate_intermediates + procedure, private :: generate_intermediates => & + phs_rambo_generate_intermediates procedure, private :: invert_intermediates => phs_rambo_invert_intermediates +<>= + module subroutine phs_rambo_generate_intermediates (phs, r) + class(phs_rambo_t), intent(inout) :: phs + real(default), dimension(:), intent(in) :: r + end subroutine phs_rambo_generate_intermediates + module subroutine phs_rambo_invert_intermediates (phs) + class(phs_rambo_t), intent(inout) :: phs + end subroutine phs_rambo_invert_intermediates <>= - subroutine phs_rambo_generate_intermediates (phs, r) + module subroutine phs_rambo_generate_intermediates (phs, r) class(phs_rambo_t), intent(inout) :: phs real(default), dimension(:), intent(in) :: r integer :: i, j associate (n => phs%config%n_out, k => phs%k, m => phs%m) m(1) = invariant_mass (sum (phs%p)) m(n) = phs%m_out (n) call calculate_k (r) do i = 2, n - 1 m(i) = k(i) + sum (phs%m_out (i:n)) end do ! Massless volume times reweighting for massive volume phs%f(1) = k(1)**(2 * n - 4) & * 8. * rho(m(n - 1), phs%m_out(n), phs%m_out(n - 1)) do i = 2, n - 1 phs%f(1) = phs%f(1) * & rho(m(i - 1), m(i), phs%m_out(i - 1)) / & rho(k(i - 1), k(i), 0._default) * & M(i) / K(i) end do end associate contains subroutine calculate_k (r) real(default), dimension(:), intent(in) :: r real(default), dimension(:), allocatable :: u integer :: i associate (n => phs%config%n_out, k => phs%k, m => phs%m) k = 0 k(1) = m(1) - sum(phs%m_out(1:n)) allocate (u(2:n - 1), source=0._default) call solve_for_u (r, u) do i = 2, n - 1 k(i) = sqrt (u(i) * k(i - 1)**2) end do end associate end subroutine calculate_k subroutine solve_for_u (r, u) real(default), dimension(phs%config%n_out - 2), intent(in) :: r real(default), dimension(2:phs%config%n_out - 1), intent(out) :: u integer :: i, j real(default) :: f, f_mid, xl, xr, xmid associate (n => phs%config%n_out) do i = 2, n - 1 xl = 0 xr = 1 if (r(i - 1) == 1 .or. r(i - 1) == 0) then u(i) = r(i - 1) else do j = 1, BISECT_MAX_ITERATIONS xmid = (xl + xr) / 2. f = f_rambo (xl, n - i) - r(i - 1) f_mid = f_rambo (xmid, n - i) - r(i - 1) if (f * f_mid > 0) then xl = xmid else xr = xmid end if if (abs(xl - xr) < BISECT_MIN_PRECISION) exit end do u(i) = xmid end if end do end associate end subroutine solve_for_u real(default) function f_rambo(u, n) real(default), intent(in) :: u integer, intent(in) :: n f_rambo = (n + 1) * u**n - n * u**(n + 1) end function f_rambo real(default) function rho (M1, M2, m) real(default), intent(in) :: M1, M2, m real(default) :: MP, MM rho = sqrt ((M1**2 - (M2 + m)**2) * (M1**2 - (M2 - m)**2)) ! MP = (M1 - (M2 + m)) * (M1 + (M2 + m)) ! MM = (M1 - (M2 - m)) * (M1 + (M2 - m)) ! rho = sqrt (MP) * sqrt (MM) rho = rho / (8._default * M1**2) end function rho end subroutine phs_rambo_generate_intermediates - subroutine phs_rambo_invert_intermediates (phs) + module subroutine phs_rambo_invert_intermediates (phs) class(phs_rambo_t), intent(inout) :: phs real(default) :: u integer :: i associate (n => phs%config%n_out, k => phs%k, m => phs%m) k = m do i = 1, n - 1 k(i) = k(i) - sum (phs%m_out(i:n)) end do do i = 2, n - 1 u = (k(i) / k(i - 1))**2 phs%r(i - 1, 1) = (n + 1 - i) * u**(n - i) & - (n - i) * u**(n + 1 - i) end do end associate end subroutine phs_rambo_invert_intermediates + @ %def phs_rambo_generate_intermediates @ Inverse evaluation. <>= procedure :: inverse => phs_rambo_inverse +<>= + module subroutine phs_rambo_inverse (phs) + class(phs_rambo_t), intent(inout) :: phs + end subroutine phs_rambo_inverse <>= - subroutine phs_rambo_inverse (phs) + module subroutine phs_rambo_inverse (phs) class(phs_rambo_t), intent(inout) :: phs type(vector4_t), dimension(:), allocatable :: q type(vector4_t) :: p type(lorentz_transformation_t) :: L real(default) :: phi, cos_theta integer :: i if (.not. (phs%p_defined .and. phs%q_defined)) return call phs%select_channel () associate (n => phs%config%n_out, m => phs%m) allocate(q(n)) m(1) = invariant_mass (sum (phs%p)) q(1) = vector4_at_rest (m(1)) q(n) = phs%q(n) do i = 2, n - 1 q(i) = q(i) + sum (phs%q(i:n)) m(i) = invariant_mass (q(i)) end do call phs%invert_intermediates () do i = 2, n L = inverse (boost (q(i - 1), m(i - 1))) p = L * phs%q(i - 1) phi = azimuthal_angle (p); cos_theta = polar_angle_ct (p) phs%r(n - 5 + 2 * i, 1) = (cos_theta + 1.) / 2. phs%r(n - 4 + 2 * i, 1) = phi / twopi end do end associate phs%r_defined = .true. end subroutine phs_rambo_inverse @ %def phs_rambo_inverse @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[phs_rambo_ut.f90]]>>= <> module phs_rambo_ut use unit_tests use phs_rambo_uti <> <> contains <> end module phs_rambo_ut @ %def phs_rambo_ut @ <<[[phs_rambo_uti.f90]]>>= <> module phs_rambo_uti <> <> use flavors use lorentz use model_data use process_constants use phs_base use phs_rambo use phs_base_ut, only: init_test_process_data, init_test_decay_data <> <> contains <> end module phs_rambo_uti @ %def phs_rambo_ut @ API: driver for the unit tests below. <>= public :: phs_rambo_test <>= subroutine phs_rambo_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine phs_rambo_test @ %def phs_rambo_test @ \subsubsection{Phase-space configuration data} Construct and display a test phase-space configuration object. Also check the [[azimuthal_dependence]] flag. <>= call test (phs_rambo_1, "phs_rambo_1", & "phase-space configuration", & u, results) <>= public :: phs_rambo_1 <>= subroutine phs_rambo_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(process_constants_t) :: process_data class(phs_config_t), allocatable :: phs_data real(default) :: sqrts write (u, "(A)") "* Test output: phs_rambo_1" write (u, "(A)") "* Purpose: initialize and display & &phase-space configuration data" write (u, "(A)") call model%init_test () write (u, "(A)") "* Initialize a process and a matching & &phase-space configuration" write (u, "(A)") call init_test_process_data (var_str ("phs_rambo_1"), process_data) allocate (phs_rambo_config_t :: phs_data) call phs_data%init (process_data, model) sqrts = 1000._default call phs_data%configure (sqrts) call phs_data%write (u) call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_rambo_1" end subroutine phs_rambo_1 @ %def phs_rambo_1 @ \subsubsection{Phase space evaluation} Compute kinematics for given parameters, also invert the calculation. <>= call test (phs_rambo_2, "phs_rambo_2", & "phase-space evaluation", & u, results) <>= public :: phs_rambo_2 <>= subroutine phs_rambo_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(process_constants_t) :: process_data real(default) :: sqrts, E class(phs_config_t), allocatable, target :: phs_data class(phs_t), pointer :: phs => null () type(vector4_t), dimension(2) :: p, q write (u, "(A)") "* Test output: phs_rambo_2" write (u, "(A)") "* Purpose: test simple two-channel phase space" write (u, "(A)") call model%init_test () call flv%init (25, model) write (u, "(A)") "* Initialize a process and a matching & &phase-space configuration" write (u, "(A)") call init_test_process_data (var_str ("phs_rambo_2"), process_data) allocate (phs_rambo_config_t :: phs_data) call phs_data%init (process_data, model) sqrts = 1000._default call phs_data%configure (sqrts) call phs_data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize the phase-space instance" write (u, "(A)") call phs_data%allocate_instance (phs) call phs%init (phs_data) call phs%write (u, verbose=.true.) write (u, "(A)") write (u, "(A)") "* Set incoming momenta" write (u, "(A)") E = sqrts / 2 p(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) p(2) = vector4_moving (E,-sqrt (E**2 - flv%get_mass ()**2), 3) call phs%set_incoming_momenta (p) call phs%compute_flux () call phs%write (u) write (u, "(A)") write (u, "(A)") "* Compute phase-space point & &for x = 0.5, 0.125" write (u, "(A)") call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default]) call phs%evaluate_other_channels (1) call phs%write (u) write (u, "(A)") write (u, "(A)") "* Inverse kinematics" write (u, "(A)") call phs%get_outgoing_momenta (q) deallocate (phs) call phs_data%allocate_instance (phs) call phs%init (phs_data) sqrts = 1000._default call phs_data%configure (sqrts) call phs%set_incoming_momenta (p) call phs%compute_flux () call phs%set_outgoing_momenta (q) call phs%inverse () call phs%write (u) call phs%final () deallocate (phs) call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_rambo_2" end subroutine phs_rambo_2 @ %def phs_rambo_2 @ \subsubsection{Phase space for non-c.m. system} Compute kinematics for given parameters, also invert the calculation. Since this will involve cancellations, we call [[pacify]] to eliminate numerical noise. <>= call test (phs_rambo_3, "phs_rambo_3", & "phase-space evaluation in lab frame", & u, results) <>= public :: phs_rambo_3 <>= subroutine phs_rambo_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(process_constants_t) :: process_data real(default) :: sqrts, E class(phs_config_t), allocatable, target :: phs_data class(phs_t), pointer :: phs => null () type(vector4_t), dimension(2) :: p, q type(lorentz_transformation_t) :: lt write (u, "(A)") "* Test output: phs_rambo_3" write (u, "(A)") "* Purpose: phase-space evaluation in lab frame" write (u, "(A)") call model%init_test () call flv%init (25, model) write (u, "(A)") "* Initialize a process and a matching & &phase-space configuration" write (u, "(A)") call init_test_process_data (var_str ("phs_rambo_3"), process_data) allocate (phs_rambo_config_t :: phs_data) call phs_data%init (process_data, model) sqrts = 1000._default call phs_data%configure (sqrts, lab_is_cm=.false., sqrts_fixed=.false.) call phs_data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize the phase-space instance" write (u, "(A)") call phs_data%allocate_instance (phs) call phs%init (phs_data) call phs%write (u, verbose=.true.) write (u, "(A)") write (u, "(A)") "* Set incoming momenta in lab system" write (u, "(A)") lt = boost (0.1_default, 1) * boost (0.3_default, 3) E = sqrts / 2 p(1) = lt * vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) p(2) = lt * vector4_moving (E,-sqrt (E**2 - flv%get_mass ()**2), 3) call vector4_write (p(1), u) call vector4_write (p(2), u) write (u, "(A)") write (u, "(A)") "* Compute phase-space point & &for x = 0.5, 0.125" write (u, "(A)") call phs%set_incoming_momenta (p) call phs%compute_flux () call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default]) call phs%evaluate_other_channels (1) call pacify (phs) call phs%write (u) write (u, "(A)") write (u, "(A)") "* Extract outgoing momenta in lab system" write (u, "(A)") call phs%get_outgoing_momenta (q) call vector4_write (q(1), u) call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "* Inverse kinematics" write (u, "(A)") deallocate (phs) call phs_data%allocate_instance (phs) call phs%init (phs_data) sqrts = 1000._default call phs_data%configure (sqrts) call phs%set_incoming_momenta (p) call phs%compute_flux () call phs%set_outgoing_momenta (q) call phs%inverse () call pacify (phs) call phs%write (u) call phs%final () deallocate (phs) call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_rambo_3" end subroutine phs_rambo_3 @ %def phs_rambo_3 @ \subsubsection{Decay Phase space evaluation} Compute kinematics for given parameters, also invert the calculation. This time, implement a decay process. <>= call test (phs_rambo_4, "phs_rambo_4", & "decay phase-space evaluation", & u, results) <>= public :: phs_rambo_4 <>= subroutine phs_rambo_4 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(process_constants_t) :: process_data class(phs_config_t), allocatable, target :: phs_data class(phs_t), pointer :: phs => null () type(vector4_t), dimension(1) :: p type(vector4_t), dimension(2) :: q write (u, "(A)") "* Test output: phs_rambo_4" write (u, "(A)") "* Purpose: test simple two-channel phase space" write (u, "(A)") call model%init_test () call model%set_par (var_str ("ff"), 0.4_default) call model%set_par (var_str ("mf"), & model%get_real (var_str ("ff")) * model%get_real (var_str ("ms"))) call flv%init (25, model) write (u, "(A)") "* Initialize a decay and a matching & &phase-space configuration" write (u, "(A)") call init_test_decay_data (var_str ("phs_rambo_4"), process_data) allocate (phs_rambo_config_t :: phs_data) call phs_data%init (process_data, model) call phs_data%configure (flv%get_mass ()) call phs_data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize the phase-space instance" write (u, "(A)") call phs_data%allocate_instance (phs) call phs%init (phs_data) call phs%write (u, verbose=.true.) write (u, "(A)") write (u, "(A)") "* Set incoming momenta" write (u, "(A)") p(1) = vector4_at_rest (flv%get_mass ()) call phs%set_incoming_momenta (p) call phs%compute_flux () call phs%write (u) write (u, "(A)") write (u, "(A)") "* Compute phase-space point & &for x = 0.5, 0.125" write (u, "(A)") call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default]) call phs%evaluate_other_channels (1) call phs%write (u) write (u, "(A)") write (u, "(A)") "* Inverse kinematics" write (u, "(A)") call phs%get_outgoing_momenta (q) deallocate (phs) call phs_data%allocate_instance (phs) call phs%init (phs_data) call phs_data%configure (flv%get_mass ()) call phs%set_incoming_momenta (p) call phs%compute_flux () call phs%set_outgoing_momenta (q) call phs%inverse () call phs%write (u) call phs%final () deallocate (phs) call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_rambo_4" end subroutine phs_rambo_4 @ %def phs_rambo_4 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Resonance Handler} For various purposes (e.g., shower histories), we should extract the set of resonances and resonant channels from a phase-space tree set. A few methods do kinematics calculations specifically for those resonance data. <<[[resonances.f90]]>>= <> module resonances <> <> -<> - use string_utils, only: str - use format_utils, only: write_indent - use io_units - use diagnostics use lorentz - use constants, only: one use model_data, only: model_data_t use flavors, only: flavor_t <> <> <> <> + interface +<> + end interface + +end module resonances +@ %def resonances +@ +<<[[resonances_sub.f90]]>>= +<> + +submodule (resonances) resonances_s + +<> + use string_utils, only: str + use format_utils, only: write_indent + use constants, only: one + use io_units + use diagnostics + + implicit none + contains <> -end module resonances -@ %def resonances +end submodule resonances_s + +@ %def resonances_s @ \subsection{Decay products (contributors)} This stores the indices of the particles that contribute to a resonance, i.e., the decay products. <>= public :: resonance_contributors_t <>= type :: resonance_contributors_t integer, dimension(:), allocatable :: c contains <> end type resonance_contributors_t @ %def resonance_contributors_t @ Equality (comparison) <>= procedure, private :: resonance_contributors_equal generic :: operator(==) => resonance_contributors_equal +<>= + elemental module function resonance_contributors_equal & + (c1, c2) result (equal) + logical :: equal + class(resonance_contributors_t), intent(in) :: c1, c2 + end function resonance_contributors_equal <>= - elemental function resonance_contributors_equal (c1, c2) result (equal) + elemental module function resonance_contributors_equal & + (c1, c2) result (equal) logical :: equal class(resonance_contributors_t), intent(in) :: c1, c2 equal = allocated (c1%c) .and. allocated (c2%c) if (equal) equal = size (c1%c) == size (c2%c) if (equal) equal = all (c1%c == c2%c) end function resonance_contributors_equal @ %def resonance_contributors_equal @ Assignment <>= procedure, private :: resonance_contributors_assign generic :: assignment(=) => resonance_contributors_assign +<>= + pure module subroutine resonance_contributors_assign & + (contributors_out, contributors_in) + class(resonance_contributors_t), intent(inout) :: contributors_out + class(resonance_contributors_t), intent(in) :: contributors_in + end subroutine resonance_contributors_assign <>= - pure subroutine resonance_contributors_assign (contributors_out, contributors_in) + pure module subroutine resonance_contributors_assign & + (contributors_out, contributors_in) class(resonance_contributors_t), intent(inout) :: contributors_out class(resonance_contributors_t), intent(in) :: contributors_in if (allocated (contributors_out%c)) deallocate (contributors_out%c) if (allocated (contributors_in%c)) then allocate (contributors_out%c (size (contributors_in%c))) contributors_out%c = contributors_in%c end if end subroutine resonance_contributors_assign @ %def resonance_contributors_assign @ \subsection{Resonance info object} This data structure augments the set of resonance contributors by a flavor object, such that we can perform calculations that take into account the particle properties, including mass and width. Avoiding nameclash with similar but different [[resonance_t]] of [[phs_base]]: <>= public :: resonance_info_t <>= type :: resonance_info_t type(flavor_t) :: flavor type(resonance_contributors_t) :: contributors contains <> end type resonance_info_t @ %def resonance_info_t @ <>= procedure :: copy => resonance_info_copy +<>= + module subroutine resonance_info_copy (resonance_in, resonance_out) + class(resonance_info_t), intent(in) :: resonance_in + type(resonance_info_t), intent(out) :: resonance_out + end subroutine resonance_info_copy <>= - subroutine resonance_info_copy (resonance_in, resonance_out) + module subroutine resonance_info_copy (resonance_in, resonance_out) class(resonance_info_t), intent(in) :: resonance_in type(resonance_info_t), intent(out) :: resonance_out resonance_out%flavor = resonance_in%flavor if (allocated (resonance_in%contributors%c)) then associate (c => resonance_in%contributors%c) allocate (resonance_out%contributors%c (size (c))) resonance_out%contributors%c = c end associate end if end subroutine resonance_info_copy @ %def resonance_info_copy @ <>= procedure :: write => resonance_info_write +<>= + module subroutine resonance_info_write (resonance, unit, verbose) + class(resonance_info_t), intent(in) :: resonance + integer, optional, intent(in) :: unit + logical, optional, intent(in) :: verbose + end subroutine resonance_info_write <>= - subroutine resonance_info_write (resonance, unit, verbose) + module subroutine resonance_info_write (resonance, unit, verbose) class(resonance_info_t), intent(in) :: resonance integer, optional, intent(in) :: unit logical, optional, intent(in) :: verbose integer :: u, i logical :: verb u = given_output_unit (unit); if (u < 0) return verb = .true.; if (present (verbose)) verb = verbose if (verb) then write (u, '(A)', advance='no') "Resonance contributors: " else write (u, '(1x)', advance="no") end if if (allocated (resonance%contributors%c)) then do i = 1, size(resonance%contributors%c) write (u, '(I0,1X)', advance='no') resonance%contributors%c(i) end do else if (verb) then write (u, "(A)", advance="no") "[not allocated]" end if if (resonance%flavor%is_defined ()) call resonance%flavor%write (u) write (u, '(A)') end subroutine resonance_info_write @ %def resonance_info_write @ Create a resonance-info object. The particle info may be available in term of a flavor object or as a PDG code; in the latter case we have to require a model data object that provides mass and width information. <>= procedure, private :: resonance_info_init_pdg procedure, private :: resonance_info_init_flv generic :: init => resonance_info_init_pdg, resonance_info_init_flv +<>= + module subroutine resonance_info_init_pdg & + (resonance, mom_id, pdg, model, n_out) + class(resonance_info_t), intent(out) :: resonance + integer, intent(in) :: mom_id + integer, intent(in) :: pdg, n_out + class(model_data_t), intent(in), target :: model + end subroutine resonance_info_init_pdg + module subroutine resonance_info_init_flv (resonance, mom_id, flv, n_out) + class(resonance_info_t), intent(out) :: resonance + integer, intent(in) :: mom_id + type(flavor_t), intent(in) :: flv + integer, intent(in) :: n_out + end subroutine resonance_info_init_flv <>= - subroutine resonance_info_init_pdg (resonance, mom_id, pdg, model, n_out) + module subroutine resonance_info_init_pdg & + (resonance, mom_id, pdg, model, n_out) class(resonance_info_t), intent(out) :: resonance integer, intent(in) :: mom_id integer, intent(in) :: pdg, n_out class(model_data_t), intent(in), target :: model type(flavor_t) :: flv if (debug_on) call msg_debug (D_PHASESPACE, "resonance_info_init_pdg") call flv%init (pdg, model) call resonance%init (mom_id, flv, n_out) end subroutine resonance_info_init_pdg - subroutine resonance_info_init_flv (resonance, mom_id, flv, n_out) + module subroutine resonance_info_init_flv (resonance, mom_id, flv, n_out) class(resonance_info_t), intent(out) :: resonance integer, intent(in) :: mom_id type(flavor_t), intent(in) :: flv integer, intent(in) :: n_out integer :: i logical, dimension(n_out) :: contrib integer, dimension(n_out) :: tmp if (debug_on) call msg_debug (D_PHASESPACE, "resonance_info_init_flv") resonance%flavor = flv do i = 1, n_out tmp(i) = i end do contrib = btest (mom_id, tmp - 1) allocate (resonance%contributors%c (count (contrib))) resonance%contributors%c = pack (tmp, contrib) end subroutine resonance_info_init_flv @ %def resonance_info_init @ <>= procedure, private :: resonance_info_equal generic :: operator(==) => resonance_info_equal +<>= + elemental module function resonance_info_equal (r1, r2) result (equal) + logical :: equal + class(resonance_info_t), intent(in) :: r1, r2 + end function resonance_info_equal <>= - elemental function resonance_info_equal (r1, r2) result (equal) + elemental module function resonance_info_equal (r1, r2) result (equal) logical :: equal class(resonance_info_t), intent(in) :: r1, r2 equal = r1%flavor == r2%flavor .and. r1%contributors == r2%contributors end function resonance_info_equal @ %def resonance_info_equal @ With each resonance region we associate a Breit-Wigner function \begin{equation*} P = \frac{M_{res}^4}{(s - M_{res}^2)^2 + \Gamma_{res}^2 M_{res}^2}, \end{equation*} where $s$ denotes the invariant mass of the outgoing momenta originating from this resonance. Note that the $M_{res}^4$ in the nominator makes the mapping a dimensionless quantity. <>= procedure :: mapping => resonance_info_mapping +<>= + module function resonance_info_mapping (resonance, s) result (bw) + real(default) :: bw + class(resonance_info_t), intent(in) :: resonance + real(default), intent(in) :: s + end function resonance_info_mapping <>= - function resonance_info_mapping (resonance, s) result (bw) + module function resonance_info_mapping (resonance, s) result (bw) real(default) :: bw class(resonance_info_t), intent(in) :: resonance real(default), intent(in) :: s real(default) :: m, gamma if (resonance%flavor%is_defined ()) then m = resonance%flavor%get_mass () gamma = resonance%flavor%get_width () bw = m**4 / ((s - m**2)**2 + gamma**2 * m**2) else bw = one end if end function resonance_info_mapping @ %def resonance_info_mapping @ Used for building a resonance tree below. <>= procedure, private :: get_n_contributors => resonance_info_get_n_contributors procedure, private :: contains => resonance_info_contains +<>= + elemental module function resonance_info_get_n_contributors & + (resonance) result (n) + class(resonance_info_t), intent(in) :: resonance + integer :: n + end function resonance_info_get_n_contributors + elemental module function resonance_info_contains & + (resonance, c) result (flag) + class(resonance_info_t), intent(in) :: resonance + integer, intent(in) :: c + logical :: flag + end function resonance_info_contains <>= - elemental function resonance_info_get_n_contributors (resonance) result (n) + elemental module function resonance_info_get_n_contributors & + (resonance) result (n) class(resonance_info_t), intent(in) :: resonance integer :: n if (allocated (resonance%contributors%c)) then n = size (resonance%contributors%c) else n = 0 end if end function resonance_info_get_n_contributors - elemental function resonance_info_contains (resonance, c) result (flag) + elemental module function resonance_info_contains & + (resonance, c) result (flag) class(resonance_info_t), intent(in) :: resonance integer, intent(in) :: c logical :: flag if (allocated (resonance%contributors%c)) then flag = any (resonance%contributors%c == c) else flag = .false. end if end function resonance_info_contains @ %def resonance_info_get_n_contributors @ %def resonance_info_contains @ \subsection{Resonance history object} This data structure stores a set of resonances, i.e., the resonances that appear in a particular Feynman graph or, in the context of phase space, phase space diagram. <>= public :: resonance_history_t <>= type :: resonance_history_t type(resonance_info_t), dimension(:), allocatable :: resonances integer :: n_resonances = 0 contains <> end type resonance_history_t @ %def resonance_history_t @ Clear the resonance history. Assuming that there are no pointer-allocated parts, a straightforward [[intent(out)]] will do. <>= procedure :: clear => resonance_history_clear +<>= + module subroutine resonance_history_clear (res_hist) + class(resonance_history_t), intent(out) :: res_hist + end subroutine resonance_history_clear <>= - subroutine resonance_history_clear (res_hist) + module subroutine resonance_history_clear (res_hist) class(resonance_history_t), intent(out) :: res_hist end subroutine resonance_history_clear @ %def resonance_history_clear @ <>= procedure :: copy => resonance_history_copy +<>= + module subroutine resonance_history_copy (res_hist_in, res_hist_out) + class(resonance_history_t), intent(in) :: res_hist_in + type(resonance_history_t), intent(out) :: res_hist_out + end subroutine resonance_history_copy <>= - subroutine resonance_history_copy (res_hist_in, res_hist_out) + module subroutine resonance_history_copy (res_hist_in, res_hist_out) class(resonance_history_t), intent(in) :: res_hist_in type(resonance_history_t), intent(out) :: res_hist_out integer :: i res_hist_out%n_resonances = res_hist_in%n_resonances allocate (res_hist_out%resonances (size (res_hist_in%resonances))) do i = 1, size (res_hist_in%resonances) call res_hist_in%resonances(i)%copy (res_hist_out%resonances(i)) end do end subroutine resonance_history_copy @ %def resonance_history_copy @ <>= procedure :: write => resonance_history_write +<>= + module subroutine resonance_history_write (res_hist, unit, verbose, indent) + class(resonance_history_t), intent(in) :: res_hist + integer, optional, intent(in) :: unit + logical, optional, intent(in) :: verbose + integer, optional, intent(in) :: indent + end subroutine resonance_history_write <>= - subroutine resonance_history_write (res_hist, unit, verbose, indent) + module subroutine resonance_history_write (res_hist, unit, verbose, indent) class(resonance_history_t), intent(in) :: res_hist integer, optional, intent(in) :: unit logical, optional, intent(in) :: verbose integer, optional, intent(in) :: indent integer :: u, i u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write(u, '(A,I0,A)') "Resonance history with ", & res_hist%n_resonances, " resonances:" do i = 1, res_hist%n_resonances call write_indent (u, indent) write (u, "(2x)", advance="no") call res_hist%resonances(i)%write (u, verbose) end do end subroutine resonance_history_write @ %def resonance_history_write @ Assignment. Indirectly calls type-bound assignment for the contributors. Strictly speaking, this is redundant. But NAGfor 6.208 intrinsic assignment crashes under certain conditions. <>= procedure, private :: resonance_history_assign generic :: assignment(=) => resonance_history_assign +<>= + module subroutine resonance_history_assign (res_hist_out, res_hist_in) + class(resonance_history_t), intent(out) :: res_hist_out + class(resonance_history_t), intent(in) :: res_hist_in + end subroutine resonance_history_assign <>= - subroutine resonance_history_assign (res_hist_out, res_hist_in) + module subroutine resonance_history_assign (res_hist_out, res_hist_in) class(resonance_history_t), intent(out) :: res_hist_out class(resonance_history_t), intent(in) :: res_hist_in if (allocated (res_hist_in%resonances)) then res_hist_out%resonances = res_hist_in%resonances res_hist_out%n_resonances = res_hist_in%n_resonances end if end subroutine resonance_history_assign @ %def resonance_history_assign @ Equality. If this turns out to slow down the program, we should change the implementation or use hash codes. <>= procedure, private :: resonance_history_equal generic :: operator(==) => resonance_history_equal +<>= + elemental module function resonance_history_equal (rh1, rh2) result (equal) + logical :: equal + class(resonance_history_t), intent(in) :: rh1, rh2 + end function resonance_history_equal <>= - elemental function resonance_history_equal (rh1, rh2) result (equal) + elemental module function resonance_history_equal (rh1, rh2) result (equal) logical :: equal class(resonance_history_t), intent(in) :: rh1, rh2 integer :: i equal = .false. if (rh1%n_resonances == rh2%n_resonances) then do i = 1, rh1%n_resonances if (.not. rh1%resonances(i) == rh2%resonances(i)) then return end if end do equal = .true. end if end function resonance_history_equal @ %def resonance_history_equal @ Check if a resonance history is a strict superset of another one. This is true if the first one is nonempty and the second one is empty. Otherwise, we check if each entry of the second argument appears in the first one. <>= procedure, private :: resonance_history_contains generic :: operator(.contains.) => resonance_history_contains -@ +<>= + elemental module function resonance_history_contains & + (rh1, rh2) result (flag) + logical :: flag + class(resonance_history_t), intent(in) :: rh1, rh2 + end function resonance_history_contains <>= - elemental function resonance_history_contains (rh1, rh2) result (flag) + elemental module function resonance_history_contains & + (rh1, rh2) result (flag) logical :: flag class(resonance_history_t), intent(in) :: rh1, rh2 integer :: i if (rh1%n_resonances > rh2%n_resonances) then flag = .true. do i = 1, rh2%n_resonances flag = flag .and. any (rh1%resonances == rh2%resonances(i)) end do else flag = .false. end if end function resonance_history_contains @ %def resonance_history_contains @ Number of entries for dynamically extending the resonance-info array. <>= integer, parameter :: n_max_resonances = 10 @ <>= procedure :: add_resonance => resonance_history_add_resonance +<>= + module subroutine resonance_history_add_resonance (res_hist, resonance) + class(resonance_history_t), intent(inout) :: res_hist + type(resonance_info_t), intent(in) :: resonance + end subroutine resonance_history_add_resonance <>= - subroutine resonance_history_add_resonance (res_hist, resonance) + module subroutine resonance_history_add_resonance (res_hist, resonance) class(resonance_history_t), intent(inout) :: res_hist type(resonance_info_t), intent(in) :: resonance type(resonance_info_t), dimension(:), allocatable :: tmp integer :: n, i - if (debug_on) call msg_debug (D_PHASESPACE, "resonance_history_add_resonance") + if (debug_on) call msg_debug & + (D_PHASESPACE, "resonance_history_add_resonance") if (.not. allocated (res_hist%resonances)) then n = 0 allocate (res_hist%resonances (1)) else n = res_hist%n_resonances allocate (tmp (n)) do i = 1, n call res_hist%resonances(i)%copy (tmp(i)) end do deallocate (res_hist%resonances) allocate (res_hist%resonances (n+1)) do i = 1, n call tmp(i)%copy (res_hist%resonances(i)) end do deallocate (tmp) end if call resonance%copy (res_hist%resonances(n+1)) res_hist%n_resonances = n + 1 if (debug_on) call msg_debug & (D_PHASESPACE, "res_hist%n_resonances", res_hist%n_resonances) end subroutine resonance_history_add_resonance @ %def resonance_history_add_resonance @ <>= procedure :: remove_resonance => resonance_history_remove_resonance +<>= + module subroutine resonance_history_remove_resonance (res_hist, i_res) + class(resonance_history_t), intent(inout) :: res_hist + integer, intent(in) :: i_res + end subroutine resonance_history_remove_resonance <>= - subroutine resonance_history_remove_resonance (res_hist, i_res) + module subroutine resonance_history_remove_resonance (res_hist, i_res) class(resonance_history_t), intent(inout) :: res_hist integer, intent(in) :: i_res type(resonance_info_t), dimension(:), allocatable :: tmp_1, tmp_2 integer :: i, j, n n = res_hist%n_resonances res_hist%n_resonances = n - 1 if (res_hist%n_resonances == 0) then deallocate (res_hist%resonances) else if (i_res > 1) allocate (tmp_1(1:i_res-1)) if (i_res < n) allocate (tmp_2(i_res+1:n)) if (allocated (tmp_1)) then do i = 1, i_res - 1 call res_hist%resonances(i)%copy (tmp_1(i)) end do end if if (allocated (tmp_2)) then do i = i_res + 1, n call res_hist%resonances(i)%copy (tmp_2(i)) end do end if deallocate (res_hist%resonances) allocate (res_hist%resonances (res_hist%n_resonances)) j = 1 if (allocated (tmp_1)) then do i = 1, i_res - 1 call tmp_1(i)%copy (res_hist%resonances(j)) j = j + 1 end do deallocate (tmp_1) end if if (allocated (tmp_2)) then do i = i_res + 1, n call tmp_2(i)%copy (res_hist%resonances(j)) j = j + 1 end do deallocate (tmp_2) end if end if end subroutine resonance_history_remove_resonance @ %def resonance_history_remove_resonance @ <>= procedure :: add_offset => resonance_history_add_offset +<>= + module subroutine resonance_history_add_offset (res_hist, n) + class(resonance_history_t), intent(inout) :: res_hist + integer, intent(in) :: n + end subroutine resonance_history_add_offset <>= - subroutine resonance_history_add_offset (res_hist, n) + module subroutine resonance_history_add_offset (res_hist, n) class(resonance_history_t), intent(inout) :: res_hist integer, intent(in) :: n integer :: i_res do i_res = 1, res_hist%n_resonances associate (contributors => res_hist%resonances(i_res)%contributors%c) contributors = contributors + n end associate end do end subroutine resonance_history_add_offset @ %def resonance_history_add_offset @ <>= procedure :: contains_leg => resonance_history_contains_leg +<>= + module function resonance_history_contains_leg & + (res_hist, i_leg) result (val) + logical :: val + class(resonance_history_t), intent(in) :: res_hist + integer, intent(in) :: i_leg + end function resonance_history_contains_leg <>= - function resonance_history_contains_leg (res_hist, i_leg) result (val) + module function resonance_history_contains_leg & + (res_hist, i_leg) result (val) logical :: val class(resonance_history_t), intent(in) :: res_hist integer, intent(in) :: i_leg integer :: i_res val = .false. do i_res = 1, res_hist%n_resonances if (any (res_hist%resonances(i_res)%contributors%c == i_leg)) then val = .true. exit end if end do end function resonance_history_contains_leg @ %def resonance_history_contains_leg @ <>= procedure :: mapping => resonance_history_mapping +<>= + module function resonance_history_mapping & + (res_hist, p, i_gluon) result (p_map) + real(default) :: p_map + class(resonance_history_t), intent(in) :: res_hist + type(vector4_t), intent(in), dimension(:) :: p + integer, intent(in), optional :: i_gluon + end function resonance_history_mapping <>= - function resonance_history_mapping (res_hist, p, i_gluon) result (p_map) + module function resonance_history_mapping & + (res_hist, p, i_gluon) result (p_map) real(default) :: p_map class(resonance_history_t), intent(in) :: res_hist type(vector4_t), intent(in), dimension(:) :: p integer, intent(in), optional :: i_gluon integer :: i_res real(default) :: s p_map = one do i_res = 1, res_hist%n_resonances associate (res => res_hist%resonances(i_res)) s = compute_resonance_mass (p, res%contributors%c, i_gluon)**2 p_map = p_map * res%mapping (s) end associate end do end function resonance_history_mapping @ %def resonance_history_mapping @ This predicate is true if all resonances in the history have exactly [[n]] contributors. For instance, if $n=2$, all resonances have a two-particle decay. <>= - procedure :: only_has_n_contributors => resonance_history_only_has_n_contributors + procedure :: only_has_n_contributors => & + resonance_history_only_has_n_contributors +<>= + module function resonance_history_only_has_n_contributors & + (res_hist, n) result (value) + logical :: value + class(resonance_history_t), intent(in) :: res_hist + integer, intent(in) :: n + end function resonance_history_only_has_n_contributors <>= - function resonance_history_only_has_n_contributors (res_hist, n) result (value) + module function resonance_history_only_has_n_contributors & + (res_hist, n) result (value) logical :: value class(resonance_history_t), intent(in) :: res_hist integer, intent(in) :: n integer :: i_res value = .true. do i_res = 1, res_hist%n_resonances associate (res => res_hist%resonances(i_res)) value = value .and. size (res%contributors%c) == n end associate end do end function resonance_history_only_has_n_contributors @ %def resonance_history_only_has_n_contributors @ <>= procedure :: has_flavor => resonance_history_has_flavor +<>= + module function resonance_history_has_flavor & + (res_hist, flv) result (has_flv) + logical :: has_flv + class(resonance_history_t), intent(in) :: res_hist + type(flavor_t), intent(in) :: flv + end function resonance_history_has_flavor <>= - function resonance_history_has_flavor (res_hist, flv) result (has_flv) + module function resonance_history_has_flavor & + (res_hist, flv) result (has_flv) logical :: has_flv class(resonance_history_t), intent(in) :: res_hist type(flavor_t), intent(in) :: flv integer :: i has_flv = .false. do i = 1, res_hist%n_resonances has_flv = has_flv .or. res_hist%resonances(i)%flavor == flv end do end function resonance_history_has_flavor @ %def resonance_history_has_flavor @ \subsection{Kinematics} Evaluate the distance from a resonance. The distance is given by $|p^2-m^2|/(m\Gamma)$. For $\Gamma\ll m$, this is the relative distance from the resonance peak in units of the half-width. <>= procedure :: evaluate_distance => resonance_info_evaluate_distance +<>= + module subroutine resonance_info_evaluate_distance (res_info, p, dist) + class(resonance_info_t), intent(in) :: res_info + type(vector4_t), dimension(:), intent(in) :: p + real(default), intent(out) :: dist + end subroutine resonance_info_evaluate_distance <>= - subroutine resonance_info_evaluate_distance (res_info, p, dist) + module subroutine resonance_info_evaluate_distance (res_info, p, dist) class(resonance_info_t), intent(in) :: res_info type(vector4_t), dimension(:), intent(in) :: p real(default), intent(out) :: dist real(default) :: m, w type(vector4_t) :: q m = res_info%flavor%get_mass () w = res_info%flavor%get_width () q = sum (p(res_info%contributors%c)) dist = abs (q**2 - m**2) / (m * w) end subroutine resonance_info_evaluate_distance @ %def resonance_info_evaluate_distance @ Evaluate the array of distances from a resonance history. We assume that the array has been allocated with correct size, namely the number of resonances in this history. <>= procedure :: evaluate_distances => resonance_history_evaluate_distances +<>= + module subroutine resonance_history_evaluate_distances (res_hist, p, dist) + class(resonance_history_t), intent(in) :: res_hist + type(vector4_t), dimension(:), intent(in) :: p + real(default), dimension(:), intent(out) :: dist + end subroutine resonance_history_evaluate_distances <>= - subroutine resonance_history_evaluate_distances (res_hist, p, dist) + module subroutine resonance_history_evaluate_distances (res_hist, p, dist) class(resonance_history_t), intent(in) :: res_hist type(vector4_t), dimension(:), intent(in) :: p real(default), dimension(:), intent(out) :: dist integer :: i do i = 1, res_hist%n_resonances call res_hist%resonances(i)%evaluate_distance (p, dist(i)) end do end subroutine resonance_history_evaluate_distances @ %def resonance_history_evaluate_distances @ Use the distance to determine a Gaussian turnoff factor for a resonance. The factor is given by a Gaussian function $e^{-d^2/\sigma^2}$, where $\sigma$ is the [[gw]] parameter multiplied by the resonance width, and $d$ is the distance (see above). So, for $d=\sigma$, the factor is $0.37$, and for $d=2\sigma$ we get $0.018$. If the [[gw]] factor is less or equal to zero, return $1$. <>= procedure :: evaluate_gaussian => resonance_info_evaluate_gaussian +<>= + module function resonance_info_evaluate_gaussian & + (res_info, p, gw) result (factor) + class(resonance_info_t), intent(in) :: res_info + type(vector4_t), dimension(:), intent(in) :: p + real(default), intent(in) :: gw + real(default) :: factor + end function resonance_info_evaluate_gaussian <>= - function resonance_info_evaluate_gaussian (res_info, p, gw) result (factor) + module function resonance_info_evaluate_gaussian & + (res_info, p, gw) result (factor) class(resonance_info_t), intent(in) :: res_info type(vector4_t), dimension(:), intent(in) :: p real(default), intent(in) :: gw real(default) :: factor real(default) :: dist, w if (gw > 0) then w = res_info%flavor%get_width () call res_info%evaluate_distance (p, dist) factor = exp (- (dist / (gw * w)) **2) else factor = 1 end if end function resonance_info_evaluate_gaussian @ %def resonance_info_evaluate_gaussian @ The Gaussian factor of the history is the product of all factors. <>= procedure :: evaluate_gaussian => resonance_history_evaluate_gaussian +<>= + module function resonance_history_evaluate_gaussian & + (res_hist, p, gw) result (factor) + class(resonance_history_t), intent(in) :: res_hist + type(vector4_t), dimension(:), intent(in) :: p + real(default), intent(in) :: gw + real(default) :: factor + end function resonance_history_evaluate_gaussian <>= - function resonance_history_evaluate_gaussian (res_hist, p, gw) result (factor) + module function resonance_history_evaluate_gaussian & + (res_hist, p, gw) result (factor) class(resonance_history_t), intent(in) :: res_hist type(vector4_t), dimension(:), intent(in) :: p real(default), intent(in) :: gw real(default), dimension(:), allocatable :: dist real(default) :: factor integer :: i factor = 1 do i = 1, res_hist%n_resonances factor = factor * res_hist%resonances(i)%evaluate_gaussian (p, gw) end do end function resonance_history_evaluate_gaussian @ %def resonance_history_evaluate_gaussian @ Use the distances to determine whether the resonance history can qualify as on-shell. The criterion is whether the distance is greater than the number of width values as given by [[on_shell_limit]]. <>= procedure :: is_on_shell => resonance_info_is_on_shell +<>= + module function resonance_info_is_on_shell (res_info, p, on_shell_limit) & + result (flag) + class(resonance_info_t), intent(in) :: res_info + type(vector4_t), dimension(:), intent(in) :: p + real(default), intent(in) :: on_shell_limit + logical :: flag + end function resonance_info_is_on_shell <>= - function resonance_info_is_on_shell (res_info, p, on_shell_limit) & + module function resonance_info_is_on_shell (res_info, p, on_shell_limit) & result (flag) class(resonance_info_t), intent(in) :: res_info type(vector4_t), dimension(:), intent(in) :: p real(default), intent(in) :: on_shell_limit logical :: flag real(default) :: dist call res_info%evaluate_distance (p, dist) flag = dist < on_shell_limit end function resonance_info_is_on_shell @ %def resonance_info_is_on_shell @ <>= procedure :: is_on_shell => resonance_history_is_on_shell +<>= + module function resonance_history_is_on_shell & + (res_hist, p, on_shell_limit) result (flag) + class(resonance_history_t), intent(in) :: res_hist + type(vector4_t), dimension(:), intent(in) :: p + real(default), intent(in) :: on_shell_limit + logical :: flag + end function resonance_history_is_on_shell <>= - function resonance_history_is_on_shell (res_hist, p, on_shell_limit) & - result (flag) + module function resonance_history_is_on_shell & + (res_hist, p, on_shell_limit) result (flag) class(resonance_history_t), intent(in) :: res_hist type(vector4_t), dimension(:), intent(in) :: p real(default), intent(in) :: on_shell_limit logical :: flag integer :: i flag = .true. do i = 1, res_hist%n_resonances flag = flag .and. res_hist%resonances(i)%is_on_shell (p, on_shell_limit) end do end function resonance_history_is_on_shell @ %def resonance_history_is_on_shell @ \subsection{OMega restriction strings} One application of the resonance module is creating restriction strings that can be fed into process definitions with the OMega generator. Since OMega counts the incoming particles first, we have to supply [[n_in]] as an offset. <>= procedure :: as_omega_string => resonance_info_as_omega_string <>= procedure :: as_omega_string => resonance_history_as_omega_string +<>= + module function resonance_info_as_omega_string & + (res_info, n_in) result (string) + class(resonance_info_t), intent(in) :: res_info + integer, intent(in) :: n_in + type(string_t) :: string + end function resonance_info_as_omega_string + module function resonance_history_as_omega_string & + (res_hist, n_in) result (string) + class(resonance_history_t), intent(in) :: res_hist + integer, intent(in) :: n_in + type(string_t) :: string + end function resonance_history_as_omega_string <>= - function resonance_info_as_omega_string (res_info, n_in) result (string) + module function resonance_info_as_omega_string & + (res_info, n_in) result (string) class(resonance_info_t), intent(in) :: res_info integer, intent(in) :: n_in type(string_t) :: string integer :: i string = "" if (allocated (res_info%contributors%c)) then do i = 1, size (res_info%contributors%c) if (i > 1) string = string // "+" string = string // str (res_info%contributors%c(i) + n_in) end do string = string // "~" // res_info%flavor%get_name () end if end function resonance_info_as_omega_string - function resonance_history_as_omega_string (res_hist, n_in) result (string) + module function resonance_history_as_omega_string & + (res_hist, n_in) result (string) class(resonance_history_t), intent(in) :: res_hist integer, intent(in) :: n_in type(string_t) :: string integer :: i string = "" do i = 1, res_hist%n_resonances if (i > 1) string = string // " && " string = string // res_hist%resonances(i)%as_omega_string (n_in) end do end function resonance_history_as_omega_string @ %def resonance_info_as_omega_string @ %def resonance_history_as_omega_string @ \subsection{Resonance history as tree} If we want to organize the resonances and their decay products, it can be useful to have them explicitly as a tree structure. We implement this in the traditional event-record form with the resonances sorted by decreasing number of contributors, and their decay products added as an extra array. <>= public :: resonance_tree_t <>= type :: resonance_branch_t integer :: i = 0 type(flavor_t) :: flv integer, dimension(:), allocatable :: r_child integer, dimension(:), allocatable :: o_child end type resonance_branch_t type :: resonance_tree_t private integer :: n = 0 type(resonance_branch_t), dimension(:), allocatable :: branch contains <> end type resonance_tree_t @ %def resonance_branch_t resonance_tree_t @ <>= procedure :: write => resonance_tree_write +<>= + module subroutine resonance_tree_write (tree, unit, indent) + class(resonance_tree_t), intent(in) :: tree + integer, intent(in), optional :: unit, indent + end subroutine resonance_tree_write <>= - subroutine resonance_tree_write (tree, unit, indent) + module subroutine resonance_tree_write (tree, unit, indent) class(resonance_tree_t), intent(in) :: tree integer, intent(in), optional :: unit, indent integer :: u, b, c u = given_output_unit (unit) call write_indent (u, indent) write (u, "(A)", advance="no") "Resonance tree:" if (tree%n > 0) then write (u, *) do b = 1, tree%n call write_indent (u, indent) write (u, "(2x,'r',I0,':',1x)", advance="no") b associate (branch => tree%branch(b)) call branch%flv%write (u) write (u, "(1x,'=>')", advance="no") if (allocated (branch%r_child)) then do c = 1, size (branch%r_child) write (u, "(1x,'r',I0)", advance="no") branch%r_child(c) end do end if if (allocated (branch%o_child)) then do c = 1, size (branch%o_child) write (u, "(1x,I0)", advance="no") branch%o_child(c) end do end if write (u, *) end associate end do else write (u, "(1x,A)") "[empty]" end if end subroutine resonance_tree_write @ %def resonance_tree_write @ Contents. <>= procedure :: get_n_resonances => resonance_tree_get_n_resonances procedure :: get_flv => resonance_tree_get_flv +<>= + module function resonance_tree_get_n_resonances (tree) result (n) + class(resonance_tree_t), intent(in) :: tree + integer :: n + end function resonance_tree_get_n_resonances + module function resonance_tree_get_flv (tree, i) result (flv) + class(resonance_tree_t), intent(in) :: tree + integer, intent(in) :: i + type(flavor_t) :: flv + end function resonance_tree_get_flv <>= - function resonance_tree_get_n_resonances (tree) result (n) + module function resonance_tree_get_n_resonances (tree) result (n) class(resonance_tree_t), intent(in) :: tree integer :: n n = tree%n end function resonance_tree_get_n_resonances - function resonance_tree_get_flv (tree, i) result (flv) + module function resonance_tree_get_flv (tree, i) result (flv) class(resonance_tree_t), intent(in) :: tree integer, intent(in) :: i type(flavor_t) :: flv flv = tree%branch(i)%flv end function resonance_tree_get_flv @ %def resonance_tree_get_n_resonances @ %def resonance_tree_get_flv @ Return the shifted indices of the resonance children for branch [[i]]. For a child which is itself a resonance, add [[offset_r]] to the index value. For the others, add [[offset_o]]. Combine both in a single array. <>= procedure :: get_children => resonance_tree_get_children +<>= + module function resonance_tree_get_children (tree, i, offset_r, offset_o) & + result (child) + class(resonance_tree_t), intent(in) :: tree + integer, intent(in) :: i, offset_r, offset_o + integer, dimension(:), allocatable :: child + end function resonance_tree_get_children <>= - function resonance_tree_get_children (tree, i, offset_r, offset_o) & + module function resonance_tree_get_children (tree, i, offset_r, offset_o) & result (child) class(resonance_tree_t), intent(in) :: tree integer, intent(in) :: i, offset_r, offset_o integer, dimension(:), allocatable :: child integer :: nr, no associate (branch => tree%branch(i)) nr = size (branch%r_child) no = size (branch%o_child) allocate (child (nr + no)) child(1:nr) = branch%r_child + offset_r child(nr+1:nr+no) = branch%o_child + offset_o end associate end function resonance_tree_get_children @ %def resonance_tree_get_children @ Transform a resonance history into a resonance tree. Algorithm: \begin{enumerate} \item Determine a mapping of the resonance array, such that in the new array the resonances are ordered by decreasing number of contributors. \item Copy the flavor entries to the mapped array. \item Scan all resonances and, for each one, find a resonance that is its parent. Since the resonances are ordered, later matches overwrite earlier ones. The last match is the correct one. Then scan again and, for each resonance, collect the resonances that have it as parent. This is the set of child resonances. \item Analogously, scan all outgoing particles that appear in any of the contributors list. Determine their immediate parent as above, and set the child outgoing parents for the resonances, as above. \end{enumerate} <>= procedure :: to_tree => resonance_history_to_tree +<>= + module subroutine resonance_history_to_tree (res_hist, tree) + class(resonance_history_t), intent(in) :: res_hist + type(resonance_tree_t), intent(out) :: tree + end subroutine resonance_history_to_tree <>= - subroutine resonance_history_to_tree (res_hist, tree) + module subroutine resonance_history_to_tree (res_hist, tree) class(resonance_history_t), intent(in) :: res_hist type(resonance_tree_t), intent(out) :: tree integer :: nr integer, dimension(:), allocatable :: r_branch, r_source nr = res_hist%n_resonances tree%n = nr allocate (tree%branch (tree%n), r_branch (tree%n), r_source (tree%n)) if (tree%n > 0) then call find_branch_ordering () call set_flavors () call set_child_resonances () call set_child_outgoing () end if contains subroutine find_branch_ordering () integer, dimension(:), allocatable :: nc_array integer :: r, ir, nc allocate (nc_array (tree%n)) nc_array(:) = res_hist%resonances%get_n_contributors () ir = 0 do nc = maxval (nc_array), minval (nc_array), -1 do r = 1, nr if (nc_array(r) == nc) then ir = ir + 1 r_branch(r) = ir r_source(ir) = r end if end do end do end subroutine find_branch_ordering subroutine set_flavors () integer :: r do r = 1, nr tree%branch(r_branch(r))%flv = res_hist%resonances(r)%flavor end do end subroutine set_flavors subroutine set_child_resonances () integer, dimension(:), allocatable :: r_child, r_parent integer :: r, ir, pr allocate (r_parent (nr), source = 0) SCAN_RES: do r = 1, nr associate (this_res => res_hist%resonances(r)) SCAN_PARENT: do ir = 1, nr pr = r_source(ir) if (pr == r) cycle SCAN_PARENT if (all (res_hist%resonances(pr)%contains & (this_res%contributors%c))) then r_parent (r) = pr end if end do SCAN_PARENT end associate end do SCAN_RES allocate (r_child (nr), source = [(r, r = 1, nr)]) do r = 1, nr ir = r_branch(r) tree%branch(ir)%r_child = r_branch (pack (r_child, r_parent == r)) end do end subroutine set_child_resonances subroutine set_child_outgoing () integer, dimension(:), allocatable :: o_child, o_parent integer :: o_max, r, o, ir o_max = 0 do r = 1, nr associate (this_res => res_hist%resonances(r)) o_max = max (o_max, maxval (this_res%contributors%c)) end associate end do allocate (o_parent (o_max), source=0) SCAN_OUT: do o = 1, o_max SCAN_PARENT: do ir = 1, nr r = r_source(ir) associate (this_res => res_hist%resonances(r)) if (this_res%contains (o)) o_parent(o) = r end associate end do SCAN_PARENT end do SCAN_OUT allocate (o_child (o_max), source = [(o, o = 1, o_max)]) do r = 1, nr ir = r_branch(r) tree%branch(ir)%o_child = pack (o_child, o_parent == r) end do end subroutine set_child_outgoing end subroutine resonance_history_to_tree @ %def resonance_history_to_tree @ \subsection{Resonance history set} This is an array of resonance histories. The elements are supposed to be unique. That is, entering a new element is successful only if the element does not already exist. The current implementation uses a straightforward linear search for comparison. If this should become an issue, we may change the implementation to a hash table. To keep this freedom, the set should be an opaque object. In fact, we expect to use it as a transient data structure. Once the set is complete, we transform it into a contiguous array. <>= public :: resonance_history_set_t <>= type :: index_array_t integer, dimension(:), allocatable :: i end type index_array_t type :: resonance_history_set_t private logical :: complete = .false. integer :: n_filter = 0 type(resonance_history_t), dimension(:), allocatable :: history type(index_array_t), dimension(:), allocatable :: contains_this type(resonance_tree_t), dimension(:), allocatable :: tree integer :: last = 0 contains <> end type resonance_history_set_t @ %def resonance_history_set_t @ Display. The tree-format version of the histories is displayed only upon request. <>= procedure :: write => resonance_history_set_write +<>= + module subroutine resonance_history_set_write & + (res_set, unit, indent, show_trees) + class(resonance_history_set_t), intent(in) :: res_set + integer, intent(in), optional :: unit + integer, intent(in), optional :: indent + logical, intent(in), optional :: show_trees + end subroutine resonance_history_set_write <>= - subroutine resonance_history_set_write (res_set, unit, indent, show_trees) + module subroutine resonance_history_set_write & + (res_set, unit, indent, show_trees) class(resonance_history_set_t), intent(in) :: res_set integer, intent(in), optional :: unit integer, intent(in), optional :: indent logical, intent(in), optional :: show_trees logical :: s_trees integer :: u, i, j, ind u = given_output_unit (unit) s_trees = .false.; if (present (show_trees)) s_trees = show_trees ind = 0; if (present (indent)) ind = indent call write_indent (u, indent) write (u, "(A)", advance="no") "Resonance history set:" if (res_set%complete) then write (u, *) else write (u, "(1x,A)") "[incomplete]" end if do i = 1, res_set%last write (u, "(1x,I0,1x)", advance="no") i call res_set%history(i)%write (u, verbose=.false., indent=indent) if (allocated (res_set%contains_this)) then call write_indent (u, indent) write (u, "(3x,A)", advance="no") "contained in (" - do j = 1, size (res_set%contains_this(i)%i) + do j = 1, size (res_set%contains_this(i)%i) if (j>1) write (u, "(',')", advance="no") write (u, "(I0)", advance="no") res_set%contains_this(i)%i(j) end do write (u, "(A)") ")" end if if (s_trees .and. allocated (res_set%tree)) then call res_set%tree(i)%write (u, ind + 1) end if end do end subroutine resonance_history_set_write @ %def resonance_history_set_write @ Initialization. The default initial size is 16 elements, to be doubled in size repeatedly as needed. <>= integer, parameter :: resonance_history_set_initial_size = 16 @ %def resonance_history_set_initial_size = 16 <>= procedure :: init => resonance_history_set_init +<>= + module subroutine resonance_history_set_init & + (res_set, n_filter, initial_size) + class(resonance_history_set_t), intent(out) :: res_set + integer, intent(in), optional :: n_filter + integer, intent(in), optional :: initial_size + end subroutine resonance_history_set_init <>= - subroutine resonance_history_set_init (res_set, n_filter, initial_size) + module subroutine resonance_history_set_init & + (res_set, n_filter, initial_size) class(resonance_history_set_t), intent(out) :: res_set integer, intent(in), optional :: n_filter integer, intent(in), optional :: initial_size if (present (n_filter)) res_set%n_filter = n_filter if (present (initial_size)) then allocate (res_set%history (initial_size)) else allocate (res_set%history (resonance_history_set_initial_size)) end if end subroutine resonance_history_set_init @ %def resonance_history_set_init @ Enter an entry: append to the array if it does not yet exist, expand as needed. If a [[n_filter]] value has been provided, enter the resonance only if it fulfils the requirement. An empty resonance history is entered only if the [[trivial]] flag is set. <>= procedure :: enter => resonance_history_set_enter +<>= + module subroutine resonance_history_set_enter & + (res_set, res_history, trivial) + class(resonance_history_set_t), intent(inout) :: res_set + type(resonance_history_t), intent(in) :: res_history + logical, intent(in), optional :: trivial + end subroutine resonance_history_set_enter <>= - subroutine resonance_history_set_enter (res_set, res_history, trivial) + module subroutine resonance_history_set_enter & + (res_set, res_history, trivial) class(resonance_history_set_t), intent(inout) :: res_set type(resonance_history_t), intent(in) :: res_history logical, intent(in), optional :: trivial integer :: i, new if (res_history%n_resonances == 0) then if (present (trivial)) then if (.not. trivial) return else return end if end if if (res_set%n_filter > 0) then if (.not. res_history%only_has_n_contributors (res_set%n_filter)) return end if do i = 1, res_set%last if (res_set%history(i) == res_history) return end do new = res_set%last + 1 if (new > size (res_set%history)) call res_set%expand () res_set%history(new) = res_history res_set%last = new end subroutine resonance_history_set_enter @ %def resonance_history_set_enter @ Freeze the resonance history set: determine the array that determines in which other resonance histories a particular history is contained. This can only be done once, and once this is done, no further histories can be entered. <>= procedure :: freeze => resonance_history_set_freeze +<>= + module subroutine resonance_history_set_freeze (res_set) + class(resonance_history_set_t), intent(inout) :: res_set + end subroutine resonance_history_set_freeze <>= - subroutine resonance_history_set_freeze (res_set) + module subroutine resonance_history_set_freeze (res_set) class(resonance_history_set_t), intent(inout) :: res_set integer :: i, n, c logical, dimension(:), allocatable :: contains_this integer, dimension(:), allocatable :: index_array n = res_set%last allocate (contains_this (n)) allocate (index_array (n), source = [(i, i=1, n)]) allocate (res_set%contains_this (n)) do i = 1, n contains_this = resonance_history_contains & (res_set%history(1:n), res_set%history(i)) c = count (contains_this) allocate (res_set%contains_this(i)%i (c)) res_set%contains_this(i)%i = pack (index_array, contains_this) end do allocate (res_set%tree (n)) do i = 1, n call res_set%history(i)%to_tree (res_set%tree(i)) end do res_set%complete = .true. end subroutine resonance_history_set_freeze @ %def resonance_history_set_freeze @ Determine the histories (in form of their indices in the array) that can be considered on-shell, given a set of momenta and a maximum distance. The distance from the resonance is measured in multiples of the resonance width. Note that the momentum array must only contain the outgoing particles. If a particular history is on-shell, but there is another history which contains this and also is on-shell, only the latter is retained. <>= procedure :: determine_on_shell_histories & => resonance_history_set_determine_on_shell_histories +<>= + module subroutine resonance_history_set_determine_on_shell_histories & + (res_set, p, on_shell_limit, index_array) + class(resonance_history_set_t), intent(in) :: res_set + type(vector4_t), dimension(:), intent(in) :: p + real(default), intent(in) :: on_shell_limit + integer, dimension(:), allocatable, intent(out) :: index_array + end subroutine resonance_history_set_determine_on_shell_histories <>= - subroutine resonance_history_set_determine_on_shell_histories & + module subroutine resonance_history_set_determine_on_shell_histories & (res_set, p, on_shell_limit, index_array) class(resonance_history_set_t), intent(in) :: res_set type(vector4_t), dimension(:), intent(in) :: p real(default), intent(in) :: on_shell_limit integer, dimension(:), allocatable, intent(out) :: index_array integer :: n, i integer, dimension(:), allocatable :: i_array if (res_set%complete) then n = res_set%last allocate (i_array (n), source=0) do i = 1, n if (res_set%history(i)%is_on_shell (p, on_shell_limit)) i_array(i) = i end do do i = 1, n if (any (i_array(res_set%contains_this(i)%i) /= 0)) then i_array(i) = 0 end if end do allocate (index_array (count (i_array /= 0))) index_array(:) = pack (i_array, i_array /= 0) end if end subroutine resonance_history_set_determine_on_shell_histories @ %def resonance_history_set_determine_on_shell_histories @ For the selected history, compute the Gaussian turnoff factor. The turnoff parameter is [[gw]]. <>= procedure :: evaluate_gaussian => resonance_history_set_evaluate_gaussian +<>= + module function resonance_history_set_evaluate_gaussian & + (res_set, p, gw, i) result (factor) + class(resonance_history_set_t), intent(in) :: res_set + type(vector4_t), dimension(:), intent(in) :: p + real(default), intent(in) :: gw + integer, intent(in) :: i + real(default) :: factor + end function resonance_history_set_evaluate_gaussian <>= - function resonance_history_set_evaluate_gaussian (res_set, p, gw, i) & - result (factor) + module function resonance_history_set_evaluate_gaussian & + (res_set, p, gw, i) result (factor) class(resonance_history_set_t), intent(in) :: res_set type(vector4_t), dimension(:), intent(in) :: p real(default), intent(in) :: gw integer, intent(in) :: i real(default) :: factor factor = res_set%history(i)%evaluate_gaussian (p, gw) end function resonance_history_set_evaluate_gaussian @ %def resonance_history_set_evaluate_gaussian @ Return the number of histories. This is zero if there are none, or if [[freeze]] has not been called yet. <>= procedure :: get_n_history => resonance_history_set_get_n_history +<>= + module function resonance_history_set_get_n_history (res_set) result (n) + class(resonance_history_set_t), intent(in) :: res_set + integer :: n + end function resonance_history_set_get_n_history <>= - function resonance_history_set_get_n_history (res_set) result (n) + module function resonance_history_set_get_n_history (res_set) result (n) class(resonance_history_set_t), intent(in) :: res_set integer :: n if (res_set%complete) then n = res_set%last else n = 0 end if end function resonance_history_set_get_n_history @ %def resonance_history_set_get_n_history @ Return a single history. <>= procedure :: get_history => resonance_history_set_get_history +<>= + module function resonance_history_set_get_history & + (res_set, i) result (res_history) + class(resonance_history_set_t), intent(in) :: res_set + integer, intent(in) :: i + type(resonance_history_t) :: res_history + end function resonance_history_set_get_history <>= - function resonance_history_set_get_history (res_set, i) result (res_history) + module function resonance_history_set_get_history & + (res_set, i) result (res_history) class(resonance_history_set_t), intent(in) :: res_set integer, intent(in) :: i type(resonance_history_t) :: res_history if (res_set%complete .and. i <= res_set%last) then res_history = res_set%history(i) end if end function resonance_history_set_get_history @ %def resonance_history_set_get_history @ Conversion to a plain array, sized correctly. <>= procedure :: to_array => resonance_history_set_to_array +<>= + module subroutine resonance_history_set_to_array (res_set, res_history) + class(resonance_history_set_t), intent(in) :: res_set + type(resonance_history_t), dimension(:), allocatable, intent(out) :: & + res_history + end subroutine resonance_history_set_to_array <>= - subroutine resonance_history_set_to_array (res_set, res_history) + module subroutine resonance_history_set_to_array (res_set, res_history) class(resonance_history_set_t), intent(in) :: res_set - type(resonance_history_t), dimension(:), allocatable, intent(out) :: res_history + type(resonance_history_t), dimension(:), allocatable, intent(out) :: & + res_history if (res_set%complete) then allocate (res_history (res_set%last)) res_history(:) = res_set%history(1:res_set%last) end if end subroutine resonance_history_set_to_array @ %def resonance_history_set_to_array @ Return a selected history in tree form. <>= procedure :: get_tree => resonance_history_set_get_tree +<>= + module subroutine resonance_history_set_get_tree (res_set, i, res_tree) + class(resonance_history_set_t), intent(in) :: res_set + integer, intent(in) :: i + type(resonance_tree_t), intent(out) :: res_tree + end subroutine resonance_history_set_get_tree <>= - subroutine resonance_history_set_get_tree (res_set, i, res_tree) + module subroutine resonance_history_set_get_tree (res_set, i, res_tree) class(resonance_history_set_t), intent(in) :: res_set integer, intent(in) :: i type(resonance_tree_t), intent(out) :: res_tree if (res_set%complete) then res_tree = res_set%tree(i) end if end subroutine resonance_history_set_get_tree @ %def resonance_history_set_to_array @ Expand: double the size of the array. We do not need this in the API. <>= procedure, private :: expand => resonance_history_set_expand +<>= + module subroutine resonance_history_set_expand (res_set) + class(resonance_history_set_t), intent(inout) :: res_set + end subroutine resonance_history_set_expand <>= - subroutine resonance_history_set_expand (res_set) + module subroutine resonance_history_set_expand (res_set) class(resonance_history_set_t), intent(inout) :: res_set type(resonance_history_t), dimension(:), allocatable :: history_new integer :: s s = size (res_set%history) allocate (history_new (2 * s)) history_new(1:s) = res_set%history(1:s) call move_alloc (history_new, res_set%history) end subroutine resonance_history_set_expand @ %def resonance_history_set_expand @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[resonances_ut.f90]]>>= <> module resonances_ut use unit_tests use resonances_uti <> <> contains <> end module resonances_ut @ %def resonances_ut @ <<[[resonances_uti.f90]]>>= <> module resonances_uti <> <> use format_defs, only: FMF_12 use lorentz, only: vector4_t, vector4_at_rest use model_data, only: model_data_t use flavors, only: flavor_t use resonances, only: resonance_history_t use resonances <> <> contains <> end module resonances_uti @ %def resonances_ut @ API: driver for the unit tests below. <>= public :: resonances_test <>= subroutine resonances_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine resonances_test @ %def resonances_test @ Basic operations on a resonance history object. <>= call test (resonances_1, "resonances_1", & "check resonance history setup", & u, results) <>= public :: resonances_1 <>= subroutine resonances_1 (u) integer, intent(in) :: u type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(model_data_t), target :: model write (u, "(A)") "* Test output: resonances_1" write (u, "(A)") "* Purpose: test resonance history setup" write (u, "(A)") write (u, "(A)") "* Read model file" call model%init_sm_test () write (u, "(A)") write (u, "(A)") "* Empty resonance history" write (u, "(A)") call res_history%write (u) write (u, "(A)") write (u, "(A)") "* Add resonance" write (u, "(A)") call res_info%init (3, -24, model, 5) call res_history%add_resonance (res_info) call res_history%write (u) write (u, "(A)") write (u, "(A)") "* Add another resonance" write (u, "(A)") call res_info%init (7, 23, model, 5) call res_history%add_resonance (res_info) call res_history%write (u) write (u, "(A)") write (u, "(A)") "* Remove resonance" write (u, "(A)") call res_history%remove_resonance (1) call res_history%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: resonances_1" end subroutine resonances_1 @ %def resonances_1 @ Basic operations on a resonance history object. <>= call test (resonances_2, "resonances_2", & "check O'Mega restriction strings", & u, results) <>= public :: resonances_2 <>= subroutine resonances_2 (u) integer, intent(in) :: u type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(model_data_t), target :: model type(string_t) :: restrictions write (u, "(A)") "* Test output: resonances_2" write (u, "(A)") "* Purpose: test OMega restrictions strings & &for resonance history" write (u, "(A)") write (u, "(A)") "* Read model file" call model%init_sm_test () write (u, "(A)") write (u, "(A)") "* Empty resonance history" write (u, "(A)") restrictions = res_history%as_omega_string (2) write (u, "(A,A,A)") "restrictions = '", char (restrictions), "'" write (u, "(A)") write (u, "(A)") "* Add resonance" write (u, "(A)") call res_info%init (3, -24, model, 5) call res_history%add_resonance (res_info) restrictions = res_history%as_omega_string (2) write (u, "(A,A,A)") "restrictions = '", char (restrictions), "'" write (u, "(A)") write (u, "(A)") "* Add another resonance" write (u, "(A)") call res_info%init (7, 23, model, 5) call res_history%add_resonance (res_info) restrictions = res_history%as_omega_string (2) write (u, "(A,A,A)") "restrictions = '", char (restrictions), "'" write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: resonances_2" end subroutine resonances_2 @ %def resonances_2 @ Basic operations on a resonance history set. <>= call test (resonances_3, "resonances_3", & "check resonance history set", & u, results) <>= public :: resonances_3 <>= subroutine resonances_3 (u) integer, intent(in) :: u type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(resonance_history_t), dimension(:), allocatable :: res_histories type(resonance_history_set_t) :: res_set type(model_data_t), target :: model integer :: i write (u, "(A)") "* Test output: resonances_3" write (u, "(A)") "* Purpose: test resonance history set" write (u, "(A)") write (u, "(A)") "* Read model file" call model%init_sm_test () write (u, "(A)") write (u, "(A)") "* Initialize resonance history set" write (u, "(A)") call res_set%init (initial_size = 2) write (u, "(A)") "* Add resonance histories, one at a time" write (u, "(A)") call res_history%write (u) call res_set%enter (res_history) call res_history%clear () write (u, *) call res_info%init (3, -24, model, 5) call res_history%add_resonance (res_info) call res_history%write (u) call res_set%enter (res_history) call res_history%clear () write (u, *) call res_info%init (3, -24, model, 5) call res_history%add_resonance (res_info) call res_info%init (7, 23, model, 5) call res_history%add_resonance (res_info) call res_history%write (u) call res_set%enter (res_history) call res_history%clear () write (u, *) call res_info%init (7, 23, model, 5) call res_history%add_resonance (res_info) call res_history%write (u) call res_set%enter (res_history) call res_history%clear () write (u, *) call res_info%init (3, -24, model, 5) call res_history%add_resonance (res_info) call res_history%write (u) call res_set%enter (res_history) call res_history%clear () write (u, *) call res_info%init (3, -24, model, 5) call res_history%add_resonance (res_info) call res_info%init (7, 25, model, 5) call res_history%add_resonance (res_info) call res_history%write (u) call res_set%enter (res_history) call res_history%clear () call res_set%freeze () write (u, "(A)") write (u, "(A)") "* Result" write (u, "(A)") call res_set%write (u) write (u, "(A)") write (u, "(A)") "* Queries" write (u, "(A)") write (u, "(A,1x,I0)") "n_history =", res_set%get_n_history () write (u, "(A)") write (u, "(A)") "History #2:" res_history = res_set%get_history (2) call res_history%write (u, indent=1) call res_history%clear () write (u, "(A)") write (u, "(A)") "* Result in array form" call res_set%to_array (res_histories) do i = 1, size (res_histories) write (u, *) call res_histories(i)%write (u) end do write (u, "(A)") write (u, "(A)") "* Re-initialize resonance history set with filter n=2" write (u, "(A)") call res_set%init (n_filter = 2) write (u, "(A)") "* Add resonance histories, one at a time" write (u, "(A)") call res_info%init (3, -24, model, 5) call res_history%add_resonance (res_info) call res_history%write (u) call res_set%enter (res_history) call res_history%clear () write (u, *) call res_info%init (3, -24, model, 5) call res_history%add_resonance (res_info) call res_info%init (7, 23, model, 5) call res_history%add_resonance (res_info) call res_history%write (u) call res_set%enter (res_history) call res_history%clear () write (u, *) call res_info%init (7, 23, model, 5) call res_history%add_resonance (res_info) call res_history%write (u) call res_set%enter (res_history) call res_history%clear () write (u, *) call res_info%init (3, -24, model, 5) call res_history%add_resonance (res_info) call res_history%write (u) call res_set%enter (res_history) call res_history%clear () call res_set%freeze () write (u, "(A)") write (u, "(A)") "* Result" write (u, "(A)") call res_set%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: resonances_3" end subroutine resonances_3 @ %def resonances_3 @ Probe momenta for resonance histories <>= call test (resonances_4, "resonances_4", & "resonance history: distance evaluation", & u, results) <>= public :: resonances_4 <>= subroutine resonances_4 (u) integer, intent(in) :: u type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(model_data_t), target :: model type(flavor_t) :: fw, fz real(default) :: mw, mz, ww, wz type(vector4_t), dimension(3) :: p real(default), dimension(2) :: dist real(default) :: gw, factor integer :: i write (u, "(A)") "* Test output: resonances_4" write (u, "(A)") "* Purpose: test resonance history evaluation" write (u, "(A)") write (u, "(A)") "* Read model file" call model%init_sm_test () write (u, "(A)") write (u, "(A)") "* W and Z parameters" write (u, "(A)") call fw%init (24, model) call fz%init (23, model) mw = fw%get_mass () ww = fw%get_width () mz = fz%get_mass () wz = fz%get_width () write (u, "(A,1x," // FMF_12 // ")") "mW =", mw write (u, "(A,1x," // FMF_12 // ")") "wW =", ww write (u, "(A,1x," // FMF_12 // ")") "mZ =", mz write (u, "(A,1x," // FMF_12 // ")") "wZ =", wz write (u, "(A)") write (u, "(A)") "* Gaussian width parameter" write (u, "(A)") gw = 2 write (u, "(A,1x," // FMF_12 // ")") "gw =", gw write (u, "(A)") write (u, "(A)") "* Setup resonance histories" write (u, "(A)") call res_info%init (3, -24, model, 5) call res_history%add_resonance (res_info) call res_info%init (7, 23, model, 5) call res_history%add_resonance (res_info) call res_history%write (u) write (u, "(A)") write (u, "(A)") "* Setup zero momenta" write (u, "(A)") do i = 1, 3 call p(i)%write (u) end do write (u, "(A)") write (u, "(A)") "* Evaluate distances from resonances" write (u, "(A)") call res_history%evaluate_distances (p, dist) write (u, "(A,1x," // FMF_12 // ")") "distance (W) =", dist(1) write (u, "(A,1x," // FMF_12 // ")") "m/w (W) =", mw / ww write (u, "(A,1x," // FMF_12 // ")") "distance (Z) =", dist(2) write (u, "(A,1x," // FMF_12 // ")") "m/w (Z) =", mz / wz write (u, "(A)") write (u, "(A)") "* Evaluate Gaussian turnoff factor" write (u, "(A)") factor = res_history%evaluate_gaussian (p, gw) write (u, "(A,1x," // FMF_12 // ")") "gaussian fac =", factor write (u, "(A)") write (u, "(A)") "* Set momenta on W peak" write (u, "(A)") p(1) = vector4_at_rest (mw/2) p(2) = vector4_at_rest (mw/2) do i = 1, 3 call p(i)%write (u) end do write (u, "(A)") write (u, "(A)") "* Evaluate distances from resonances" write (u, "(A)") call res_history%evaluate_distances (p, dist) write (u, "(A,1x," // FMF_12 // ")") "distance (W) =", dist(1) write (u, "(A,1x," // FMF_12 // ")") "distance (Z) =", dist(2) write (u, "(A,1x," // FMF_12 // ")") "expected =", & abs (mz**2 - mw**2) / (mz*wz) write (u, "(A)") write (u, "(A)") "* Evaluate Gaussian turnoff factor" write (u, "(A)") factor = res_history%evaluate_gaussian (p, gw) write (u, "(A,1x," // FMF_12 // ")") "gaussian fac =", factor write (u, "(A,1x," // FMF_12 // ")") "expected =", & exp (- (abs (mz**2 - mw**2) / (mz*wz))**2 / (gw * wz)**2) write (u, "(A)") write (u, "(A)") "* Set momenta on both peaks" write (u, "(A)") p(3) = vector4_at_rest (mz - mw) do i = 1, 3 call p(i)%write (u) end do write (u, "(A)") write (u, "(A)") "* Evaluate distances from resonances" write (u, "(A)") call res_history%evaluate_distances (p, dist) write (u, "(A,1x," // FMF_12 // ")") "distance (W) =", dist(1) write (u, "(A,1x," // FMF_12 // ")") "distance (Z) =", dist(2) write (u, "(A)") write (u, "(A)") "* Evaluate Gaussian turnoff factor" write (u, "(A)") factor = res_history%evaluate_gaussian (p, gw) write (u, "(A,1x," // FMF_12 // ")") "gaussian fac =", factor write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: resonances_4" end subroutine resonances_4 @ %def resonances_4 @ Probe on-shell test for resonance histories <>= call test (resonances_5, "resonances_5", & "resonance history: on-shell test", & u, results) <>= public :: resonances_5 <>= subroutine resonances_5 (u) integer, intent(in) :: u type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(resonance_history_set_t) :: res_set type(model_data_t), target :: model type(flavor_t) :: fw, fz real(default) :: mw, mz, ww, wz real(default) :: on_shell_limit integer, dimension(:), allocatable :: on_shell type(vector4_t), dimension(4) :: p write (u, "(A)") "* Test output: resonances_5" write (u, "(A)") "* Purpose: resonance history on-shell test" write (u, "(A)") write (u, "(A)") "* Read model file" call model%init_sm_test () write (u, "(A)") write (u, "(A)") "* W and Z parameters" write (u, "(A)") call fw%init (24, model) call fz%init (23, model) mw = fw%get_mass () ww = fw%get_width () mz = fz%get_mass () wz = fz%get_width () write (u, "(A,1x," // FMF_12 // ")") "mW =", mw write (u, "(A,1x," // FMF_12 // ")") "wW =", ww write (u, "(A,1x," // FMF_12 // ")") "mZ =", mz write (u, "(A,1x," // FMF_12 // ")") "wZ =", wz write (u, "(A)") write (u, "(A)") "* On-shell parameter: distance as multiple of width" write (u, "(A)") on_shell_limit = 3 write (u, "(A,1x," // FMF_12 // ")") "on-shell limit =", on_shell_limit write (u, "(A)") write (u, "(A)") "* Setup resonance history set" write (u, "(A)") call res_set%init () call res_info%init (3, -24, model, 6) call res_history%add_resonance (res_info) call res_set%enter (res_history) call res_history%clear () call res_info%init (12, 24, model, 6) call res_history%add_resonance (res_info) call res_set%enter (res_history) call res_history%clear () call res_info%init (15, 23, model, 6) call res_history%add_resonance (res_info) call res_set%enter (res_history) call res_history%clear () call res_info%init (3, -24, model, 6) call res_history%add_resonance (res_info) call res_info%init (15, 23, model, 6) call res_history%add_resonance (res_info) call res_set%enter (res_history) call res_history%clear () call res_info%init (12, 24, model, 6) call res_history%add_resonance (res_info) call res_info%init (15, 23, model, 6) call res_history%add_resonance (res_info) call res_set%enter (res_history) call res_history%clear () call res_set%freeze () call res_set%write (u) write (u, "(A)") write (u, "(A)") "* Setup zero momenta" write (u, "(A)") call write_momenta (p) call res_set%determine_on_shell_histories (p, on_shell_limit, on_shell) call write_on_shell_histories (on_shell) write (u, "(A)") write (u, "(A)") "* Setup momenta near W- resonance (2 widths off)" write (u, "(A)") p(1) = vector4_at_rest (82.5_default) call write_momenta (p) call res_set%determine_on_shell_histories (p, on_shell_limit, on_shell) call write_on_shell_histories (on_shell) write (u, "(A)") write (u, "(A)") "* Setup momenta near W- resonance (4 widths off)" write (u, "(A)") p(1) = vector4_at_rest (84.5_default) call write_momenta (p) call res_set%determine_on_shell_histories (p, on_shell_limit, on_shell) call write_on_shell_histories (on_shell) write (u, "(A)") write (u, "(A)") "* Setup momenta near Z resonance" write (u, "(A)") p(1) = vector4_at_rest (45._default) p(3) = vector4_at_rest (45._default) call write_momenta (p) call res_set%determine_on_shell_histories (p, on_shell_limit, on_shell) call write_on_shell_histories (on_shell) write (u, "(A)") write (u, "(A)") "* Setup momenta near W- and W+ resonances" write (u, "(A)") p(1) = vector4_at_rest (40._default) p(2) = vector4_at_rest (40._default) p(3) = vector4_at_rest (40._default) p(4) = vector4_at_rest (40._default) call write_momenta (p) call res_set%determine_on_shell_histories (p, on_shell_limit, on_shell) call write_on_shell_histories (on_shell) write (u, "(A)") write (u, "(A)") "* Setup momenta near W- and Z resonances, & &shadowing single resonances" write (u, "(A)") p(1) = vector4_at_rest (40._default) p(2) = vector4_at_rest (40._default) p(3) = vector4_at_rest (10._default) p(4) = vector4_at_rest ( 0._default) call write_momenta (p) call res_set%determine_on_shell_histories (p, on_shell_limit, on_shell) call write_on_shell_histories (on_shell) write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: resonances_5" contains subroutine write_momenta (p) type(vector4_t), dimension(:), intent(in) :: p integer :: i do i = 1, size (p) call p(i)%write (u) end do end subroutine write_momenta subroutine write_on_shell_histories (on_shell) integer, dimension(:), intent(in) :: on_shell integer :: i write (u, *) write (u, "(A)", advance="no") "on-shell = (" do i = 1, size (on_shell) if (i > 1) write (u, "(',')", advance="no") write (u, "(I0)", advance="no") on_shell(i) end do write (u, "(')')") end subroutine write_on_shell_histories end subroutine resonances_5 @ %def resonances_5 @ Organize the resonance history as a tree structure. <>= call test (resonances_6, "resonances_6", & "check resonance history setup", & u, results) <>= public :: resonances_6 <>= subroutine resonances_6 (u) integer, intent(in) :: u type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(resonance_tree_t) :: res_tree type(model_data_t), target :: model write (u, "(A)") "* Test output: resonances_6" write (u, "(A)") "* Purpose: retrieve resonance histories as trees" write (u, "(A)") write (u, "(A)") "* Read model file" call model%init_sm_test () write (u, "(A)") write (u, "(A)") "* Empty resonance history" write (u, "(A)") call res_history%write (u) write (u, "(A)") call res_history%to_tree (res_tree) call res_tree%write (u) write (u, "(A)") write (u, "(A)") "* Single resonance" write (u, "(A)") call res_info%init (3, -24, model, 5) call res_history%add_resonance (res_info) call res_history%write (u) write (u, "(A)") call res_history%to_tree (res_tree) call res_tree%write (u) write (u, "(A)") write (u, "(A)") "* Nested resonances" write (u, "(A)") call res_info%init (7, 23, model, 5) call res_history%add_resonance (res_info) call res_history%write (u) write (u, "(A)") call res_history%to_tree (res_tree) call res_tree%write (u) write (u, "(A)") write (u, "(A)") "* Disjunct resonances" write (u, "(A)") call res_history%clear () call res_info%init (5, 24, model, 7) call res_history%add_resonance (res_info) call res_info%init (7, 6, model, 7) call res_history%add_resonance (res_info) call res_info%init (80, -24, model, 7) call res_history%add_resonance (res_info) call res_info%init (112, -6, model, 7) call res_history%add_resonance (res_info) call res_history%write (u) write (u, "(A)") call res_history%to_tree (res_tree) call res_tree%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: resonances_6" end subroutine resonances_6 @ %def resonances_6 @ Basic operations on a resonance history set. <>= call test (resonances_7, "resonances_7", & "display tree format of history set elements", & u, results) <>= public :: resonances_7 <>= subroutine resonances_7 (u) integer, intent(in) :: u type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(resonance_tree_t) :: res_tree type(resonance_history_set_t) :: res_set type(model_data_t), target :: model type(flavor_t) :: flv write (u, "(A)") "* Test output: resonances_7" write (u, "(A)") "* Purpose: test tree format" write (u, "(A)") write (u, "(A)") "* Read model file" call model%init_sm_test () write (u, "(A)") write (u, "(A)") "* Initialize, fill and freeze resonance history set" write (u, "(A)") call res_set%init (initial_size = 2) call res_info%init (3, -24, model, 5) call res_history%add_resonance (res_info) call res_history%clear () call res_info%init (3, -24, model, 5) call res_history%add_resonance (res_info) call res_info%init (7, 23, model, 5) call res_history%add_resonance (res_info) call res_set%enter (res_history) call res_history%clear () call res_info%init (7, 23, model, 5) call res_history%add_resonance (res_info) call res_set%enter (res_history) call res_history%clear () call res_info%init (3, -24, model, 5) call res_history%add_resonance (res_info) call res_set%enter (res_history) call res_history%clear () call res_info%init (3, -24, model, 5) call res_history%add_resonance (res_info) call res_info%init (7, 25, model, 5) call res_history%add_resonance (res_info) call res_set%enter (res_history) call res_history%clear () call res_set%freeze () call res_set%write (u, show_trees = .true.) write (u, "(A)") write (u, "(A)") "* Extract tree #1" write (u, "(A)") call res_set%get_tree (1, res_tree) call res_tree%write (u) write (u, *) write (u, "(1x,A,1x,I0)") "n_resonances =", res_tree%get_n_resonances () write (u, *) write (u, "(1x,A,1x)", advance="no") "flv(r1) =" flv = res_tree%get_flv (1) call flv%write (u) write (u, *) write (u, "(1x,A,1x)", advance="no") "flv(r2) =" flv = res_tree%get_flv (2) call flv%write (u) write (u, *) write (u, *) write (u, "(1x,A)") "[offset = 2, 4]" write (u, "(1x,A,9(1x,I0))") "children(r1) =", & res_tree%get_children(1, 2, 4) write (u, "(1x,A,9(1x,I0))") "children(r2) =", & res_tree%get_children(2, 2, 4) write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: resonances_7" end subroutine resonances_7 @ %def resonances_7 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \clearpage \section{Mappings} Mappings are objects that encode the transformation of the interval $(0,1)$ to a physical variable $m^2$ or $\cos\theta$ (and back), as it is used in the phase space parameterization. The mapping objects contain fixed parameters, the associated methods implement the mapping and inverse mapping operations, including the computation of the Jacobian (phase space factor). <<[[mappings.f90]]>>= <> module mappings <> use kinds, only: TC <> - use io_units - use constants, only: pi - use format_defs, only: FMT_19 - use diagnostics - use md5 use model_data use flavors <> <> <> <> <> + interface +<> + end interface + +end module mappings +@ %def mappings +@ +<<[[mappings_sub.f90]]>>= +<> + +submodule (mappings) mappings_s + + use io_units + use constants, only: pi + use format_defs, only: FMT_19 + use diagnostics + use md5 + + implicit none + contains <> -end module mappings -@ %def mappings +end submodule mappings_s + +@ %def mappings_s @ \subsection{Default parameters} This type holds the default parameters, needed for setting the scale in cases where no mass parameter is available. The contents are public. <>= public :: mapping_defaults_t <>= type :: mapping_defaults_t real(default) :: energy_scale = 10 real(default) :: invariant_mass_scale = 10 real(default) :: momentum_transfer_scale = 10 logical :: step_mapping = .true. logical :: step_mapping_exp = .true. logical :: enable_s_mapping = .false. contains <> end type mapping_defaults_t @ %def mapping_defaults_t @ Output. <>= procedure :: write => mapping_defaults_write +<>= + module subroutine mapping_defaults_write (object, unit) + class(mapping_defaults_t), intent(in) :: object + integer, intent(in), optional :: unit + end subroutine mapping_defaults_write <>= - subroutine mapping_defaults_write (object, unit) + module subroutine mapping_defaults_write (object, unit) class(mapping_defaults_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(3x,A," // FMT_19 // ")") "energy scale = ", & object%energy_scale write (u, "(3x,A," // FMT_19 // ")") "mass scale = ", & object%invariant_mass_scale write (u, "(3x,A," // FMT_19 // ")") "q scale = ", & object%momentum_transfer_scale write (u, "(3x,A,L1)") "step mapping = ", & object%step_mapping write (u, "(3x,A,L1)") "step exp. mode = ", & object%step_mapping_exp write (u, "(3x,A,L1)") "allow s mapping = ", & object%enable_s_mapping end subroutine mapping_defaults_write @ %def mapping_defaults_write @ <>= public :: mapping_defaults_md5sum +<>= + module function mapping_defaults_md5sum & + (mapping_defaults) result (md5sum_map) + character(32) :: md5sum_map + type(mapping_defaults_t), intent(in) :: mapping_defaults + end function mapping_defaults_md5sum <>= - function mapping_defaults_md5sum (mapping_defaults) result (md5sum_map) + module function mapping_defaults_md5sum & + (mapping_defaults) result (md5sum_map) character(32) :: md5sum_map type(mapping_defaults_t), intent(in) :: mapping_defaults integer :: u u = free_unit () open (u, status = "scratch") write (u, *) mapping_defaults%energy_scale write (u, *) mapping_defaults%invariant_mass_scale write (u, *) mapping_defaults%momentum_transfer_scale write (u, *) mapping_defaults%step_mapping write (u, *) mapping_defaults%step_mapping_exp write (u, *) mapping_defaults%enable_s_mapping rewind (u) md5sum_map = md5sum (u) close (u) end function mapping_defaults_md5sum @ %def mapping_defaults_md5sum @ \subsection{The Mapping type} Each mapping has a type (e.g., s-channel, infrared), a binary code (redundant, but useful for debugging), and a reference particle. The flavor code of this particle is stored for bookkeeping reasons, what matters are the mass and width of this particle. Furthermore, depending on the type, various mapping parameters can be set and used. The parameters [[a1]] to [[a3]] (for $m^2$ mappings) and [[b1]] to [[b3]] (for $\cos\theta$ mappings) are values that are stored once to speed up the calculation, if [[variable_limits]] is false. The exact meaning of these parameters depends on the mapping type. The limits are fixed if there is a fixed c.m. energy. <>= public :: mapping_t <>= type :: mapping_t private integer :: type = NO_MAPPING integer(TC) :: bincode type(flavor_t) :: flv real(default) :: mass = 0 real(default) :: width = 0 logical :: a_unknown = .true. real(default) :: a1 = 0 real(default) :: a2 = 0 real(default) :: a3 = 0 logical :: b_unknown = .true. real(default) :: b1 = 0 real(default) :: b2 = 0 real(default) :: b3 = 0 logical :: variable_limits = .true. contains <> end type mapping_t @ %def mapping_t @ The valid mapping types. The extra type [[STEP_MAPPING]] is used only internally. <>= <> @ \subsection{Screen output} Do not write empty mappings. -<>= - public :: mapping_write +<>= + procedure :: write => mapping_write +<>= + module subroutine mapping_write (map, unit, verbose) + class(mapping_t), intent(in) :: map + integer, intent(in), optional :: unit + logical, intent(in), optional :: verbose + end subroutine mapping_write <>= - subroutine mapping_write (map, unit, verbose) - type(mapping_t), intent(in) :: map + module subroutine mapping_write (map, unit, verbose) + class(mapping_t), intent(in) :: map integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u character(len=9) :: str u = given_output_unit (unit); if (u < 0) return select case(map%type) case(S_CHANNEL); str = "s_channel" case(COLLINEAR); str = "collinear" case(INFRARED); str = "infrared " case(RADIATION); str = "radiation" case(T_CHANNEL); str = "t_channel" case(U_CHANNEL); str = "u_channel" case(STEP_MAPPING_E); str = "step_exp" case(STEP_MAPPING_H); str = "step_hyp" case(ON_SHELL); str = "on_shell" case default; str = "????????" end select if (map%type /= NO_MAPPING) then write (u, '(1x,A,I4,A)') & "Branch #", map%bincode, ": " // & "Mapping (" // str // ") for particle " // & '"' // char (map%flv%get_name ()) // '"' if (present (verbose)) then if (verbose) then select case (map%type) case (S_CHANNEL, RADIATION, STEP_MAPPING_E, STEP_MAPPING_H) write (u, "(1x,A,3(" // FMT_19 // "))") & " m/w = ", map%mass, map%width case default write (u, "(1x,A,3(" // FMT_19 // "))") & " m = ", map%mass end select select case (map%type) case (S_CHANNEL, T_CHANNEL, U_CHANNEL, & STEP_MAPPING_E, STEP_MAPPING_H, & COLLINEAR, INFRARED, RADIATION) write (u, "(1x,A,3(" // FMT_19 // "))") & " a1/2/3 = ", map%a1, map%a2, map%a3 end select select case (map%type) case (T_CHANNEL, U_CHANNEL, COLLINEAR) write (u, "(1x,A,3(" // FMT_19 // "))") & " b1/2/3 = ", map%b1, map%b2, map%b3 end select end if end if end if end subroutine mapping_write @ %def mapping_write @ \subsection{Define a mapping} The initialization routine sets the mapping type and the particle (binary code and flavor code) for which the mapping applies (e.g., a $Z$ resonance in branch \#3). -<>= - public :: mapping_init +<>= + procedure :: init => mapping_init +<>= + module subroutine mapping_init (mapping, bincode, type, f, model) + class(mapping_t), intent(inout) :: mapping + integer(TC), intent(in) :: bincode + type(string_t), intent(in) :: type + integer, intent(in), optional :: f + class(model_data_t), intent(in), optional, target :: model + end subroutine mapping_init <>= - subroutine mapping_init (mapping, bincode, type, f, model) - type(mapping_t), intent(inout) :: mapping + module subroutine mapping_init (mapping, bincode, type, f, model) + class(mapping_t), intent(inout) :: mapping integer(TC), intent(in) :: bincode type(string_t), intent(in) :: type integer, intent(in), optional :: f class(model_data_t), intent(in), optional, target :: model mapping%bincode = bincode select case (char (type)) case ("s_channel"); mapping%type = S_CHANNEL case ("collinear"); mapping%type = COLLINEAR case ("infrared"); mapping%type = INFRARED case ("radiation"); mapping%type = RADIATION case ("t_channel"); mapping%type = T_CHANNEL case ("u_channel"); mapping%type = U_CHANNEL case ("step_exp"); mapping%type = STEP_MAPPING_E case ("step_hyp"); mapping%type = STEP_MAPPING_H case ("on_shell"); mapping%type = ON_SHELL case default call msg_bug ("Mappings: encountered undefined mapping key '" & // char (type) // "'") end select if (present (f) .and. present (model)) call mapping%flv%init (f, model) end subroutine mapping_init @ %def mapping_init @ This sets the actual mass and width, using a parameter set. Since the auxiliary parameters will only be determined when the mapping is first called, they are marked as unknown. -<>= - public :: mapping_set_parameters +<>= + procedure :: set_parameters => mapping_set_parameters +<>= + module subroutine mapping_set_parameters & + (map, mapping_defaults, variable_limits) + class(mapping_t), intent(inout) :: map + type(mapping_defaults_t), intent(in) :: mapping_defaults + logical, intent(in) :: variable_limits + end subroutine mapping_set_parameters <>= - subroutine mapping_set_parameters (map, mapping_defaults, variable_limits) - type(mapping_t), intent(inout) :: map + module subroutine mapping_set_parameters & + (map, mapping_defaults, variable_limits) + class(mapping_t), intent(inout) :: map type(mapping_defaults_t), intent(in) :: mapping_defaults logical, intent(in) :: variable_limits if (map%type /= NO_MAPPING) then map%mass = map%flv%get_mass () map%width = map%flv%get_width () map%variable_limits = variable_limits map%a_unknown = .true. map%b_unknown = .true. select case (map%type) case (S_CHANNEL) if (map%mass <= 0) then - call mapping_write (map) + call map%write () call msg_fatal & & (" S-channel resonance must have positive mass") else if (map%width <= 0) then - call mapping_write (map) + call map%write () call msg_fatal & & (" S-channel resonance must have positive width") end if case (RADIATION) map%width = max (map%width, mapping_defaults%energy_scale) case (INFRARED, COLLINEAR) map%mass = max (map%mass, mapping_defaults%invariant_mass_scale) case (T_CHANNEL, U_CHANNEL) map%mass = max (map%mass, mapping_defaults%momentum_transfer_scale) end select end if end subroutine mapping_set_parameters @ %def mapping_set_code mapping_set_parameters @ For a step mapping the mass and width are set directly, instead of being determined from the flavor parameter (which is meaningless here). They correspond to the effective upper bound of phase space due to a resonance, as opposed to the absolute upper bound. -<>= - public :: mapping_set_step_mapping_parameters +<>= + procedure :: set_step_mapping_parameters => & + mapping_set_step_mapping_parameters +<>= + module subroutine mapping_set_step_mapping_parameters (map, & + mass, width, variable_limits) + class(mapping_t), intent(inout) :: map + real(default), intent(in) :: mass, width + logical, intent(in) :: variable_limits + end subroutine mapping_set_step_mapping_parameters <>= - subroutine mapping_set_step_mapping_parameters (map, & + module subroutine mapping_set_step_mapping_parameters (map, & mass, width, variable_limits) - type(mapping_t), intent(inout) :: map + class(mapping_t), intent(inout) :: map real(default), intent(in) :: mass, width logical, intent(in) :: variable_limits select case (map%type) case (STEP_MAPPING_E, STEP_MAPPING_H) map%variable_limits = variable_limits map%a_unknown = .true. map%b_unknown = .true. map%mass = mass map%width = width end select end subroutine mapping_set_step_mapping_parameters @ %def mapping_set_step_mapping_parameters @ \subsection{Retrieve contents} Return true if there is any / an s-channel mapping. -<>= - public :: mapping_is_set - public :: mapping_is_s_channel - public :: mapping_is_on_shell <>= procedure :: is_set => mapping_is_set procedure :: is_s_channel => mapping_is_s_channel procedure :: is_on_shell => mapping_is_on_shell +<>= + module function mapping_is_set (mapping) result (flag) + class(mapping_t), intent(in) :: mapping + logical :: flag + end function mapping_is_set + module function mapping_is_s_channel (mapping) result (flag) + class(mapping_t), intent(in) :: mapping + logical :: flag + end function mapping_is_s_channel + module function mapping_is_on_shell (mapping) result (flag) + class(mapping_t), intent(in) :: mapping + logical :: flag + end function mapping_is_on_shell <>= - function mapping_is_set (mapping) result (flag) + module function mapping_is_set (mapping) result (flag) class(mapping_t), intent(in) :: mapping logical :: flag flag = mapping%type /= NO_MAPPING end function mapping_is_set - function mapping_is_s_channel (mapping) result (flag) + module function mapping_is_s_channel (mapping) result (flag) class(mapping_t), intent(in) :: mapping logical :: flag flag = mapping%type == S_CHANNEL end function mapping_is_s_channel - function mapping_is_on_shell (mapping) result (flag) + module function mapping_is_on_shell (mapping) result (flag) class(mapping_t), intent(in) :: mapping logical :: flag flag = mapping%type == ON_SHELL end function mapping_is_on_shell @ %def mapping_is_set @ %def mapping_is_s_channel @ %def mapping_is_on_shell @ Return the binary code for the mapped particle. <>= procedure :: get_bincode => mapping_get_bincode +<>= + module function mapping_get_bincode (mapping) result (bincode) + class(mapping_t), intent(in) :: mapping + integer(TC) :: bincode + end function mapping_get_bincode <>= - function mapping_get_bincode (mapping) result (bincode) + module function mapping_get_bincode (mapping) result (bincode) class(mapping_t), intent(in) :: mapping integer(TC) :: bincode bincode = mapping%bincode end function mapping_get_bincode @ %def mapping_get_bincode @ Return the flavor object for the mapped particle. <>= procedure :: get_flv => mapping_get_flv +<>= + module function mapping_get_flv (mapping) result (flv) + class(mapping_t), intent(in) :: mapping + type(flavor_t) :: flv + end function mapping_get_flv <>= - function mapping_get_flv (mapping) result (flv) + module function mapping_get_flv (mapping) result (flv) class(mapping_t), intent(in) :: mapping type(flavor_t) :: flv flv = mapping%flv end function mapping_get_flv @ %def mapping_get_flv @ Return stored mass and width, respectively. -<>= - public :: mapping_get_mass - public :: mapping_get_width +<>= + procedure :: get_mass => mapping_get_mass + procedure :: get_width => mapping_get_width +<>= + module function mapping_get_mass (mapping) result (mass) + class(mapping_t), intent(in) :: mapping + real(default) :: mass + end function mapping_get_mass + module function mapping_get_width (mapping) result (width) + class(mapping_t), intent(in) :: mapping + real(default) :: width + end function mapping_get_width <>= - function mapping_get_mass (mapping) result (mass) + module function mapping_get_mass (mapping) result (mass) + class(mapping_t), intent(in) :: mapping real(default) :: mass - type(mapping_t), intent(in) :: mapping mass = mapping%mass end function mapping_get_mass - function mapping_get_width (mapping) result (width) + module function mapping_get_width (mapping) result (width) + class(mapping_t), intent(in) :: mapping real(default) :: width - type(mapping_t), intent(in) :: mapping width = mapping%width end function mapping_get_width @ %def mapping_get_mass @ %def mapping_get_width @ \subsection{Compare mappings} Equality for single mappings and arrays <>= public :: operator(==) <>= interface operator(==) module procedure mapping_equal end interface +<>= + module function mapping_equal (m1, m2) result (equal) + type(mapping_t), intent(in) :: m1, m2 + logical :: equal + end function mapping_equal <>= - function mapping_equal (m1, m2) result (equal) + module function mapping_equal (m1, m2) result (equal) type(mapping_t), intent(in) :: m1, m2 logical :: equal if (m1%type == m2%type) then select case (m1%type) case (NO_MAPPING) equal = .true. case (S_CHANNEL, RADIATION, STEP_MAPPING_E, STEP_MAPPING_H) equal = (m1%mass == m2%mass) .and. (m1%width == m2%width) case default equal = (m1%mass == m2%mass) end select else equal = .false. end if end function mapping_equal @ %def mapping_equal @ \subsection{Mappings of the invariant mass} Inserting an $x$ value between 0 and 1, we want to compute the corresponding invariant mass $m^2(x)$ and the jacobian, aka phase space factor $f(x)$. We also need the reverse operation. In general, the phase space factor $f$ is defined by \begin{equation} \frac{1}{s}\int_{m^2_{\textrm{min}}}^{m^2_{\textrm{max}}} dm^2\,g(m^2) = \int_0^1 dx\,\frac{1}{s}\,\frac{dm^2}{dx}\,g(m^2(x)) = \int_0^1 dx\,f(x)\,g(x), \end{equation} where thus \begin{equation} f(x) = \frac{1}{s}\,\frac{dm^2}{dx}. \end{equation} With this mapping, a function of the form \begin{equation} g(m^2) = c\frac{dx(m^2)}{dm^2} \end{equation} is mapped to a constant: \begin{equation} \frac{1}{s}\int_{m^2_{\textrm{min}}}^{m^2_{\textrm{max}}} dm^2\,g(m^2) = \int_0^1 dx\,f(x)\,g(m^2(x)) = \int_0^1 dx\,\frac{c}{s}. \end{equation} Here is the mapping routine. Input are the available energy squared [[s]], the limits for $m^2$, and the $x$ value. Output are the $m^2$ value and the phase space factor $f$. -<>= - public :: mapping_compute_msq_from_x +<>= + procedure :: compute_msq_from_x => mapping_compute_msq_from_x +<>= + module subroutine mapping_compute_msq_from_x & + (map, s, msq_min, msq_max, msq, f, x) + class(mapping_t), intent(inout) :: map + real(default), intent(in) :: s, msq_min, msq_max + real(default), intent(out) :: msq, f + real(default), intent(in) :: x + end subroutine mapping_compute_msq_from_x <>= - subroutine mapping_compute_msq_from_x (map, s, msq_min, msq_max, msq, f, x) - type(mapping_t), intent(inout) :: map + module subroutine mapping_compute_msq_from_x & + (map, s, msq_min, msq_max, msq, f, x) + class(mapping_t), intent(inout) :: map real(default), intent(in) :: s, msq_min, msq_max real(default), intent(out) :: msq, f real(default), intent(in) :: x real(default) :: z, msq0, msq1, tmp integer :: type type = map%type if (s == 0) & call msg_fatal (" Applying msq mapping for zero energy") <> select case(type) case (NO_MAPPING) <> <> case (S_CHANNEL) <> <> case (COLLINEAR, INFRARED, RADIATION) <> <> case (T_CHANNEL, U_CHANNEL) <> <> case (STEP_MAPPING_E) <> <> case (STEP_MAPPING_H) <> <> case default call msg_fatal ( " Attempt to apply undefined msq mapping") end select end subroutine mapping_compute_msq_from_x @ %def mapping_compute_msq_from_x @ The inverse mapping -<>= - public :: mapping_compute_x_from_msq +<>= + procedure :: compute_x_from_msq => mapping_compute_x_from_msq +<>= + module subroutine mapping_compute_x_from_msq & + (map, s, msq_min, msq_max, msq, f, x) + class(mapping_t), intent(inout) :: map + real(default), intent(in) :: s, msq_min, msq_max + real(default), intent(in) :: msq + real(default), intent(out) :: f, x + end subroutine mapping_compute_x_from_msq <>= - subroutine mapping_compute_x_from_msq (map, s, msq_min, msq_max, msq, f, x) - type(mapping_t), intent(inout) :: map + module subroutine mapping_compute_x_from_msq & + (map, s, msq_min, msq_max, msq, f, x) + class(mapping_t), intent(inout) :: map real(default), intent(in) :: s, msq_min, msq_max real(default), intent(in) :: msq real(default), intent(out) :: f, x real(default) :: msq0, msq1, tmp, z integer :: type type = map%type if (s == 0) & call msg_fatal (" Applying inverse msq mapping for zero energy") <> select case (type) case (NO_MAPPING) <> <> case (S_CHANNEL) <> <> case (COLLINEAR, INFRARED, RADIATION) <> <> case (T_CHANNEL, U_CHANNEL) <> <> case (STEP_MAPPING_E) <> <> case (STEP_MAPPING_H) <> <> case default call msg_fatal ( " Attempt to apply undefined msq mapping") end select end subroutine mapping_compute_x_from_msq @ %def mapping_compute_x_from_msq @ \subsubsection{Trivial mapping} We simply map the boundaries of the interval $(m_{\textrm{min}}, m_{\textrm{max}})$ to $(0,1)$: \begin{equation} m^2 = (1-x) m_{\textrm{min}}^2 + x m_{\textrm{max}}^2; \end{equation} the inverse is \begin{equation} x = \frac{m^2 - m_{\textrm{min}}^2}{m_{\textrm{max}}^2- m_{\textrm{min}}^2}. \end{equation} Hence \begin{equation} f(x) = \frac{m_{\textrm{max}}^2 - m_{\textrm{min}}^2}{s}, \end{equation} and we have, as required, \begin{equation} f(x)\,\frac{dx}{dm^2} = \frac{1}{s}. \end{equation} We store the constant parameters the first time the mapping is called -- or, if limits vary, recompute them each time. <>= if (map%variable_limits .or. map%a_unknown) then map%a1 = 0 map%a2 = msq_max - msq_min map%a3 = map%a2 / s map%a_unknown = .false. end if <>= msq = (1-x) * msq_min + x * msq_max f = map%a3 <>= if (map%a2 /= 0) then x = (msq - msq_min) / map%a2 else x = 0 end if f = map%a3 @ Resonance or step mapping does not make much sense if the resonance mass is outside the kinematical bounds. If this is the case, revert to [[NO_MAPPING]]. This is possible even if the kinematical bounds vary from event to event. <>= select case (type) case (S_CHANNEL, STEP_MAPPING_E, STEP_MAPPING_H) msq0 = map%mass**2 if (msq0 < msq_min .or. msq0 > msq_max) type = NO_MAPPING end select @ \subsubsection{Breit-Wigner mapping} A Breit-Wigner resonance with mass $M$ and width $\Gamma$ is flattened by the following mapping: This mapping does not make much sense if the resonance mass is too low. If this is the case, revert to [[NO_MAPPING]]. There is a tricky point with this if the mass is too high: [[msq_max]] is not a constant if structure functions are around. However, switching the type depending on the overall energy does not change the integral, it is just another branching point. \begin{equation} m^2 = M(M+t\Gamma), \end{equation} where \begin{equation} t = \tan\left[(1-x)\arctan\frac{m^2_{\textrm{min}} - M^2}{M\Gamma} + x \arctan\frac{m^2_{\textrm{max}} - M^2}{M\Gamma}\right]. \end{equation} The inverse: \begin{equation} x = \frac{ \arctan\frac{m^2 - M^2}{M\Gamma} - \arctan\frac{m^2_{\textrm{min}} - M^2}{M\Gamma}} { \arctan\frac{m^2_{\textrm{max}} - M^2}{M\Gamma} - \arctan\frac{m^2_{\textrm{min}} - M^2}{M\Gamma}} \end{equation} The phase-space factor of this transformation is \begin{equation} f(x) = \frac{M\Gamma}{s}\left( \arctan\frac{m^2_{\textrm{max}} - M^2}{M\Gamma} - \arctan\frac{m^2_{\textrm{min}} - M^2}{M\Gamma}\right) (1 + t^2). \end{equation} This maps any function proportional to \begin{equation} g(m^2) = \frac{M\Gamma}{(m^2-M^2)^2 + M^2\Gamma^2} \end{equation} to a constant times $1/s$. <>= if (map%variable_limits .or. map%a_unknown) then msq0 = map%mass ** 2 map%a1 = atan ((msq_min - msq0) / (map%mass * map%width)) map%a2 = atan ((msq_max - msq0) / (map%mass * map%width)) map%a3 = (map%a2 - map%a1) * (map%mass * map%width) / s map%a_unknown = .false. end if <>= z = (1-x) * map%a1 + x * map%a2 if (-pi/2 < z .and. z < pi/2) then tmp = tan (z) msq = map%mass * (map%mass + map%width * tmp) f = map%a3 * (1 + tmp**2) else msq = 0 f = 0 end if <>= tmp = (msq - msq0) / (map%mass * map%width) x = (atan (tmp) - map%a1) / (map%a2 - map%a1) f = map%a3 * (1 + tmp**2) @ \subsubsection{Mapping for massless splittings} This mapping accounts for approximately scale-invariant behavior where $\ln M^2$ is evenly distributed. \begin{equation} m^2 = m_{\textrm{min}}^2 + M^2\left(\exp(xL)-1\right) \end{equation} where \begin{equation} L = \ln\left(\frac{m_{\textrm{max}}^2 - m_{\textrm{min}}^2}{M^2} + 1\right). \end{equation} The inverse: \begin{equation} x = \frac1L\ln\left(\frac{m^2-m_{\textrm{min}}^2}{M^2} + 1\right) \end{equation} The constant $M$ is a characteristic scale. Above this scale ($m^2-m_{\textrm{min}}^2 \gg M^2$), this mapping behaves like $x\propto\ln m^2$, while below the scale it reverts to a linear mapping. The phase-space factor is \begin{equation} f(x) = \frac{M^2}{s}\,\exp(xL)\,L. \end{equation} A function proportional to \begin{equation} g(m^2) = \frac{1}{(m^2-m_{\textrm{min}}^2) + M^2} \end{equation} is mapped to a constant, i.e., a simple pole near $m_{\textrm{min}}$ with a regulator mass $M$. This type of mapping is useful for massless collinear and infrared singularities, where the scale is stored as the mass parameter. In the radiation case (IR radiation off massive particle), the heavy particle width is the characteristic scale. <>= if (map%variable_limits .or. map%a_unknown) then if (type == RADIATION) then msq0 = map%width**2 else msq0 = map%mass**2 end if map%a1 = msq0 map%a2 = log ((msq_max - msq_min) / msq0 + 1) map%a3 = map%a2 / s map%a_unknown = .false. end if <>= msq1 = map%a1 * exp (x * map%a2) msq = msq1 - map%a1 + msq_min f = map%a3 * msq1 <>= msq1 = msq - msq_min + map%a1 x = log (msq1 / map%a1) / map%a2 f = map%a3 * msq1 @ \subsubsection{Mapping for t-channel poles} This is also approximately scale-invariant, and we use the same type of mapping as before. However, we map $1/x$ singularities at both ends of the interval; again, the mapping becomes linear when the distance is less than $M^2$: \begin{equation} m^2 = \begin{cases} m_{\textrm{min}}^2 + M^2\left(\exp(xL)-1\right) & \text{for $0 < x < \frac12$} \\ m_{\textrm{max}}^2 - M^2\left(\exp((1-x)L)-1\right) & \text{for $\frac12 \leq x < 1$} \end{cases} \end{equation} where \begin{equation} L = 2\ln\left(\frac{m_{\textrm{max}}^2 - m_{\textrm{min}}^2}{2M^2} + 1\right). \end{equation} The inverse: \begin{equation} x = \begin{cases} \frac1L\ln\left(\frac{m^2-m_{\textrm{min}}^2}{M^2} + 1\right) & \text{for $m^2 < (m_{\textrm{max}}^2 - m_{\textrm{min}}^2)/2$} \\ 1 - \frac1L\ln\left(\frac{m_{\textrm{max}}-m^2}{M^2} + 1\right) & \text{for $m^2 \geq (m_{\textrm{max}}^2 - m_{\textrm{min}}^2)/2$} \end{cases} \end{equation} The phase-space factor is \begin{equation} f(x) = \begin{cases} \frac{M^2}{s}\,\exp(xL)\,L. & \text{for $0 < x < \frac12$} \\ \frac{M^2}{s}\,\exp((1-x)L)\,L. & \text{for $\frac12 \leq x < 1$} \end{cases} \end{equation} A (continuous) function proportional to \begin{equation} g(m^2) = \begin{cases} 1/(m^2-m_{\textrm{min}}^2) + M^2) & \text{for $m^2 < (m_{\textrm{max}}^2 - m_{\textrm{min}}^2)/2$} \\ 1/((m_{\textrm{max}}^2 - m^2) + M^2) & \text{for $m^2 \leq (m_{\textrm{max}}^2 - m_{\textrm{min}}^2)/2$} \end{cases} \end{equation} is mapped to a constant by this mapping, i.e., poles near both ends of the interval. <>= if (map%variable_limits .or. map%a_unknown) then msq0 = map%mass**2 map%a1 = msq0 map%a2 = 2 * log ((msq_max - msq_min)/(2*msq0) + 1) map%a3 = map%a2 / s map%a_unknown = .false. end if <>= if (x < .5_default) then msq1 = map%a1 * exp (x * map%a2) msq = msq1 - map%a1 + msq_min else msq1 = map%a1 * exp ((1-x) * map%a2) msq = -(msq1 - map%a1) + msq_max end if f = map%a3 * msq1 <>= if (msq < (msq_max + msq_min)/2) then msq1 = msq - msq_min + map%a1 x = log (msq1/map%a1) / map%a2 else msq1 = msq_max - msq + map%a1 x = 1 - log (msq1/map%a1) / map%a2 end if f = map%a3 * msq1 @ \subsection{Step mapping} Step mapping is useful when the allowed range for a squared-mass variable is large, but only a fraction at the lower end is populated because the particle in question is an (off-shell) decay product of a narrow resonance. I.e., if the resonance was forced to be on-shell, the upper end of the range would be the resonance mass, minus the effective (real or resonance) mass of the particle(s) in the sibling branch of the decay. The edge of this phase space section has a width which is determined by the width of the parent, plus the width of the sibling branch. (The widths might be added in quadrature, but this precision is probably not important.) \subsubsection{Fermi function} A possible mapping is derived from the Fermi function which has precisely this behavior. The Fermi function is given by \begin{equation} f(x) = \frac{1}{1 + \exp\frac{x-\mu}{\gamma}} \end{equation} where $x$ is taken as the invariant mass squared, $\mu$ is the invariant mass squared of the edge, and $\gamma$ is the effective width which is given by the widths of the parent and the sibling branch. (Widths might be added in quadrature, but we do not require this level of precision.) \begin{align} x &= \frac{m^2 - m_{\text{min}}^2}{\Delta m^2} \\ \mu &= \frac{m_{\text{max,eff}}^2 - m_{\text{min}}^2} {\Delta m^2} \\ \gamma &= \frac{2m_{\text{max,eff}}\Gamma}{\Delta m^2} \end{align} with \begin{equation} \Delta m^2 = m_{\text{max}}^2 - m_{\text{min}}^2 \end{equation} $m^2$ is thus given by \begin{equation} m^2(x) = xm_{\text{max}}^2 + (1-x)m_{\text{min}}^2 \end{equation} For the mapping, we compute the integral $g(x)$ of the Fermi function, normalized such that $g(0)=0$ and $g(1)=1$. We introduce the abbreviations \begin{align} \alpha &= 1 - \gamma\ln\frac{1 + \beta e^{1/\gamma}}{1 + \beta} \\ \beta &= e^{- \mu/\gamma} \end{align} and obtain \begin{equation} g(x) = \frac{1}{\alpha} \left(x - \gamma\ln\frac{1 + \beta e^{x/\gamma}} {1 + \beta}\right) \end{equation} The actual mapping is the inverse function $h(y) = g^{-1}(y)$, \begin{equation} h(y) = -\gamma\ln\left(e^{-\alpha y/\gamma}(1 + \beta) - \beta\right) \end{equation} The Jacobian is \begin{equation} \frac{dh}{dy} = \alpha\left(1 - e^{\alpha y/\gamma} \frac{\beta}{1 + \beta}\right)^{-1} \end{equation} which is equal to $1/(dg/dx)$, namely \begin{equation} \frac{dg}{dx} = \frac{1}{\alpha}\,\frac{1}{1 + \beta e^{x/\gamma}} \end{equation} The final result is \begin{align} \int_{m_{\text{min}}^2}^{m_{\text{max}}^2} dm^2\,F(m^2) &= \Delta m^2\int_0^1\,dx\,F(m^2(x)) \\ &= \Delta m^2\int_0^1\,dy\,F(m^2(h(y)))\,\frac{dh}{dy} \end{align} Here is the implementation. We fill [[a1]], [[a2]], [[a3]] with $\alpha,\beta,\gamma$, respectively. <>= if (map%variable_limits .or. map%a_unknown) then map%a3 = max (2 * map%mass * map%width / (msq_max - msq_min), 0.01_default) map%a2 = exp (- (map%mass**2 - msq_min) / (msq_max - msq_min) & / map%a3) map%a1 = 1 - map%a3 * log ((1 + map%a2 * exp (1 / map%a3)) / (1 + map%a2)) end if <>= tmp = exp (- x * map%a1 / map%a3) * (1 + map%a2) z = - map%a3 * log (tmp - map%a2) msq = z * msq_max + (1 - z) * msq_min f = map%a1 / (1 - map%a2 / tmp) * (msq_max - msq_min) / s <>= z = (msq - msq_min) / (msq_max - msq_min) tmp = 1 + map%a2 * exp (z / map%a3) x = (z - map%a3 * log (tmp / (1 + map%a2))) & / map%a1 f = map%a1 * tmp * (msq_max - msq_min) / s @ \subsubsection{Hyperbolic mapping} The Fermi function has the drawback that it decreases exponentially. It might be preferable to take a function with a power-law decrease, such that the high-mass region is not completely depopulated. Here, we start with the actual mapping which we take as \begin{equation} h(y) = \frac{b}{a-y} - \frac{b}{a} + \mu y \end{equation} with the abbreviation \begin{equation} a = \frac12\left(1 + \sqrt{1 + \frac{4b}{1-\mu}}\right) \end{equation} This is a hyperbola in the $xy$ plane. The derivative is \begin{equation} \frac{dh}{dy} = \frac{b}{(a-y)^2} + \mu \end{equation} The constants correspond to \begin{align} \mu &= \frac{m_{\text{max,eff}}^2 - m_{\text{min}}^2} {\Delta m^2} \\ b &= \frac{1}{\mu}\left(\frac{2m_{\text{max,eff}}\Gamma}{\Delta m^2}\right)^2 \end{align} The inverse function is the solution of a quadratic equation, \begin{equation} g(x) = \frac{1}{2} \left[\left(a + \frac{x}{\mu} + \frac{b}{a\mu}\right) - \sqrt{\left(a-\frac{x}{\mu}\right)^2 + 2\frac{b}{a\mu}\left(a + \frac{x}{\mu}\right) + \left(\frac{b}{a\mu}\right)^2}\right] \end{equation} The constants $a_{1,2,3}$ are identified with $a,b,\mu$. <>= if (map%variable_limits .or. map%a_unknown) then map%a3 = (map%mass**2 - msq_min) / (msq_max - msq_min) map%a2 = max ((2 * map%mass * map%width / (msq_max - msq_min))**2 & / map%a3, 1e-6_default) map%a1 = (1 + sqrt (1 + 4 * map%a2 / (1 - map%a3))) / 2 end if <>= z = map%a2 / (map%a1 - x) - map%a2 / map%a1 + map%a3 * x msq = z * msq_max + (1 - z) * msq_min f = (map%a2 / (map%a1 - x)**2 + map%a3) * (msq_max - msq_min) / s <>= z = (msq - msq_min) / (msq_max - msq_min) tmp = map%a2 / (map%a1 * map%a3) x = ((map%a1 + z / map%a3 + tmp) & - sqrt ((map%a1 - z / map%a3)**2 + 2 * tmp * (map%a1 + z / map%a3) & + tmp**2)) / 2 f = (map%a2 / (map%a1 - x)**2 + map%a3) * (msq_max - msq_min) / s @ \subsection{Mappings of the polar angle} The other type of singularity, a simple pole just outside the integration region, can occur in the integration over $\cos\theta$. This applies to exchange of massless (or light) particles. Double poles (Coulomb scattering) are also possible, but only in certain cases. These are also handled by the single-pole mapping. The mapping is analogous to the previous $m^2$ pole mapping, but with a different normalization and notation of variables: \begin{equation} \frac12\int_{-1}^1 d\cos\theta\,g(\theta) = \int_0^1 dx\,\frac{d\cos\theta}{dx}\,g(\theta(x)) = \int_0^1 dx\,f(x)\,g(x), \end{equation} where thus \begin{equation} f(x) = \frac12\,\frac{d\cos\theta}{dx}. \end{equation} With this mapping, a function of the form \begin{equation} g(\theta) = c\frac{dx(\cos\theta)}{d\cos\theta} \end{equation} is mapped to a constant: \begin{equation} \int_{-1}^1 d\cos\theta\,g(\theta) = \int_0^1 dx\,f(x)\,g(\theta(x)) = \int_0^1 dx\,c. \end{equation} -<>= - public :: mapping_compute_ct_from_x +<>= + procedure :: compute_ct_from_x => mapping_compute_ct_from_x +<>= + module subroutine mapping_compute_ct_from_x (map, s, ct, st, f, x) + class(mapping_t), intent(inout) :: map + real(default), intent(in) :: s + real(default), intent(out) :: ct, st, f + real(default), intent(in) :: x + end subroutine mapping_compute_ct_from_x <>= - subroutine mapping_compute_ct_from_x (map, s, ct, st, f, x) - type(mapping_t), intent(inout) :: map + module subroutine mapping_compute_ct_from_x (map, s, ct, st, f, x) + class(mapping_t), intent(inout) :: map real(default), intent(in) :: s real(default), intent(out) :: ct, st, f real(default), intent(in) :: x real(default) :: tmp, ct1 select case (map%type) case (NO_MAPPING, S_CHANNEL, INFRARED, RADIATION, & STEP_MAPPING_E, STEP_MAPPING_H) <> case (T_CHANNEL, U_CHANNEL, COLLINEAR) <> <> case default call msg_fatal (" Attempt to apply undefined ct mapping") end select end subroutine mapping_compute_ct_from_x @ %def mapping_compute_ct_from_x -<>= - public :: mapping_compute_x_from_ct +<>= + procedure :: compute_x_from_ct => mapping_compute_x_from_ct +<>= + module subroutine mapping_compute_x_from_ct (map, s, ct, f, x) + class(mapping_t), intent(inout) :: map + real(default), intent(in) :: s + real(default), intent(in) :: ct + real(default), intent(out) :: f, x + end subroutine mapping_compute_x_from_ct <>= - subroutine mapping_compute_x_from_ct (map, s, ct, f, x) - type(mapping_t), intent(inout) :: map + module subroutine mapping_compute_x_from_ct (map, s, ct, f, x) + class(mapping_t), intent(inout) :: map real(default), intent(in) :: s real(default), intent(in) :: ct real(default), intent(out) :: f, x real(default) :: ct1 select case (map%type) case (NO_MAPPING, S_CHANNEL, INFRARED, RADIATION, & STEP_MAPPING_E, STEP_MAPPING_H) <> case (T_CHANNEL, U_CHANNEL, COLLINEAR) <> <> case default call msg_fatal (" Attempt to apply undefined inverse ct mapping") end select end subroutine mapping_compute_x_from_ct @ %def mapping_compute_x_from_ct @ \subsubsection{Trivial mapping} This is just the mapping of the interval $(-1,1)$ to $(0,1)$: \begin{equation} \cos\theta = -1 + 2x \end{equation} and \begin{equation} f(x) = 1 \end{equation} with the inverse \begin{equation} x = \frac{1+\cos\theta}{2} \end{equation} <>= tmp = 2 * (1-x) ct = 1 - tmp st = sqrt (tmp * (2-tmp)) f = 1 <>= x = (ct + 1) / 2 f = 1 @ \subsubsection{Pole mapping} As above for $m^2$, we simultaneously map poles at both ends of the $\cos\theta$ interval. The formulae are completely analogous: \begin{equation} \cos\theta = \begin{cases} \frac{M^2}{s}\left[\exp(xL)-1\right] - 1 & \text{for $x<\frac12$} \\ -\frac{M^2}{s}\left[\exp((1-x)L)-1\right] + 1 & \text{for $x\geq\frac12$} \end{cases} \end{equation} where \begin{equation} L = 2\ln\frac{M^2+s}{M^2}. \end{equation} Inverse: \begin{equation} x = \begin{cases} \frac{1}{2L}\ln\frac{1 + \cos\theta + M^2/s}{M^2/s} & \text{for $\cos\theta < 0$} \\ 1 - \frac{1}{2L}\ln\frac{1 - \cos\theta + M^2/s}{M^2/s} & \text{for $\cos\theta \geq 0$} \end{cases} \end{equation} The phase-space factor: \begin{equation} f(x) = \begin{cases} \frac{M^2}{s}\exp(xL)\,L & \text{for $x<\frac12$} \\ \frac{M^2}{s}\exp((1-x)L)\,L & \text{for $x\geq\frac12$} \end{cases} \end{equation} <>= if (map%variable_limits .or. map%b_unknown) then map%b1 = map%mass**2 / s map%b2 = log ((map%b1 + 1) / map%b1) map%b3 = 0 map%b_unknown = .false. end if <>= if (x < .5_default) then ct1 = map%b1 * exp (2 * x * map%b2) ct = ct1 - map%b1 - 1 else ct1 = map%b1 * exp (2 * (1-x) * map%b2) ct = -(ct1 - map%b1) + 1 end if if (ct >= -1 .and. ct <= 1) then st = sqrt (1 - ct**2) f = ct1 * map%b2 else ct = 1; st = 0; f = 0 end if <>= if (ct < 0) then ct1 = ct + map%b1 + 1 x = log (ct1 / map%b1) / (2 * map%b2) else ct1 = -ct + map%b1 + 1 x = 1 - log (ct1 / map%b1) / (2 * map%b2) end if f = ct1 * map%b2 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \clearpage \section{Phase-space trees} The phase space evaluation is organized in terms of trees, where each branch corresponds to three integrations: $m^2$, $\cos\theta$, and $\phi$. The complete tree thus makes up a specific parameterization of the multidimensional phase-space integral. For the multi-channel integration, the phase-space tree is a single channel. The trees imply mappings of formal Feynman tree graphs into arrays of integer numbers: Each branch, corresponding to a particular line in the graph, is assigned an integer code $c$ (with kind value [[TC]] = tree code). In this integer, each bit determines whether a particular external momentum flows through the line. The external branches therefore have codes $1,2,4,8,\ldots$. An internal branch has those bits ORed corresponding to the momenta flowing through it. For example, a branch with momentum $p_1+p_4$ has code $2^0+2^3=1+8=9$. There is a two-fold ambiguity: Momentum conservation implies that the branch with code \begin{equation} c_0 = \sum_{i=1}^{n(\rm{ext})} 2^{i-1} \end{equation} i.e. the branch with momentum $p_1+p_2+\ldots p_n$ has momentum zero, which is equivalent to tree code $0$ by definition. Correspondingly, \begin{equation} c \quad\textrm{and}\quad c_0 - c = c\;\textrm{XOR}\;c_0 \end{equation} are equivalent. E.g., if there are five externals with codes $c=1,2,4,8,16$, then $c=9$ and $\bar c=31-9=22$ are equivalent. This ambiguity may be used to assign a direction to the line: If all momenta are understood as outgoing, $c=9$ in the example above means $p_1+p_4$, but $c=22$ means $p_2+p_3+p_5 = -(p_1+p_4)$. Here we make use of the ambiguity in a slightly different way. First, the initial particles are singled out as those externals with the highest bits, the IN-bits. (Here: $8$ and $16$ for a $2\to 3$ scattering process, $16$ only for a $1\to 4$ decay.) Then we invert those codes where all IN-bits are set. For a decay process this maps each tree of an equivalence class onto a unique representative (that one with the smallest integer codes). For a scattering process we proceed further: The ambiguity remains in all branches where only one IN-bit is set, including the initial particles. If there are only externals with this property, we have an $s$-channel graph which we leave as it is. In all other cases, an internal with only one IN-bit is a $t$-channel line, which for phase space integration should be associated with one of the initial momenta as a reference axis. We take that one whose bit is set in the current tree code. (E.g., for branch $c=9$ we use the initial particle $c=8$ as reference axis, whereas for the same branch we would take $c=16$ if it had been assigned $\bar c=31-9=22$ as tree code.) Thus, different ways of coding the same $t$-channel graph imply different phase space parameterizations. $s$-channel graphs have a unique parameterization. The same sets of parameterizations are used for $t$-channel graphs, except for the reference frames of their angular parts. We map each $t$-channel graph onto an $s$-channel graph as follows: Working in ascending order, for each $t$-channel line (whose code has exactly one IN-bit set) the attached initial line is flipped upstream, while the outgoing line is flipped downstream. (This works only if $t$-channel graphs are always parameterized beginning at their outer vertices, which we require as a restriction.) After all possible flips have been applied, we have an $s$-channel graph. We only have to remember the initial particle a vertex was originally attached to. <<[[phs_trees.f90]]>>= <> module phs_trees <> use kinds, only: TC <> - use io_units - use constants, only: twopi, twopi2, twopi5 - use format_defs, only: FMT_19 - use numeric_utils, only: vanishes - use diagnostics use lorentz use permutations, only: permutation_t, permutation_size use permutations, only: permutation_init, permutation_find use permutations, only: tc_decay_level, tc_permute use model_data use flavors use resonances, only: resonance_history_t, resonance_info_t use mappings <> <> <> + interface +<> + end interface + +end module phs_trees +@ %def phs_trees +@ +<<[[phs_trees_sub.f90]]>>= +<> + +submodule (phs_trees) phs_trees_s + + use io_units + use constants, only: twopi, twopi2, twopi5 + use format_defs, only: FMT_19 + use numeric_utils, only: vanishes + use diagnostics + + implicit none + contains <> -end module phs_trees -@ %def phs_trees +end submodule phs_trees_s + +@ %def phs_trees_s @ \subsection{Particles} We define a particle type which contains only four-momentum and invariant mass squared, and a flag that tells whether the momentum is filled or not. <>= public :: phs_prt_t <>= type :: phs_prt_t private logical :: defined = .false. type(vector4_t) :: p real(default) :: p2 + contains + <> end type phs_prt_t @ %def phs_prt_t @ Set contents: -<>= - public :: phs_prt_set_defined - public :: phs_prt_set_undefined - public :: phs_prt_set_momentum - public :: phs_prt_set_msq +<>= + procedure :: set_defined => phs_prt_set_defined + procedure :: set_undefined => phs_prt_set_undefined + procedure :: set_momentum => phs_prt_set_momentum + procedure :: set_msq => phs_prt_set_msq +<>= + elemental module subroutine phs_prt_set_defined (prt) + class(phs_prt_t), intent(inout) :: prt + end subroutine phs_prt_set_defined + elemental module subroutine phs_prt_set_undefined (prt) + class(phs_prt_t), intent(inout) :: prt + end subroutine phs_prt_set_undefined + elemental module subroutine phs_prt_set_momentum (prt, p) + class(phs_prt_t), intent(inout) :: prt + type(vector4_t), intent(in) :: p + end subroutine phs_prt_set_momentum + elemental module subroutine phs_prt_set_msq (prt, p2) + class(phs_prt_t), intent(inout) :: prt + real(default), intent(in) :: p2 + end subroutine phs_prt_set_msq <>= - elemental subroutine phs_prt_set_defined (prt) - type(phs_prt_t), intent(inout) :: prt + elemental module subroutine phs_prt_set_defined (prt) + class(phs_prt_t), intent(inout) :: prt prt%defined = .true. end subroutine phs_prt_set_defined - elemental subroutine phs_prt_set_undefined (prt) - type(phs_prt_t), intent(inout) :: prt + elemental module subroutine phs_prt_set_undefined (prt) + class(phs_prt_t), intent(inout) :: prt prt%defined = .false. end subroutine phs_prt_set_undefined - elemental subroutine phs_prt_set_momentum (prt, p) - type(phs_prt_t), intent(inout) :: prt + elemental module subroutine phs_prt_set_momentum (prt, p) + class(phs_prt_t), intent(inout) :: prt type(vector4_t), intent(in) :: p prt%p = p end subroutine phs_prt_set_momentum - elemental subroutine phs_prt_set_msq (prt, p2) - type(phs_prt_t), intent(inout) :: prt + elemental module subroutine phs_prt_set_msq (prt, p2) + class(phs_prt_t), intent(inout) :: prt real(default), intent(in) :: p2 prt%p2 = p2 end subroutine phs_prt_set_msq @ %def phs_prt_set_defined phs_prt_set_momentum phs_prt_set_msq @ Access methods: -<>= - public :: phs_prt_is_defined - public :: phs_prt_get_momentum - public :: phs_prt_get_msq +<>= + procedure :: is_defined => phs_prt_is_defined + procedure :: get_momentum => phs_prt_get_momentum + procedure :: get_msq => phs_prt_get_msq +<>= + elemental module function phs_prt_is_defined (prt) result (defined) + logical :: defined + class(phs_prt_t), intent(in) :: prt + end function phs_prt_is_defined + elemental module function phs_prt_get_momentum (prt) result (p) + type(vector4_t) :: p + class(phs_prt_t), intent(in) :: prt + end function phs_prt_get_momentum + elemental module function phs_prt_get_msq (prt) result (p2) + real(default) :: p2 + class(phs_prt_t), intent(in) :: prt + end function phs_prt_get_msq <>= - elemental function phs_prt_is_defined (prt) result (defined) + elemental module function phs_prt_is_defined (prt) result (defined) logical :: defined - type(phs_prt_t), intent(in) :: prt + class(phs_prt_t), intent(in) :: prt defined = prt%defined end function phs_prt_is_defined - elemental function phs_prt_get_momentum (prt) result (p) + elemental module function phs_prt_get_momentum (prt) result (p) type(vector4_t) :: p - type(phs_prt_t), intent(in) :: prt + class(phs_prt_t), intent(in) :: prt p = prt%p end function phs_prt_get_momentum - elemental function phs_prt_get_msq (prt) result (p2) + elemental module function phs_prt_get_msq (prt) result (p2) real(default) :: p2 - type(phs_prt_t), intent(in) :: prt + class(phs_prt_t), intent(in) :: prt p2 = prt%p2 end function phs_prt_get_msq @ %def phs_prt_is_defined phs_prt_get_momentum phs_prt_get_msq @ Addition of momenta (invariant mass square is computed). -<>= - public :: phs_prt_combine +<>= + procedure :: combine => phs_prt_combine +<>= + elemental module subroutine phs_prt_combine (prt, prt1, prt2) + class(phs_prt_t), intent(inout) :: prt + type(phs_prt_t), intent(in) :: prt1, prt2 + end subroutine phs_prt_combine <>= - elemental subroutine phs_prt_combine (prt, prt1, prt2) - type(phs_prt_t), intent(inout) :: prt + elemental module subroutine phs_prt_combine (prt, prt1, prt2) + class(phs_prt_t), intent(inout) :: prt type(phs_prt_t), intent(in) :: prt1, prt2 prt%defined = .true. prt%p = prt1%p + prt2%p prt%p2 = prt%p ** 2 call phs_prt_check (prt) end subroutine phs_prt_combine @ %def phs_prt_combine @ Output -<>= - public :: phs_prt_write +<>= + procedure :: write => phs_prt_write +<>= + module subroutine phs_prt_write (prt, unit) + class(phs_prt_t), intent(in) :: prt + integer, intent(in), optional :: unit + end subroutine phs_prt_write <>= - subroutine phs_prt_write (prt, unit) - type(phs_prt_t), intent(in) :: prt + module subroutine phs_prt_write (prt, unit) + class(phs_prt_t), intent(in) :: prt integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return if (prt%defined) then call vector4_write (prt%p, u) write (u, "(1x,A,1x," // FMT_19 // ")") "T = ", prt%p2 else write (u, "(3x,A)") "[undefined]" end if end subroutine phs_prt_write @ %def phs_prt_write -<>= - public :: phs_prt_check +<>= + procedure :: check => phs_prt_check +<>= + elemental module subroutine phs_prt_check (prt) + class(phs_prt_t), intent(inout) :: prt + end subroutine phs_prt_check <>= - elemental subroutine phs_prt_check (prt) - type(phs_prt_t), intent(inout) :: prt + elemental module subroutine phs_prt_check (prt) + class(phs_prt_t), intent(inout) :: prt if (prt%p2 < 0._default) then prt%p2 = 0._default end if end subroutine phs_prt_check @ %def phs_prt_check @ \subsection{The phase-space tree type} \subsubsection{Definition} In the concrete implementation, each branch $c$ may have two \emph{daughters} $c_1$ and $c_2$ such that $c_1+c_2=c$, a \emph{sibling} $c_s$ and a \emph{mother} $c_m$ such that $c+c_s = c_m$, and a \emph{friend} which is kept during flips, such that it can indicate a fixed reference frame. Absent entries are set $c=0$. First, declare the branch type. There is some need to have this public. Give initializations for all components, so no [[init]] routine is necessary. The branch has some information about the associated coordinates and about connections. <>= type :: phs_branch_t private logical :: set = .false. logical :: inverted_decay = .false. logical :: inverted_axis = .false. integer(TC) :: mother = 0 integer(TC) :: sibling = 0 integer(TC) :: friend = 0 integer(TC) :: origin = 0 integer(TC), dimension(2) :: daughter = 0 integer :: firstborn = 0 logical :: has_children = .false. logical :: has_friend = .false. logical :: is_real = .false. end type phs_branch_t @ %def phs_branch_t @ The tree type: No initialization, this is done by [[phs_tree_init]]. In addition to the branch array which The branches are collected in an array which holds all possible branches, of which only a few are set. After flips have been applied, the branch $c_M=\sum_{i=1}^{n({\rm fin})}2^{i-1}$ must be there, indicating the mother of all decay products. In addition, we should check for consistency at the beginning. [[n_branches]] is the number of those actually set. [[n_externals]] defines the number of significant bit, and [[mask]] is a code where all bits are set. Analogous: [[n_in]] and [[mask_in]] for the incoming particles. The [[mapping]] array contains the mappings associated to the branches (corresponding indices). The array [[mass_sum]] contains the sum of the real masses of the external final-state particles associated to the branch. During phase-space evaluation, this determines the boundaries. <>= public :: phs_tree_t <>= type :: phs_tree_t private integer :: n_branches, n_externals, n_in, n_msq, n_angles integer(TC) :: n_branches_tot, n_branches_out integer(TC) :: mask, mask_in, mask_out type(phs_branch_t), dimension(:), allocatable :: branch type(mapping_t), dimension(:), allocatable :: mapping real(default), dimension(:), allocatable :: mass_sum real(default), dimension(:), allocatable :: effective_mass real(default), dimension(:), allocatable :: effective_width logical :: real_phsp = .false. integer, dimension(:), allocatable :: momentum_link contains <> end type phs_tree_t @ %def phs_tree_t @ The maximum number of external particles that can be represented is related to the bit size of the integer that stores binary codes. With the default integer of 32 bit on common machines, this is more than enough space. If [[TC]] is actually the default integer kind, there is no need to keep it separate, but doing so marks this as a special type of integer. So, just state that the maximum number is 32: <>= integer, parameter, public :: MAX_EXTERNAL = 32 @ %def MAX_EXTERNAL @ \subsubsection{Constructor and destructor} Allocate memory for a phase-space tree with given number of externals and incoming. The number of allocated branches can easily become large, but appears manageable for realistic cases, e.g., for [[n_in=2]] and [[n_out=8]] we get $2^{10}-1=1023$. -<>= - public :: phs_tree_init - public :: phs_tree_final -@ Here we set the masks for incoming and for all externals. +Here we set the masks for incoming and for all externals. <>= procedure :: init => phs_tree_init procedure :: final => phs_tree_final +<>= + elemental module subroutine phs_tree_init & + (tree, n_in, n_out, n_masses, n_angles) + class(phs_tree_t), intent(inout) :: tree + integer, intent(in) :: n_in, n_out, n_masses, n_angles + end subroutine phs_tree_init + elemental module subroutine phs_tree_final (tree) + class(phs_tree_t), intent(inout) :: tree + end subroutine phs_tree_final <>= - elemental subroutine phs_tree_init (tree, n_in, n_out, n_masses, n_angles) + elemental module subroutine phs_tree_init & + (tree, n_in, n_out, n_masses, n_angles) class(phs_tree_t), intent(inout) :: tree integer, intent(in) :: n_in, n_out, n_masses, n_angles integer(TC) :: i tree%n_externals = n_in + n_out tree%n_branches_tot = 2**(n_in+n_out) - 1 tree%n_branches_out = 2**n_out - 1 tree%mask = 0 do i = 0, n_in + n_out - 1 tree%mask = ibset (tree%mask, i) end do tree%n_in = n_in tree%mask_in = 0 do i = n_out, n_in + n_out - 1 tree%mask_in = ibset (tree%mask_in, i) end do tree%mask_out = ieor (tree%mask, tree%mask_in) tree%n_msq = n_masses tree%n_angles = n_angles allocate (tree%branch (tree%n_branches_tot)) tree%n_branches = 0 allocate (tree%mapping (tree%n_branches_out)) allocate (tree%mass_sum (tree%n_branches_out)) allocate (tree%effective_mass (tree%n_branches_out)) allocate (tree%effective_width (tree%n_branches_out)) end subroutine phs_tree_init - elemental subroutine phs_tree_final (tree) + elemental module subroutine phs_tree_final (tree) class(phs_tree_t), intent(inout) :: tree deallocate (tree%branch) deallocate (tree%mapping) deallocate (tree%mass_sum) deallocate (tree%effective_mass) deallocate (tree%effective_width) end subroutine phs_tree_final @ %def phs_tree_init phs_tree_final @ \subsubsection{Screen output} Write only the branches that are set: -<>= - public :: phs_tree_write <>= procedure :: write => phs_tree_write +<>= + module subroutine phs_tree_write (tree, unit) + class(phs_tree_t), intent(in) :: tree + integer, intent(in), optional :: unit + end subroutine phs_tree_write <>= - subroutine phs_tree_write (tree, unit) + module subroutine phs_tree_write (tree, unit) class(phs_tree_t), intent(in) :: tree integer, intent(in), optional :: unit integer :: u integer(TC) :: k u = given_output_unit (unit); if (u < 0) return write (u, '(3X,A,1x,I0,5X,A,I3)') & 'External:', tree%n_externals, 'Mask:', tree%mask write (u, '(3X,A,1x,I0,5X,A,I3)') & 'Incoming:', tree%n_in, 'Mask:', tree%mask_in write (u, '(3X,A,1x,I0,5X,A,I3)') & 'Branches:', tree%n_branches do k = size (tree%branch), 1, -1 if (tree%branch(k)%set) & call phs_branch_write (tree%branch(k), unit=unit, kval=k) end do do k = 1, size (tree%mapping) - call mapping_write (tree%mapping (k), unit, verbose=.true.) + call tree%mapping (k)%write (unit, verbose=.true.) end do write (u, "(3x,A)") "Arrays: mass_sum, effective_mass, effective_width" do k = 1, size (tree%mass_sum) if (tree%branch(k)%set) then write (u, "(5x,I0,3(2x," // FMT_19 // "))") k, tree%mass_sum(k), & tree%effective_mass(k), tree%effective_width(k) end if end do end subroutine phs_tree_write subroutine phs_branch_write (b, unit, kval) type(phs_branch_t), intent(in) :: b integer, intent(in), optional :: unit integer(TC), intent(in), optional :: kval integer :: u integer(TC) :: k character(len=6) :: tmp character(len=1) :: firstborn(2), sign_decay, sign_axis integer :: i u = given_output_unit (unit); if (u < 0) return k = 0; if (present (kval)) k = kval if (b%origin /= 0) then write(tmp, '(A,I4,A)') '(', b%origin, ')' else tmp = ' ' end if do i=1, 2 if (b%firstborn == i) then firstborn(i) = "*" else firstborn(i) = " " end if end do if (b%inverted_decay) then sign_decay = "-" else sign_decay = "+" end if if (b%inverted_axis) then sign_axis = "-" else sign_axis = "+" end if if (b%has_children) then if (b%has_friend) then write(u,'(4X,A1,I0,3x,A,1X,A,I0,A1,1x,I0,A1,1X,A1,1X,A,1x,I0)') & & '*', k, tmp, & & 'Daughters: ', & & b%daughter(1), firstborn(1), & & b%daughter(2), firstborn(2), sign_decay, & & 'Friend: ', b%friend else write(u,'(4X,A1,I0,3x,A,1X,A,I0,A1,1x,I0,A1,1X,A1,1X,A)') & & '*', k, tmp, & & 'Daughters: ', & & b%daughter(1), firstborn(1), & & b%daughter(2), firstborn(2), sign_decay, & & '(axis '//sign_axis//')' end if else write(u,'(5X,I0)') k end if end subroutine phs_branch_write @ %def phs_tree_write phs_branch_write @ \subsection{PHS tree setup} \subsubsection{Transformation into an array of branch codes and back} Assume that the tree/array has been created before with the appropriate length and is empty. <>= public :: phs_tree_from_array <>= procedure :: from_array => phs_tree_from_array +<>= + module subroutine phs_tree_from_array (tree, a) + class(phs_tree_t), intent(inout) :: tree + integer(TC), dimension(:), intent(in) :: a + end subroutine phs_tree_from_array <>= - subroutine phs_tree_from_array (tree, a) + module subroutine phs_tree_from_array (tree, a) class(phs_tree_t), intent(inout) :: tree integer(TC), dimension(:), intent(in) :: a integer :: i integer(TC) :: k <> <> <> <> contains <> end subroutine phs_tree_from_array @ %def phs_tree_from_array @ First, set all branches specified by the user. If all IN-bits are set, we invert the branch code. <>= do i=1, size(a) k = a(i) if (iand(k, tree%mask_in) == tree%mask_in) k = ieor(tree%mask, k) tree%branch(k)%set = .true. tree%n_branches = tree%n_branches+1 end do @ The external branches are understood, so set them now if not yet done. In all cases ensure that the representative with one bit set is used, except for decays where the in-particle is represented by all OUT-bits set instead. <>= do i=0, tree%n_externals-1 k = ibset(0,i) if (iand(k, tree%mask_in) == tree%mask_in) k = ieor(tree%mask, k) if (tree%branch(ieor(tree%mask, k))%set) then tree%branch(ieor(tree%mask, k))%set = .false. tree%branch(k)%set = .true. else if (.not.tree%branch(k)%set) then tree%branch(k)%set = .true. tree%n_branches = tree%n_branches+1 end if end do @ Now the number of branches set can be checked. Here we assume that the tree is binary. For three externals there are three branches in total, and for each additional external branch we get another internal one. <>= if (tree%n_branches /= tree%n_externals*2-3) then call phs_tree_write (tree) call msg_bug & & (" Wrong number of branches set in phase space tree") end if @ For all branches that are set, except for the externals, we try to find the daughter branches: <>= do k=1, size (tree%branch) if (tree%branch(k)%set .and. tc_decay_level (k) /= 1) then call branch_set_relatives(k) end if end do @ To this end, we scan all codes less than the current code, whether we can find two branches which are set and which together give the current code. After that, the tree may still not be connected, but at least we know if a branch does not have daughters: This indicates some inconsistency. The algorithm ensures that, at this stage, the first daughter has a smaller code value than the second one. <>= subroutine branch_set_relatives (k) integer(TC), intent(in) :: k integer(TC) :: m,n do m=1, k-1 if (iand(k,m)==m) then n = ieor(k,m) if ( tree%branch(m)%set .and. tree%branch(n)%set ) then tree%branch(k)%daughter(1) = m; tree%branch(k)%daughter(2) = n tree%branch(m)%mother = k; tree%branch(n)%mother = k tree%branch(m)%sibling = n; tree%branch(n)%sibling = m tree%branch(k)%has_children = .true. return end if end if end do call phs_tree_write (tree) call msg_bug & & (" Missing daughter branch(es) in phase space tree") end subroutine branch_set_relatives @ The inverse: this is trivial, fortunately. @ \subsubsection{Flip $t$-channel into $s$-channel} Flipping the tree is done upwards, beginning from the decay products. First we select a $t$-channel branch [[k]]: one which is set, which does have an IN-bit, and which is not an external particle. Next, we determine the adjacent in-particle (called the 'friend' [[f]] here, since it will provide the reference axis for the angular integration). In addition, we look for the 'mother' and 'sibling' of this particle. If the latter field is empty, we select the (unique) other out-particle which has no mother, calling the internal subroutine [[find_orphan]]. The flip is done as follows: We assume that the first daughter [[d]] is an $s$-channel line, which is true if the daughters are sorted. This will stay the first daughter. The second one is a $t$-channel line; it is exchanged with the 'sibling' [[s]]. The new line which replaces the branch [[k]] is just the sum of [[s]] and [[d]]. In addition, we have to rearrange the relatives of [[s]] and [[d]], as well of [[f]]. Finally, we flip 'sibling' and 'friend' and set the new $s$-channel branch [[n]] which replaces the $t$-channel branch [[k]]. After this is complete, we are ready to execute another flip. [Although the friend is not needed for the final flip, since it would be an initial particle anyway, we need to know whether we have $t$- or $u$-channel.] -<>= - public :: phs_tree_flip_t_to_s_channel +<>= + procedure :: flip_t_to_s_channel => phs_tree_flip_t_to_s_channel +<>= + module subroutine phs_tree_flip_t_to_s_channel (tree) + class(phs_tree_t), intent(inout) :: tree + end subroutine phs_tree_flip_t_to_s_channel <>= - subroutine phs_tree_flip_t_to_s_channel (tree) - type(phs_tree_t), intent(inout) :: tree + module subroutine phs_tree_flip_t_to_s_channel (tree) + class(phs_tree_t), intent(inout) :: tree integer(TC) :: k, f, m, n, d, s if (tree%n_in == 2) then FLIP: do k=3, tree%mask-1 if (.not. tree%branch(k)%set) cycle FLIP f = iand(k,tree%mask_in) if (f==0 .or. f==k) cycle FLIP m = tree%branch(k)%mother s = tree%branch(k)%sibling if (s==0) call find_orphan(s) d = tree%branch(k)%daughter(1) n = ior(d,s) tree%branch(k)%set = .false. tree%branch(n)%set = .true. tree%branch(n)%origin = k tree%branch(n)%daughter(1) = d; tree%branch(d)%mother = n tree%branch(n)%daughter(2) = s; tree%branch(s)%mother = n tree%branch(n)%has_children = .true. tree%branch(d)%sibling = s; tree%branch(s)%sibling = d tree%branch(n)%sibling = f; tree%branch(f)%sibling = n tree%branch(n)%mother = m tree%branch(f)%mother = m if (m/=0) then tree%branch(m)%daughter(1) = n tree%branch(m)%daughter(2) = f end if tree%branch(n)%friend = f tree%branch(n)%has_friend = .true. tree%branch(n)%firstborn = 2 end do FLIP end if contains subroutine find_orphan(s) integer(TC) :: s do s=1, tree%mask_out if (tree%branch(s)%set .and. tree%branch(s)%mother==0) return end do call phs_tree_write (tree) call msg_bug (" Can't flip phase space tree to channel") end subroutine find_orphan end subroutine phs_tree_flip_t_to_s_channel @ %def phs_tree_flip_t_to_s_channel @ After the tree has been flipped, one may need to determine what has become of a particular $t$-channel branch. This function gives the bincode of the flipped tree. If the original bincode does not contain IN-bits, we leave it as it is. <>= function tc_flipped (tree, kt) result (ks) type(phs_tree_t), intent(in) :: tree integer(TC), intent(in) :: kt integer(TC) :: ks if (iand (kt, tree%mask_in) == 0) then ks = kt else ks = tree%branch(iand (kt, tree%mask_out))%mother end if end function tc_flipped @ %def tc_flipped @ Scan a tree and make sure that the first daughter has always a smaller code than the second one. Furthermore, delete any [[friend]] entry in the root branch -- this branching has the incoming particle direction as axis anyway. Keep track of reordering by updating [[inverted_axis]], [[inverted_decay]] and [[firstborn]]. -<>= - public :: phs_tree_canonicalize +<>= + procedure :: canonicalize => phs_tree_canonicalize +<>= + module subroutine phs_tree_canonicalize (tree) + class(phs_tree_t), intent(inout) :: tree + end subroutine phs_tree_canonicalize <>= - subroutine phs_tree_canonicalize (tree) - type(phs_tree_t), intent(inout) :: tree + module subroutine phs_tree_canonicalize (tree) + class(phs_tree_t), intent(inout) :: tree integer :: n_out integer(TC) :: k_out call branch_canonicalize (tree%branch(tree%mask_out)) n_out = tree%n_externals - tree%n_in k_out = tree%mask_out if (tree%branch(k_out)%has_friend & & .and. tree%branch(k_out)%friend == ibset (0, n_out)) then tree%branch(k_out)%inverted_axis = .not.tree%branch(k_out)%inverted_axis end if tree%branch(k_out)%has_friend = .false. tree%branch(k_out)%friend = 0 contains recursive subroutine branch_canonicalize (b) type(phs_branch_t), intent(inout) :: b integer(TC) :: d1, d2 if (b%has_children) then d1 = b%daughter(1) d2 = b%daughter(2) if (d1 > d2) then b%daughter(1) = d2 b%daughter(2) = d1 b%inverted_decay = .not.b%inverted_decay if (b%firstborn /= 0) b%firstborn = 3 - b%firstborn end if call branch_canonicalize (tree%branch(b%daughter(1))) call branch_canonicalize (tree%branch(b%daughter(2))) end if end subroutine branch_canonicalize end subroutine phs_tree_canonicalize @ %def phs_tree_canonicalize @ \subsubsection{Mappings} Initialize a mapping for the current tree. This is done while reading from file, so the mapping parameters are read, but applied to the flipped tree. Thus, the size of the array of mappings is given by the number of outgoing particles only. -<>= - public :: phs_tree_init_mapping <>= procedure :: init_mapping => phs_tree_init_mapping +<>= + module subroutine phs_tree_init_mapping (tree, k, type, pdg, model) + class(phs_tree_t), intent(inout) :: tree + integer(TC), intent(in) :: k + type(string_t), intent(in) :: type + integer, intent(in) :: pdg + class(model_data_t), intent(in), target :: model + end subroutine phs_tree_init_mapping <>= - subroutine phs_tree_init_mapping (tree, k, type, pdg, model) + module subroutine phs_tree_init_mapping (tree, k, type, pdg, model) class(phs_tree_t), intent(inout) :: tree integer(TC), intent(in) :: k type(string_t), intent(in) :: type integer, intent(in) :: pdg class(model_data_t), intent(in), target :: model integer(TC) :: kk kk = tc_flipped (tree, k) - call mapping_init (tree%mapping(kk), kk, type, pdg, model) + call tree%mapping(kk)%init (kk, type, pdg, model) end subroutine phs_tree_init_mapping @ %def phs_tree_init_mapping @ Set the physical parameters for the mapping, using a specific parameter set. Also set the mass sum array. -<>= - public :: phs_tree_set_mapping_parameters <>= procedure :: set_mapping_parameters => phs_tree_set_mapping_parameters +<>= + module subroutine phs_tree_set_mapping_parameters & + (tree, mapping_defaults, variable_limits) + class(phs_tree_t), intent(inout) :: tree + type(mapping_defaults_t), intent(in) :: mapping_defaults + logical, intent(in) :: variable_limits + end subroutine phs_tree_set_mapping_parameters <>= - subroutine phs_tree_set_mapping_parameters & + module subroutine phs_tree_set_mapping_parameters & (tree, mapping_defaults, variable_limits) class(phs_tree_t), intent(inout) :: tree type(mapping_defaults_t), intent(in) :: mapping_defaults logical, intent(in) :: variable_limits integer(TC) :: k do k = 1, tree%n_branches_out - call mapping_set_parameters & - (tree%mapping(k), mapping_defaults, variable_limits) + call tree%mapping(k)%set_parameters (mapping_defaults, variable_limits) end do end subroutine phs_tree_set_mapping_parameters @ %def phs_tree_set_mapping_parameters @ Return the mapping for the sum of all outgoing particles. This should either be no mapping or a global s-channel mapping. -<>= - public :: phs_tree_assign_s_mapping +<>= + procedure :: assign_s_mapping => phs_tree_assign_s_mapping +<>= + module subroutine phs_tree_assign_s_mapping (tree, mapping) + class(phs_tree_t), intent(in) :: tree + type(mapping_t), intent(out) :: mapping + end subroutine phs_tree_assign_s_mapping <>= - subroutine phs_tree_assign_s_mapping (tree, mapping) - type(phs_tree_t), intent(in) :: tree + module subroutine phs_tree_assign_s_mapping (tree, mapping) + class(phs_tree_t), intent(in) :: tree type(mapping_t), intent(out) :: mapping mapping = tree%mapping(tree%mask_out) end subroutine phs_tree_assign_s_mapping @ %def phs_tree_assign_s_mapping @ \subsubsection{Kinematics} Fill the mass sum array, starting from the external particles and working down to the tree root. For each bincode [[k]] we scan the bits in [[k]]; if only one is set, we take the physical mass of the corresponding external particle; if more then one is set, we sum up the two masses (which we know have already been set). -<>= - public :: phs_tree_set_mass_sum <>= procedure :: set_mass_sum => phs_tree_set_mass_sum +<>= + module subroutine phs_tree_set_mass_sum (tree, flv) + class(phs_tree_t), intent(inout) :: tree + type(flavor_t), dimension(:), intent(in) :: flv + end subroutine phs_tree_set_mass_sum <>= - subroutine phs_tree_set_mass_sum (tree, flv) + module subroutine phs_tree_set_mass_sum (tree, flv) class(phs_tree_t), intent(inout) :: tree type(flavor_t), dimension(:), intent(in) :: flv integer(TC) :: k integer :: i tree%mass_sum = 0 do k = 1, tree%n_branches_out do i = 0, size (flv) - 1 if (btest(k,i)) then if (ibclr(k,i) == 0) then tree%mass_sum(k) = flv(i+1)%get_mass () else tree%mass_sum(k) = & tree%mass_sum(ibclr(k,i)) + tree%mass_sum(ibset(0,i)) end if exit end if end do end do end subroutine phs_tree_set_mass_sum @ %def phs_tree_set_mass_sum @ Set the effective masses and widths. For each non-resonant branch in a tree, the effective mass is equal to the sum of the effective masses of the children (and analogous for the width). External particles have their real mass and width zero. For resonant branches, we insert mass and width from the corresponding mapping. This routine has [[phs_tree_set_mass_sum]] and [[phs_tree_set_mapping_parameters]] as prerequisites. -<>= - public :: phs_tree_set_effective_masses <>= procedure :: set_effective_masses => phs_tree_set_effective_masses +<>= + module subroutine phs_tree_set_effective_masses (tree) + class(phs_tree_t), intent(inout) :: tree + end subroutine phs_tree_set_effective_masses <>= - subroutine phs_tree_set_effective_masses (tree) + module subroutine phs_tree_set_effective_masses (tree) class(phs_tree_t), intent(inout) :: tree tree%effective_mass = 0 tree%effective_width = 0 call set_masses_x (tree%mask_out) contains recursive subroutine set_masses_x (k) integer(TC), intent(in) :: k integer(TC) :: k1, k2 if (tree%branch(k)%has_children) then k1 = tree%branch(k)%daughter(1) k2 = tree%branch(k)%daughter(2) call set_masses_x (k1) call set_masses_x (k2) - if (mapping_is_s_channel (tree%mapping(k))) then - tree%effective_mass(k) = mapping_get_mass (tree%mapping(k)) - tree%effective_width(k) = mapping_get_width (tree%mapping(k)) + if (tree%mapping(k)%is_s_channel ()) then + tree%effective_mass(k) = tree%mapping(k)%get_mass () + tree%effective_width(k) = tree%mapping(k)%get_width () else tree%effective_mass(k) = & tree%effective_mass(k1) + tree%effective_mass(k2) tree%effective_width(k) = & tree%effective_width(k1) + tree%effective_width(k2) end if else tree%effective_mass(k) = tree%mass_sum(k) end if end subroutine set_masses_x end subroutine phs_tree_set_effective_masses @ %def phs_tree_set_effective_masses @ Define step mappings, recursively, for the decay products of all intermediate resonances. Step mappings account for the fact that a branch may originate from a resonance, which almost replaces the upper limit on the possible invariant mass. The step mapping implements a smooth cutoff that interpolates between the resonance and the real kinematic limit. The mapping width determines the sharpness of the cutoff. Step mappings are inserted only for branches that are not mapped otherwise. At each branch, we record the mass that is effectively available for phase space, by taking the previous limit and subtracting the effective mass of the sibling branch. Widths are added, not subtracted. If we encounter a resonance decay, we discard the previous limit and replace it by the mass and width of the resonance, also subtracting the sibling branch. Initially, the limit is zero, so it becomes negative at any branch. Only if there is a resonance, the limit becomes positive. Whenever the limit is positive, and the current branch decays, we activate a step mapping for the current branch. As a result, step mappings are implemented for all internal lines that originate from an intermediate resonance decay. The flag [[variable_limits]] applies to the ultimate limit from the available energy, not to the intermediate resonances whose masses are always fixed. This routine requires [[phs_tree_set_effective_masses]] -<>= - public :: phs_tree_set_step_mappings +<>= + procedure :: set_step_mappings => phs_tree_set_step_mappings +<>= + module subroutine phs_tree_set_step_mappings & + (tree, exp_type, variable_limits) + class(phs_tree_t), intent(inout) :: tree + logical, intent(in) :: exp_type + logical, intent(in) :: variable_limits + end subroutine phs_tree_set_step_mappings <>= - subroutine phs_tree_set_step_mappings (tree, exp_type, variable_limits) - type(phs_tree_t), intent(inout) :: tree + module subroutine phs_tree_set_step_mappings & + (tree, exp_type, variable_limits) + class(phs_tree_t), intent(inout) :: tree logical, intent(in) :: exp_type logical, intent(in) :: variable_limits type(string_t) :: map_str integer(TC) :: k if (exp_type) then map_str = "step_exp" else map_str = "step_hyp" end if k = tree%mask_out call set_step_mappings_x (k, 0._default, 0._default) contains recursive subroutine set_step_mappings_x (k, m_limit, w_limit) integer(TC), intent(in) :: k real(default), intent(in) :: m_limit, w_limit integer(TC), dimension(2) :: kk real(default), dimension(2) :: m, w if (tree%branch(k)%has_children) then if (m_limit > 0) then - if (.not. mapping_is_set (tree%mapping(k))) then - call mapping_init (tree%mapping(k), k, map_str) - call mapping_set_step_mapping_parameters (tree%mapping(k), & - m_limit, w_limit, & - variable_limits) + if (.not. tree%mapping(k)%is_set ()) then + call tree%mapping(k)%init (k, map_str) + call tree%mapping(k)%set_step_mapping_parameters (m_limit, & + w_limit, variable_limits) end if end if kk = tree%branch(k)%daughter m = tree%effective_mass(kk) w = tree%effective_width(kk) - if (mapping_is_s_channel (tree%mapping(k))) then + if (tree%mapping(k)%is_s_channel ()) then call set_step_mappings_x (kk(1), & - mapping_get_mass (tree%mapping(k)) - m(2), & - mapping_get_width (tree%mapping(k)) + w(2)) + tree%mapping(k)%get_mass () - m(2), & + tree%mapping(k)%get_width () + w(2)) call set_step_mappings_x (kk(2), & - mapping_get_mass (tree%mapping(k)) - m(1), & - mapping_get_width (tree%mapping(k)) + w(1)) + tree%mapping(k)%get_mass () - m(1), & + tree%mapping(k)%get_width () + w(1)) else if (m_limit > 0) then call set_step_mappings_x (kk(1), & m_limit - m(2), & w_limit + w(2)) call set_step_mappings_x (kk(2), & m_limit - m(1), & w_limit + w(1)) else call set_step_mappings_x (kk(1), & - m(2), & + w(2)) call set_step_mappings_x (kk(2), & - m(1), & + w(1)) end if end if end subroutine set_step_mappings_x end subroutine phs_tree_set_step_mappings @ %def phs_tree_set_step_mappings @ \subsubsection{Resonance structure} We identify the resonances within a tree as the set of s-channel mappings. The [[resonance_history_t]] type serves as the result container. <>= procedure :: extract_resonance_history => phs_tree_extract_resonance_history +<>= + module subroutine phs_tree_extract_resonance_history (tree, res_history) + class(phs_tree_t), intent(in) :: tree + type(resonance_history_t), intent(out) :: res_history + end subroutine phs_tree_extract_resonance_history <>= - subroutine phs_tree_extract_resonance_history (tree, res_history) + module subroutine phs_tree_extract_resonance_history (tree, res_history) class(phs_tree_t), intent(in) :: tree type(resonance_history_t), intent(out) :: res_history type(resonance_info_t) :: res_info integer :: i if (allocated (tree%mapping)) then do i = 1, size (tree%mapping) associate (mapping => tree%mapping(i)) if (mapping%is_s_channel ()) then call res_info%init (mapping%get_bincode (), mapping%get_flv (), & n_out = tree%n_externals - tree%n_in) call res_history%add_resonance (res_info) end if end associate end do end if end subroutine phs_tree_extract_resonance_history @ %def phs_tree_extract_resonance_history @ \subsubsection{Structural comparison} This function allows to check whether one tree is the permutation of another one. The permutation is applied to the second tree in the argument list. We do not make up a temporary permuted tree, but compare the two trees directly. The branches are scanned recursively, where for each daughter we check the friend and the mapping as well. Once a discrepancy is found, the recursion is exited immediately. <>= public :: phs_tree_equivalent +<>= + module function phs_tree_equivalent (t1, t2, perm) result (is_equal) + type(phs_tree_t), intent(in) :: t1, t2 + type(permutation_t), intent(in) :: perm + logical :: equal, is_equal + end function phs_tree_equivalent <>= - function phs_tree_equivalent (t1, t2, perm) result (is_equal) + module function phs_tree_equivalent (t1, t2, perm) result (is_equal) type(phs_tree_t), intent(in) :: t1, t2 type(permutation_t), intent(in) :: perm logical :: equal, is_equal integer(TC) :: k1, k2, mask_in k1 = t1%mask_out k2 = t2%mask_out mask_in = t1%mask_in equal = .true. call check (t1%branch(k1), t2%branch(k2), k1, k2) is_equal = equal contains recursive subroutine check (b1, b2, k1, k2) type(phs_branch_t), intent(in) :: b1, b2 integer(TC), intent(in) :: k1, k2 integer(TC), dimension(2) :: d1, d2, pd2 integer :: i if (.not.b1%has_friend .and. .not.b2%has_friend) then equal = .true. else if (b1%has_friend .and. b2%has_friend) then equal = (b1%friend == tc_permute (b2%friend, perm, mask_in)) end if if (equal) then if (b1%has_children .and. b2%has_children) then d1 = b1%daughter d2 = b2%daughter do i=1, 2 pd2(i) = tc_permute (d2(i), perm, mask_in) end do if (d1(1)==pd2(1) .and. d1(2)==pd2(2)) then equal = (b1%firstborn == b2%firstborn) if (equal) call check & & (t1%branch(d1(1)), t2%branch(d2(1)), d1(1), d2(1)) if (equal) call check & & (t1%branch(d1(2)), t2%branch(d2(2)), d1(2), d2(2)) else if (d1(1)==pd2(2) .and. d1(2)==pd2(1)) then equal = ( (b1%firstborn == 0 .and. b2%firstborn == 0) & & .or. (b1%firstborn == 3 - b2%firstborn) ) if (equal) call check & & (t1%branch(d1(1)), t2%branch(d2(2)), d1(1), d2(2)) if (equal) call check & & (t1%branch(d1(2)), t2%branch(d2(1)), d1(2), d2(1)) else equal = .false. end if end if end if if (equal) then equal = (t1%mapping(k1) == t2%mapping(k2)) end if end subroutine check end function phs_tree_equivalent @ %def phs_tree_equivalent @ Scan two decay trees and determine the correspondence of mass variables, i.e., the permutation that transfers the ordered list of mass variables belonging to the second tree into the first one. Mass variables are assigned beginning from branches and ending at the root. <>= public :: phs_tree_find_msq_permutation +<>= + module subroutine phs_tree_find_msq_permutation & + (tree1, tree2, perm2, msq_perm) + type(phs_tree_t), intent(in) :: tree1, tree2 + type(permutation_t), intent(in) :: perm2 + type(permutation_t), intent(out) :: msq_perm + end subroutine phs_tree_find_msq_permutation <>= - subroutine phs_tree_find_msq_permutation (tree1, tree2, perm2, msq_perm) + module subroutine phs_tree_find_msq_permutation & + (tree1, tree2, perm2, msq_perm) type(phs_tree_t), intent(in) :: tree1, tree2 type(permutation_t), intent(in) :: perm2 type(permutation_t), intent(out) :: msq_perm type(permutation_t) :: perm1 integer(TC) :: mask_in, root integer(TC), dimension(:), allocatable :: index1, index2 integer :: i allocate (index1 (tree1%n_msq), index2 (tree2%n_msq)) call permutation_init (perm1, permutation_size (perm2)) mask_in = tree1%mask_in root = tree1%mask_out i = 0 call tree_scan (tree1, root, perm1, index1) i = 0 call tree_scan (tree2, root, perm2, index2) call permutation_find (msq_perm, index1, index2) contains recursive subroutine tree_scan (tree, k, perm, index) type(phs_tree_t), intent(in) :: tree integer(TC), intent(in) :: k type(permutation_t), intent(in) :: perm integer, dimension(:), intent(inout) :: index if (tree%branch(k)%has_children) then call tree_scan (tree, tree%branch(k)%daughter(1), perm, index) call tree_scan (tree, tree%branch(k)%daughter(2), perm, index) i = i + 1 if (i <= size (index)) index(i) = tc_permute (k, perm, mask_in) end if end subroutine tree_scan end subroutine phs_tree_find_msq_permutation @ %def phs_tree_find_msq_permutation <>= public :: phs_tree_find_angle_permutation +<>= + module subroutine phs_tree_find_angle_permutation & + (tree1, tree2, perm2, angle_perm, sig2) + type(phs_tree_t), intent(in) :: tree1, tree2 + type(permutation_t), intent(in) :: perm2 + type(permutation_t), intent(out) :: angle_perm + logical, dimension(:), allocatable, intent(out) :: sig2 + end subroutine phs_tree_find_angle_permutation <>= - subroutine phs_tree_find_angle_permutation & + module subroutine phs_tree_find_angle_permutation & (tree1, tree2, perm2, angle_perm, sig2) type(phs_tree_t), intent(in) :: tree1, tree2 type(permutation_t), intent(in) :: perm2 type(permutation_t), intent(out) :: angle_perm logical, dimension(:), allocatable, intent(out) :: sig2 type(permutation_t) :: perm1 integer(TC) :: mask_in, root integer(TC), dimension(:), allocatable :: index1, index2 logical, dimension(:), allocatable :: sig1 integer :: i allocate (index1 (tree1%n_angles), index2 (tree2%n_angles)) allocate (sig1 (tree1%n_angles), sig2 (tree2%n_angles)) call permutation_init (perm1, permutation_size (perm2)) mask_in = tree1%mask_in root = tree1%mask_out i = 0 call tree_scan (tree1, root, perm1, index1, sig1) i = 0 call tree_scan (tree2, root, perm2, index2, sig2) call permutation_find (angle_perm, index1, index2) contains recursive subroutine tree_scan (tree, k, perm, index, sig) type(phs_tree_t), intent(in) :: tree integer(TC), intent(in) :: k type(permutation_t), intent(in) :: perm integer, dimension(:), intent(inout) :: index logical, dimension(:), intent(inout) :: sig integer(TC) :: k1, k2, kp logical :: s if (tree%branch(k)%has_children) then k1 = tree%branch(k)%daughter(1) k2 = tree%branch(k)%daughter(2) s = (tc_permute(k1, perm, mask_in) < tc_permute(k2, perm, mask_in)) kp = tc_permute (k, perm, mask_in) i = i + 1 index(i) = kp sig(i) = s i = i + 1 index(i) = - kp sig(i) = s call tree_scan (tree, k1, perm, index, sig) call tree_scan (tree, k2, perm, index, sig) end if end subroutine tree_scan end subroutine phs_tree_find_angle_permutation @ %def phs_tree_find_angle_permutation @ \subsection{Phase-space evaluation} \subsubsection{Phase-space volume} We compute the phase-space volume recursively, following the same path as for computing other kinematical variables. However, the volume depends just on $\sqrt{\hat s}$, not on the momentum configuration. Note: counting branches, we may replace this by a simple formula. -<>= - public :: phs_tree_compute_volume +<>= + procedure :: compute_volume => phs_tree_compute_volume +<>= + module subroutine phs_tree_compute_volume (tree, sqrts, volume) + class(phs_tree_t), intent(in) :: tree + real(default), intent(in) :: sqrts + real(default), intent(out) :: volume + end subroutine phs_tree_compute_volume <>= - subroutine phs_tree_compute_volume (tree, sqrts, volume) - type(phs_tree_t), intent(in) :: tree + module subroutine phs_tree_compute_volume (tree, sqrts, volume) + class(phs_tree_t), intent(in) :: tree real(default), intent(in) :: sqrts real(default), intent(out) :: volume integer(TC) :: k k = tree%mask_out if (tree%branch(k)%has_children) then call compute_volume_x (tree%branch(k), k, volume, .true.) else volume = 1 end if contains recursive subroutine compute_volume_x (b, k, volume, initial) type(phs_branch_t), intent(in) :: b integer(TC), intent(in) :: k real(default), intent(out) :: volume logical, intent(in) :: initial integer(TC) :: k1, k2 real(default) :: v1, v2 k1 = b%daughter(1); k2 = b%daughter(2) if (tree%branch(k1)%has_children) then call compute_volume_x (tree%branch(k1), k1, v1, .false.) else v1 = 1 end if if (tree%branch(k2)%has_children) then call compute_volume_x (tree%branch(k2), k2, v2, .false.) else v2 = 1 end if if (initial) then volume = v1 * v2 / (4 * twopi5) else volume = v1 * v2 * sqrts**2 / (4 * twopi2) end if end subroutine compute_volume_x end subroutine phs_tree_compute_volume @ %def phs_tree_compute_volume @ \subsubsection{Determine momenta} This is done in two steps: First the masses are determined. This step may fail, in which case [[ok]] is set to false. If successful, we generate angles and the actual momenta. The array [[decay_p]] serves for transferring the individual three-momenta of the daughter particles in their mother rest frame from the mass generation to the momentum generation step. -<>= - public :: phs_tree_compute_momenta_from_x +<>= + procedure :: compute_momenta_from_x => phs_tree_compute_momenta_from_x +<>= + module subroutine phs_tree_compute_momenta_from_x & + (tree, prt, factor, volume, sqrts, x, ok) + class(phs_tree_t), intent(inout) :: tree + type(phs_prt_t), dimension(:), intent(inout) :: prt + real(default), intent(out) :: factor, volume + real(default), intent(in) :: sqrts + real(default), dimension(:), intent(in) :: x + logical, intent(out) :: ok + end subroutine phs_tree_compute_momenta_from_x <>= - subroutine phs_tree_compute_momenta_from_x & + module subroutine phs_tree_compute_momenta_from_x & (tree, prt, factor, volume, sqrts, x, ok) - type(phs_tree_t), intent(inout) :: tree + class(phs_tree_t), intent(inout) :: tree type(phs_prt_t), dimension(:), intent(inout) :: prt real(default), intent(out) :: factor, volume real(default), intent(in) :: sqrts real(default), dimension(:), intent(in) :: x logical, intent(out) :: ok real(default), dimension(tree%mask_out) :: decay_p integer :: n1, n2 integer :: n_out if (tree%real_phsp) then n_out = tree%n_externals - tree%n_in - 1 n1 = max (n_out-2, 0) n2 = n1 + max (2*n_out, 0) else n1 = tree%n_msq n2 = n1 + tree%n_angles end if call phs_tree_set_msq & (tree, prt, factor, volume, decay_p, sqrts, x(1:n1), ok) if (ok) call phs_tree_set_angles & (tree, prt, factor, decay_p, sqrts, x(n1+1:n2)) end subroutine phs_tree_compute_momenta_from_x @ %def phs_tree_compute_momenta_from_x @ Mass generation is done recursively. The [[ok]] flag causes the filled tree to be discarded if set to [[.false.]]. This happens if a three-momentum turns out to be imaginary, indicating impossible kinematics. The index [[ix]] tells us how far we have used up the input array [[x]]. <>= subroutine phs_tree_set_msq & (tree, prt, factor, volume, decay_p, sqrts, x, ok) type(phs_tree_t), intent(inout) :: tree type(phs_prt_t), dimension(:), intent(inout) :: prt real(default), intent(out) :: factor, volume real(default), dimension(:), intent(out) :: decay_p real(default), intent(in) :: sqrts real(default), dimension(:), intent(in) :: x logical, intent(out) :: ok integer :: ix integer(TC) :: k real(default) :: m_tot ok =.true. ix = 1 k = tree%mask_out m_tot = tree%mass_sum(k) decay_p(k) = 0. if (m_tot < sqrts .or. k == 1) then if (tree%branch(k)%has_children) then call set_msq_x (tree%branch(k), k, factor, volume, .true.) else factor = 1 volume = 1 end if else ok = .false. end if contains recursive subroutine set_msq_x (b, k, factor, volume, initial) type(phs_branch_t), intent(in) :: b integer(TC), intent(in) :: k real(default), intent(out) :: factor, volume logical, intent(in) :: initial real(default) :: msq, m, m_min, m_max, m1, m2, msq1, msq2, lda, rlda integer(TC) :: k1, k2 real(default) :: f1, f2, v1, v2 k1 = b%daughter(1); k2 = b%daughter(2) if (tree%branch(k1)%has_children) then call set_msq_x (tree%branch(k1), k1, f1, v1, .false.) if (.not.ok) return else f1 = 1; v1 = 1 end if if (tree%branch(k2)%has_children) then call set_msq_x (tree%branch(k2), k2, f2, v2, .false.) if (.not.ok) return else f2 = 1; v2 = 1 end if m_min = tree%mass_sum(k) if (initial) then msq = sqrts**2 m = sqrts m_max = sqrts factor = f1 * f2 volume = v1 * v2 / (4 * twopi5) else m_max = sqrts - m_tot + m_min - call mapping_compute_msq_from_x & - (tree%mapping(k), sqrts**2, m_min**2, m_max**2, msq, factor, & - x(ix)); ix = ix + 1 + call tree%mapping(k)%compute_msq_from_x (sqrts**2, m_min**2, & + m_max**2, msq, factor, x(ix)); ix = ix + 1 if (msq >= 0) then m = sqrt (msq) factor = f1 * f2 * factor volume = v1 * v2 * sqrts**2 / (4 * twopi2) - call phs_prt_set_msq (prt(k), msq) - call phs_prt_set_defined (prt(k)) + call prt(k)%set_msq (msq) + call prt(k)%set_defined () else ok = .false. end if end if if (ok) then - msq1 = phs_prt_get_msq (prt(k1)); m1 = sqrt (msq1) - msq2 = phs_prt_get_msq (prt(k2)); m2 = sqrt (msq2) + msq1 = prt(k1)%get_msq (); m1 = sqrt (msq1) + msq2 = prt(k2)%get_msq (); m2 = sqrt (msq2) lda = lambda (msq, msq1, msq2) if (lda > 0 .and. m > m1 + m2 .and. m <= m_max) then rlda = sqrt (lda) decay_p(k1) = rlda / (2*m) decay_p(k2) = - decay_p(k1) factor = rlda / msq * factor else ok = .false. end if end if end subroutine set_msq_x end subroutine phs_tree_set_msq @ %def phs_tree_set_msq @ The heart of phase space generation: Now we have the invariant masses, let us generate angles. At each branch, we take a Lorentz transformation and augment it by a boost to the current particle rest frame, and by rotations $\phi$ and $\theta$ around the $z$ and $y$ axis, respectively. This transformation is passed down to the daughter particles, if present. <>= subroutine phs_tree_set_angles (tree, prt, factor, decay_p, sqrts, x) type(phs_tree_t), intent(inout) :: tree type(phs_prt_t), dimension(:), intent(inout) :: prt real(default), intent(inout) :: factor real(default), dimension(:), intent(in) :: decay_p real(default), intent(in) :: sqrts real(default), dimension(:), intent(in) :: x integer :: ix integer(TC) :: k ix = 1 k = tree%mask_out call set_angles_x (tree%branch(k), k) contains recursive subroutine set_angles_x (b, k, L0) type(phs_branch_t), intent(in) :: b integer(TC), intent(in) :: k type(lorentz_transformation_t), intent(in), optional :: L0 real(default) :: m, msq, ct, st, phi, f, E, p, bg type(lorentz_transformation_t) :: L, LL integer(TC) :: k1, k2 type(vector3_t) :: axis p = decay_p(k) - msq = phs_prt_get_msq (prt(k)); m = sqrt (msq) + msq = prt(k)%get_msq (); m = sqrt (msq) E = sqrt (msq + p**2) if (present (L0)) then - call phs_prt_set_momentum (prt(k), L0 * vector4_moving (E,p,3)) + call prt(k)%set_momentum (L0 * vector4_moving (E,p,3)) else - call phs_prt_set_momentum (prt(k), vector4_moving (E,p,3)) + call prt(k)%set_momentum (vector4_moving (E,p,3)) end if - call phs_prt_set_defined (prt(k)) + call prt(k)%set_defined () if (b%has_children) then k1 = b%daughter(1) k2 = b%daughter(2) if (m > 0) then bg = p / m else bg = 0 end if phi = x(ix) * twopi; ix = ix + 1 - call mapping_compute_ct_from_x & - (tree%mapping(k), sqrts**2, ct, st, f, x(ix)); ix = ix + 1 + call tree%mapping(k)%compute_ct_from_x (sqrts**2, ct, st, f, & + x(ix)); ix = ix + 1 factor = factor * f if (.not. b%has_friend) then L = LT_compose_r2_r3_b3 (ct, st, cos(phi), sin(phi), bg) !!! The function above is equivalent to: ! L = boost (bg,3) * rotation (phi,3) * rotation (ct,st,2) else LL = boost (-bg,3); if (present (L0)) LL = LL * inverse(L0) axis = space_part ( & - LL * phs_prt_get_momentum (prt(tree%branch(k)%friend)) ) + LL * prt(tree%branch(k)%friend)%get_momentum () ) L = boost(bg,3) * rotation_to_2nd (vector3_canonical(3), axis) & * LT_compose_r2_r3_b3 (ct, st, cos(phi), sin(phi), 0._default) end if if (present (L0)) L = L0 * L call set_angles_x (tree%branch(k1), k1, L) call set_angles_x (tree%branch(k2), k2, L) end if end subroutine set_angles_x end subroutine phs_tree_set_angles @ %def phs_tree_set_angles @ \subsubsection{Recover random numbers} For the other channels we want to compute the random numbers that would have generated the momenta that we already know. -<>= - public :: phs_tree_compute_x_from_momenta +<>= + procedure :: compute_x_from_momenta => phs_tree_compute_x_from_momenta +<>= + module subroutine phs_tree_compute_x_from_momenta & + (tree, prt, factor, sqrts, x) + class(phs_tree_t), intent(inout) :: tree + type(phs_prt_t), dimension(:), intent(in) :: prt + real(default), intent(out) :: factor + real(default), intent(in) :: sqrts + real(default), dimension(:), intent(inout) :: x + end subroutine phs_tree_compute_x_from_momenta <>= - subroutine phs_tree_compute_x_from_momenta (tree, prt, factor, sqrts, x) - type(phs_tree_t), intent(inout) :: tree + module subroutine phs_tree_compute_x_from_momenta & + (tree, prt, factor, sqrts, x) + class(phs_tree_t), intent(inout) :: tree type(phs_prt_t), dimension(:), intent(in) :: prt real(default), intent(out) :: factor real(default), intent(in) :: sqrts real(default), dimension(:), intent(inout) :: x real(default), dimension(tree%mask_out) :: decay_p integer :: n1, n2 n1 = tree%n_msq n2 = n1 + tree%n_angles call phs_tree_get_msq & (tree, prt, factor, decay_p, sqrts, x(1:n1)) call phs_tree_get_angles & (tree, prt, factor, decay_p, sqrts, x(n1+1:n2)) end subroutine phs_tree_compute_x_from_momenta @ %def phs_tree_compute_x_from_momenta @ The inverse operation follows exactly the same steps. The tree is [[inout]] because it contains mappings whose parameters can be reset when the mapping is applied. <>= subroutine phs_tree_get_msq (tree, prt, factor, decay_p, sqrts, x) type(phs_tree_t), intent(inout) :: tree type(phs_prt_t), dimension(:), intent(in) :: prt real(default), intent(out) :: factor real(default), dimension(:), intent(out) :: decay_p real(default), intent(in) :: sqrts real(default), dimension(:), intent(inout) :: x integer :: ix integer(TC) :: k real(default) :: m_tot ix = 1 k = tree%mask_out m_tot = tree%mass_sum(k) decay_p(k) = 0. if (tree%branch(k)%has_children) then call get_msq_x (tree%branch(k), k, factor, .true.) else factor = 1 end if contains recursive subroutine get_msq_x (b, k, factor, initial) type(phs_branch_t), intent(in) :: b integer(TC), intent(in) :: k real(default), intent(out) :: factor logical, intent(in) :: initial real(default) :: msq, m, m_min, m_max, msq1, msq2, lda, rlda integer(TC) :: k1, k2 real(default) :: f1, f2 k1 = b%daughter(1); k2 = b%daughter(2) if (tree%branch(k1)%has_children) then call get_msq_x (tree%branch(k1), k1, f1, .false.) else f1 = 1 end if if (tree%branch(k2)%has_children) then call get_msq_x (tree%branch(k2), k2, f2, .false.) else f2 = 1 end if m_min = tree%mass_sum(k) m_max = sqrts - m_tot + m_min - msq = phs_prt_get_msq (prt(k)); m = sqrt (msq) + msq = prt(k)%get_msq (); m = sqrt (msq) if (initial) then factor = f1 * f2 else - call mapping_compute_x_from_msq & - (tree%mapping(k), sqrts**2, m_min**2, m_max**2, msq, factor, & - x(ix)); ix = ix + 1 + call tree%mapping(k)%compute_x_from_msq (sqrts**2, m_min**2, & + m_max**2, msq, factor, x(ix)); ix = ix + 1 factor = f1 * f2 * factor end if - msq1 = phs_prt_get_msq (prt(k1)) - msq2 = phs_prt_get_msq (prt(k2)) + msq1 = prt(k1)%get_msq () + msq2 = prt(k2)%get_msq () lda = lambda (msq, msq1, msq2) if (lda > 0) then rlda = sqrt (lda) decay_p(k1) = rlda / (2 * m) decay_p(k2) = - decay_p(k1) factor = rlda / msq * factor else decay_p(k1) = 0 decay_p(k2) = 0 factor = 0 end if end subroutine get_msq_x end subroutine phs_tree_get_msq @ %def phs_tree_get_msq @ This subroutine is the most time-critical part of the whole program. Therefore, we do not exactly parallel the angle generation routine above but make sure that things get evaluated only if they are really needed, at the expense of readability. Particularly important is to have as few multiplications of Lorentz transformations as possible. <>= subroutine phs_tree_get_angles (tree, prt, factor, decay_p, sqrts, x) type(phs_tree_t), intent(inout) :: tree type(phs_prt_t), dimension(:), intent(in) :: prt real(default), intent(inout) :: factor real(default), dimension(:), intent(in) :: decay_p real(default), intent(in) :: sqrts real(default), dimension(:), intent(out) :: x integer :: ix integer(TC) :: k ix = 1 k = tree%mask_out if (tree%branch(k)%has_children) then call get_angles_x (tree%branch(k), k) end if contains recursive subroutine get_angles_x (b, k, ct0, st0, phi0, L0) type(phs_branch_t), intent(in) :: b integer(TC), intent(in) :: k real(default), intent(in), optional :: ct0, st0, phi0 type(lorentz_transformation_t), intent(in), optional :: L0 real(default) :: cp0, sp0, m, msq, ct, st, phi, bg, f type(lorentz_transformation_t) :: L, LL type(vector4_t) :: p1, pf type(vector3_t) :: n, axis integer(TC) :: k1, k2, kf logical :: has_friend, need_L k1 = b%daughter(1) k2 = b%daughter(2) kf = b%friend has_friend = b%has_friend if (present(L0)) then - p1 = L0 * phs_prt_get_momentum (prt(k1)) - if (has_friend) pf = L0 * phs_prt_get_momentum (prt(kf)) + p1 = L0 * prt(k1)%get_momentum () + if (has_friend) pf = L0 * prt(kf)%get_momentum () else - p1 = phs_prt_get_momentum (prt(k1)) - if (has_friend) pf = phs_prt_get_momentum (prt(kf)) + p1 = prt(k1)%get_momentum () + if (has_friend) pf = prt(kf)%get_momentum () end if if (present(phi0)) then cp0 = cos (phi0) sp0 = sin (phi0) end if - msq = phs_prt_get_msq (prt(k)); m = sqrt (msq) + msq = prt(k)%get_msq (); m = sqrt (msq) if (m > 0) then bg = decay_p(k) / m else bg = 0 end if if (has_friend) then if (present (phi0)) then axis = axis_from_p_r3_r2_b3 (pf, cp0, -sp0, ct0, -st0, -bg) LL = rotation_to_2nd (axis, vector3_canonical (3)) & * LT_compose_r3_r2_b3 (cp0, -sp0, ct0, -st0, -bg) else axis = axis_from_p_b3 (pf, -bg) LL = rotation_to_2nd (axis, vector3_canonical(3)) if (.not. vanishes (bg)) LL = LL * boost(-bg, 3) end if n = space_part (LL * p1) else if (present (phi0)) then n = axis_from_p_r3_r2_b3 (p1, cp0, -sp0, ct0, -st0, -bg) else n = axis_from_p_b3 (p1, -bg) end if phi = azimuthal_angle (n) x(ix) = phi / twopi; ix = ix + 1 ct = polar_angle_ct (n) st = sqrt (1 - ct**2) - call mapping_compute_x_from_ct (tree%mapping(k), sqrts**2, ct, f, & - x(ix)); ix = ix + 1 + call tree%mapping(k)%compute_x_from_ct (sqrts**2, ct, f, & + x(ix)); ix = ix + 1 factor = factor * f if (tree%branch(k1)%has_children .or. tree%branch(k2)%has_children) then need_L = .true. if (has_friend) then if (present (L0)) then L = LL * L0 else L = LL end if else if (present (L0)) then L = LT_compose_r3_r2_b3 (cp0, -sp0, ct0, -st0, -bg) * L0 else if (present (phi0)) then L = LT_compose_r3_r2_b3 (cp0, -sp0, ct0, -st0, -bg) else if (bg /= 0) then L = boost(-bg, 3) else need_L = .false. end if if (need_L) then if (tree%branch(k1)%has_children) & call get_angles_x (tree%branch(k1), k1, ct, st, phi, L) if (tree%branch(k2)%has_children) & call get_angles_x (tree%branch(k2), k2, ct, st, phi, L) else if (tree%branch(k1)%has_children) & call get_angles_x (tree%branch(k1), k1, ct, st, phi) if (tree%branch(k2)%has_children) & call get_angles_x (tree%branch(k2), k2, ct, st, phi) end if end if end subroutine get_angles_x end subroutine phs_tree_get_angles @ %def phs_tree_get_angles @ \subsubsection{Auxiliary stuff} This calculates all momenta that are not yet known by summing up daughter particle momenta. The external particles must be known. Only composite particles not yet known are calculated. <>= public :: phs_tree_combine_particles +<>= + module subroutine phs_tree_combine_particles (tree, prt) + type(phs_tree_t), intent(in) :: tree + type(phs_prt_t), dimension(:), intent(inout) :: prt + end subroutine phs_tree_combine_particles <>= - subroutine phs_tree_combine_particles (tree, prt) + module subroutine phs_tree_combine_particles (tree, prt) type(phs_tree_t), intent(in) :: tree type(phs_prt_t), dimension(:), intent(inout) :: prt call combine_particles_x (tree%mask_out) contains recursive subroutine combine_particles_x (k) integer(TC), intent(in) :: k integer :: k1, k2 if (tree%branch(k)%has_children) then k1 = tree%branch(k)%daughter(1); k2 = tree%branch(k)%daughter(2) call combine_particles_x (k1) call combine_particles_x (k2) if (.not. prt(k)%defined) then - call phs_prt_combine (prt(k), prt(k1), prt(k2)) + call prt(k)%combine (prt(k1), prt(k2)) end if end if end subroutine combine_particles_x end subroutine phs_tree_combine_particles @ %def phs_tree_combine_particles @ The previous routine is to be evaluated at runtime. Instead of scanning trees, we can as well set up a multiplication table. This is generated here. Note that the table is [[intent(out)]]. <>= public :: phs_tree_setup_prt_combinations +<>= + module subroutine phs_tree_setup_prt_combinations (tree, comb) + type(phs_tree_t), intent(in) :: tree + integer, dimension(:,:), intent(out) :: comb + end subroutine phs_tree_setup_prt_combinations <>= - subroutine phs_tree_setup_prt_combinations (tree, comb) + module subroutine phs_tree_setup_prt_combinations (tree, comb) type(phs_tree_t), intent(in) :: tree integer, dimension(:,:), intent(out) :: comb comb = 0 call setup_prt_combinations_x (tree%mask_out) contains recursive subroutine setup_prt_combinations_x (k) integer(TC), intent(in) :: k integer, dimension(2) :: kk if (tree%branch(k)%has_children) then kk = tree%branch(k)%daughter call setup_prt_combinations_x (kk(1)) call setup_prt_combinations_x (kk(2)) comb(:,k) = kk end if end subroutine setup_prt_combinations_x end subroutine phs_tree_setup_prt_combinations @ %def phs_tree_setup_prt_combinations -@ -<>= - public :: phs_tree_reshuffle_mappings +@ JRR: 2022-01-22 [[reshuffle_mappings]] is commented out, and no +longer used, not clear why? +<>= + procedure :: reshuffle_mappings => phs_tree_reshuffle_mappings +<>= + module subroutine phs_tree_reshuffle_mappings (tree) + class(phs_tree_t), intent(inout) :: tree + end subroutine phs_tree_reshuffle_mappings <>= - subroutine phs_tree_reshuffle_mappings (tree) - type(phs_tree_t), intent(inout) :: tree + module subroutine phs_tree_reshuffle_mappings (tree) + class(phs_tree_t), intent(inout) :: tree integer(TC) :: k0, k_old, k_new, k2 integer :: i type(mapping_t) :: mapping_tmp real(default) :: mass_tmp do i = 1, size (tree%momentum_link) if (i /= tree%momentum_link (i)) then k_old = 2**(i-tree%n_in-1) k_new = 2**(tree%momentum_link(i)-tree%n_in-1) k0 = tree%branch(k_old)%mother k2 = k_new + tree%branch(k_old)%sibling mapping_tmp = tree%mapping(k0) mass_tmp = tree%mass_sum(k0) tree%mapping(k0) = tree%mapping(k2) tree%mapping(k2) = mapping_tmp tree%mass_sum(k0) = tree%mass_sum(k2) tree%mass_sum(k2) = mass_tmp end if end do end subroutine phs_tree_reshuffle_mappings @ %def phs_tree_reshuffle_mappings @ <>= public :: phs_tree_set_momentum_links +<>= + module subroutine phs_tree_set_momentum_links (tree, list) + type(phs_tree_t), intent(inout) :: tree + integer, dimension(:), allocatable :: list + end subroutine phs_tree_set_momentum_links <>= - subroutine phs_tree_set_momentum_links (tree, list) + module subroutine phs_tree_set_momentum_links (tree, list) type(phs_tree_t), intent(inout) :: tree integer, dimension(:), allocatable :: list tree%momentum_link = list end subroutine phs_tree_set_momentum_links @ %def phs_tree_set_momentum_links @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[phs_trees_ut.f90]]>>= <> module phs_trees_ut use unit_tests use phs_trees_uti <> <> contains <> end module phs_trees_ut @ %def phs_trees_ut @ <<[[phs_trees_uti.f90]]>>= <> module phs_trees_uti !!!<> use kinds, only: TC <> use flavors, only: flavor_t use model_data, only: model_data_t use resonances, only: resonance_history_t use mappings, only: mapping_defaults_t use phs_trees <> <> contains <> end module phs_trees_uti @ %def phs_trees_ut @ API: driver for the unit tests below. <>= public :: phs_trees_test <>= subroutine phs_trees_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine phs_trees_test @ %def phs_trees_test @ Create a simple $2\to 3$ PHS tree and display it. <>= call test (phs_tree_1, "phs_tree_1", & "check phs tree setup", & u, results) <>= public :: phs_tree_1 <>= subroutine phs_tree_1 (u) integer, intent(in) :: u type(phs_tree_t) :: tree type(model_data_t), target :: model type(flavor_t), dimension(5) :: flv integer :: i write (u, "(A)") "* Test output: phs_tree_1" write (u, "(A)") "* Purpose: test PHS tree routines" write (u, "(A)") write (u, "(A)") "* Read model file" call model%init_sm_test () write (u, "(A)") write (u, "(A)") "* Set up flavors" write (u, "(A)") call flv%init ([1, -2, 24, 5, -5], model) do i = 1, 5 write (u, "(1x)", advance="no") call flv(i)%write (u) end do write (u, *) write (u, "(A)") write (u, "(A)") "* Create tree" write (u, "(A)") call tree%init (2, 3, 0, 0) call tree%from_array ([integer(TC) :: 1, 2, 3, 4, 7, 8, 16]) call tree%set_mass_sum (flv) call tree%set_effective_masses () call tree%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call tree%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_tree_1" end subroutine phs_tree_1 @ %def phs_tree_1 @ The analogous tree with resonance (s-channel) mappings. <>= call test (phs_tree_2, "phs_tree_2", & "check phs tree with resonances", & u, results) <>= public :: phs_tree_2 <>= subroutine phs_tree_2 (u) integer, intent(in) :: u type(phs_tree_t) :: tree type(model_data_t), target :: model type(mapping_defaults_t) :: mapping_defaults type(flavor_t), dimension(5) :: flv type(resonance_history_t) :: res_history integer :: i write (u, "(A)") "* Test output: phs_tree_2" write (u, "(A)") "* Purpose: test PHS tree with resonances" write (u, "(A)") write (u, "(A)") "* Read model file" call model%init_sm_test () write (u, "(A)") write (u, "(A)") "* Set up flavors" write (u, "(A)") call flv%init ([1, -2, 24, 5, -5], model) do i = 1, 5 write (u, "(1x)", advance="no") call flv(i)%write (u) end do write (u, *) write (u, "(A)") write (u, "(A)") "* Create tree with mappings" write (u, "(A)") call tree%init (2, 3, 0, 0) call tree%from_array ([integer(TC) :: 1, 2, 3, 4, 7, 8, 16]) call tree%set_mass_sum (flv) call tree%init_mapping (3_TC, var_str ("s_channel"), -24, model) call tree%init_mapping (7_TC, var_str ("s_channel"), 23, model) call tree%set_mapping_parameters (mapping_defaults, variable_limits=.false.) call tree%set_effective_masses () call tree%write (u) write (u, "(A)") write (u, "(A)") "* Extract resonances from mappings" write (u, "(A)") call tree%extract_resonance_history (res_history) call res_history%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call tree%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_tree_2" end subroutine phs_tree_2 @ %def phs_tree_2 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{The phase-space forest} Simply stated, a phase-space forest is a collection of phase-space trees. More precisely, a [[phs_forest]] object contains all parameterizations of phase space that \whizard\ will use for a single hard process, prepared in the form of [[phs_tree]] objects. This is suitable for evaluation by the \vamp\ integration package: each parameterization (tree) is a valid channel in the multi-channel adaptive integration, and each variable in a tree corresponds to an integration dimension, defined by an appropriate mapping of the $(0,1)$ interval to the allowed range of the integration variable. The trees are grouped in groves. The trees (integration channels) within a grove share a common weight, assuming that they are related by some approximate symmetry. Trees/channels that are related by an exact symmetry are connected by an array of equivalences; each equivalence object holds the data that relate one channel to another. The phase-space setup, i.e., the detailed structure of trees and forest, are read from a file. Therefore, this module also contains the syntax definition and the parser needed for interpreting this file. <<[[phs_forests.f90]]>>= <> module phs_forests <> use kinds, only: TC <> - use io_units - use format_defs, only: FMT_19 - use diagnostics use lorentz - use numeric_utils use permutations - use ifiles use syntax_rules - use lexers use parser use model_data - use model_data use flavors use interactions use phs_base use resonances, only: resonance_history_t use resonances, only: resonance_history_set_t use mappings use phs_trees <> <> <> <> <> + interface +<> + end interface + contains -<> +<> end module phs_forests @ %def phs_forests @ +<<[[phs_forests_sub.f90]]>>= +<> + +submodule (phs_forests) phs_forests_s + + use io_units + use format_defs, only: FMT_19 + use diagnostics + use numeric_utils + use ifiles + use lexers + + implicit none + +contains + +<> + +end submodule phs_forests_s + +@ %def phs_forests_s +@ \subsection{Phase-space setup parameters} This transparent container holds the parameters that the algorithm needs for phase-space setup, with reasonable defaults. The threshold mass (for considering a particle as effectively massless) is specified separately for s- and t-channel. The default is to treat $W$ and $Z$ bosons as massive in the s-channel, but as massless in the t-channel. The $b$-quark is treated always massless, the $t$-quark always massive. <>= public :: phs_parameters_t <>= type :: phs_parameters_t real(default) :: sqrts = 0 real(default) :: m_threshold_s = 50._default real(default) :: m_threshold_t = 100._default integer :: off_shell = 1 integer :: t_channel = 2 logical :: keep_nonresonant = .true. contains <> end type phs_parameters_t @ %def phs_parameters_t @ Write phase-space parameters to file. <>= procedure :: write => phs_parameters_write +<>= + module subroutine phs_parameters_write (phs_par, unit) + class(phs_parameters_t), intent(in) :: phs_par + integer, intent(in), optional :: unit + end subroutine phs_parameters_write <>= - subroutine phs_parameters_write (phs_par, unit) + module subroutine phs_parameters_write (phs_par, unit) class(phs_parameters_t), intent(in) :: phs_par integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(3x,A," // FMT_19 // ")") "sqrts = ", phs_par%sqrts write (u, "(3x,A," // FMT_19 // ")") "m_threshold_s = ", phs_par%m_threshold_s write (u, "(3x,A," // FMT_19 // ")") "m_threshold_t = ", phs_par%m_threshold_t write (u, "(3x,A,I0)") "off_shell = ", phs_par%off_shell write (u, "(3x,A,I0)") "t_channel = ", phs_par%t_channel write (u, "(3x,A,L1)") "keep_nonresonant = ", phs_par%keep_nonresonant end subroutine phs_parameters_write @ %def phs_parameters_write @ Read phase-space parameters from file. -<>= - public :: phs_parameters_read +<>= + procedure :: read => phs_parameters_read +<>= + module subroutine phs_parameters_read (phs_par, unit) + class(phs_parameters_t), intent(out) :: phs_par + integer, intent(in) :: unit + end subroutine phs_parameters_read <>= - subroutine phs_parameters_read (phs_par, unit) - type(phs_parameters_t), intent(out) :: phs_par + module subroutine phs_parameters_read (phs_par, unit) + class(phs_parameters_t), intent(out) :: phs_par integer, intent(in) :: unit character(20) :: dummy character :: equals read (unit, *) dummy, equals, phs_par%sqrts read (unit, *) dummy, equals, phs_par%m_threshold_s read (unit, *) dummy, equals, phs_par%m_threshold_t read (unit, *) dummy, equals, phs_par%off_shell read (unit, *) dummy, equals, phs_par%t_channel read (unit, *) dummy, equals, phs_par%keep_nonresonant end subroutine phs_parameters_read @ %def phs_parameters_write @ Comparison. <>= interface operator(==) module procedure phs_parameters_eq end interface interface operator(/=) module procedure phs_parameters_ne end interface +<>= + module function phs_parameters_eq (phs_par1, phs_par2) result (equal) + logical :: equal + type(phs_parameters_t), intent(in) :: phs_par1, phs_par2 + end function phs_parameters_eq + module function phs_parameters_ne (phs_par1, phs_par2) result (ne) + logical :: ne + type(phs_parameters_t), intent(in) :: phs_par1, phs_par2 + end function phs_parameters_ne <>= - function phs_parameters_eq (phs_par1, phs_par2) result (equal) + module function phs_parameters_eq (phs_par1, phs_par2) result (equal) logical :: equal type(phs_parameters_t), intent(in) :: phs_par1, phs_par2 equal = phs_par1%sqrts == phs_par2%sqrts & .and. phs_par1%m_threshold_s == phs_par2%m_threshold_s & .and. phs_par1%m_threshold_t == phs_par2%m_threshold_t & .and. phs_par1%off_shell == phs_par2%off_shell & .and. phs_par1%t_channel == phs_par2%t_channel & .and.(phs_par1%keep_nonresonant .eqv. phs_par2%keep_nonresonant) end function phs_parameters_eq - function phs_parameters_ne (phs_par1, phs_par2) result (ne) + module function phs_parameters_ne (phs_par1, phs_par2) result (ne) logical :: ne type(phs_parameters_t), intent(in) :: phs_par1, phs_par2 ne = phs_par1%sqrts /= phs_par2%sqrts & .or. phs_par1%m_threshold_s /= phs_par2%m_threshold_s & .or. phs_par1%m_threshold_t /= phs_par2%m_threshold_t & .or. phs_par1%off_shell /= phs_par2%off_shell & .or. phs_par1%t_channel /= phs_par2%t_channel & .or.(phs_par1%keep_nonresonant .neqv. phs_par2%keep_nonresonant) end function phs_parameters_ne @ %def phs_parameters_eq phs_parameters_ne @ \subsection{Equivalences} This type holds information about equivalences between phase-space trees. We make a linked list, where each node contains the two trees which are equivalent and the corresponding permutation of external particles. Two more arrays are to be filled: The permutation of mass variables and the permutation of angular variables, where the signature indicates a necessary exchange of daughter branches. <>= type :: equivalence_t private integer :: left, right type(permutation_t) :: perm type(permutation_t) :: msq_perm, angle_perm logical, dimension(:), allocatable :: angle_sig type(equivalence_t), pointer :: next => null () end type equivalence_t @ %def equivalence_t <>= type :: equivalence_list_t private integer :: length = 0 type(equivalence_t), pointer :: first => null () type(equivalence_t), pointer :: last => null () end type equivalence_list_t @ %def equivalence_list_t @ Append an equivalence to the list <>= subroutine equivalence_list_add (eql, left, right, perm) type(equivalence_list_t), intent(inout) :: eql integer, intent(in) :: left, right type(permutation_t), intent(in) :: perm type(equivalence_t), pointer :: eq allocate (eq) eq%left = left eq%right = right eq%perm = perm if (associated (eql%last)) then eql%last%next => eq else eql%first => eq end if eql%last => eq eql%length = eql%length + 1 end subroutine equivalence_list_add @ %def equivalence_list_add @ Delete the list contents. Has to be pure because it is called from an elemental subroutine. <>= pure subroutine equivalence_list_final (eql) type(equivalence_list_t), intent(inout) :: eql type(equivalence_t), pointer :: eq do while (associated (eql%first)) eq => eql%first eql%first => eql%first%next deallocate (eq) end do eql%last => null () eql%length = 0 end subroutine equivalence_list_final @ %def equivalence_list_final @ Make a deep copy of the equivalence list. This allows for deep copies of groves and forests. <>= interface assignment(=) module procedure equivalence_list_assign end interface -<>= +<>= subroutine equivalence_list_assign (eql_out, eql_in) type(equivalence_list_t), intent(out) :: eql_out type(equivalence_list_t), intent(in) :: eql_in type(equivalence_t), pointer :: eq, eq_copy eq => eql_in%first do while (associated (eq)) allocate (eq_copy) eq_copy = eq eq_copy%next => null () if (associated (eql_out%first)) then eql_out%last%next => eq_copy else eql_out%first => eq_copy end if eql_out%last => eq_copy eq => eq%next end do end subroutine equivalence_list_assign @ %def equivalence_list_assign @ The number of list entries <>= elemental function equivalence_list_length (eql) result (length) integer :: length type(equivalence_list_t), intent(in) :: eql length = eql%length end function equivalence_list_length @ %def equivalence_list_length @ Recursively write the equivalences list <>= subroutine equivalence_list_write (eql, unit) type(equivalence_list_t), intent(in) :: eql integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return if (associated (eql%first)) then call equivalence_write_rec (eql%first, u) else write (u, *) " [empty]" end if contains recursive subroutine equivalence_write_rec (eq, u) type(equivalence_t), intent(in) :: eq integer, intent(in) :: u integer :: i write (u, "(3x,A,1x,I0,1x,I0,2x,A)", advance="no") & "Equivalence:", eq%left, eq%right, "Final state permutation:" call permutation_write (eq%perm, u) write (u, "(1x,12x,1x,A,1x)", advance="no") & " msq permutation: " call permutation_write (eq%msq_perm, u) write (u, "(1x,12x,1x,A,1x)", advance="no") & " angle permutation:" call permutation_write (eq%angle_perm, u) write (u, "(1x,12x,1x,26x)", advance="no") do i = 1, size (eq%angle_sig) if (eq%angle_sig(i)) then write (u, "(1x,A)", advance="no") "+" else write (u, "(1x,A)", advance="no") "-" end if end do write (u, *) if (associated (eq%next)) call equivalence_write_rec (eq%next, u) end subroutine equivalence_write_rec end subroutine equivalence_list_write @ %def equivalence_list_write @ \subsection{Groves} A grove is a group of trees (phase-space channels) that share a common weight in the integration. Within a grove, channels can be declared equivalent, so they also share their integration grids (up to symmetries). The grove contains a list of equivalences. The [[tree_count_offset]] is the total number of trees of the preceding groves; when the trees are counted per forest (integration channels), the offset has to be added to all tree indices. <>= type :: phs_grove_t private integer :: tree_count_offset type(phs_tree_t), dimension(:), allocatable :: tree type(equivalence_list_t) :: equivalence_list end type phs_grove_t @ %def phs_grove_t @ Call [[phs_tree_init]] which is also elemental: <>= elemental subroutine phs_grove_init & (grove, n_trees, n_in, n_out, n_masses, n_angles) type(phs_grove_t), intent(inout) :: grove integer, intent(in) :: n_trees, n_in, n_out, n_masses, n_angles grove%tree_count_offset = 0 allocate (grove%tree (n_trees)) - call phs_tree_init (grove%tree, n_in, n_out, n_masses, n_angles) + call grove%tree%init (n_in, n_out, n_masses, n_angles) end subroutine phs_grove_init @ %def phs_grove_init @ The trees do not have pointer components, thus no call to [[phs_tree_final]]: <>= elemental subroutine phs_grove_final (grove) type(phs_grove_t), intent(inout) :: grove deallocate (grove%tree) call equivalence_list_final (grove%equivalence_list) end subroutine phs_grove_final @ %def phs_grove_final -@ Deep copy. +@ Deep copy. This triggers double free corruption with the Intel +compiler and hence has to remain in the main module. <>= interface assignment(=) module procedure phs_grove_assign0 module procedure phs_grove_assign1 end interface -<>= +<>= subroutine phs_grove_assign0 (grove_out, grove_in) type(phs_grove_t), intent(out) :: grove_out type(phs_grove_t), intent(in) :: grove_in grove_out%tree_count_offset = grove_in%tree_count_offset if (allocated (grove_in%tree)) then allocate (grove_out%tree (size (grove_in%tree))) grove_out%tree = grove_in%tree end if grove_out%equivalence_list = grove_in%equivalence_list end subroutine phs_grove_assign0 subroutine phs_grove_assign1 (grove_out, grove_in) type(phs_grove_t), dimension(:), intent(out) :: grove_out type(phs_grove_t), dimension(:), intent(in) :: grove_in integer :: i do i = 1, size (grove_in) call phs_grove_assign0 (grove_out(i), grove_in(i)) end do end subroutine phs_grove_assign1 @ %def phs_grove_assign @ Get the global (s-channel) mappings. Implemented as a subroutine which returns an array (slice). <>= subroutine phs_grove_assign_s_mappings (grove, mapping) type(phs_grove_t), intent(in) :: grove type(mapping_t), dimension(:), intent(out) :: mapping integer :: i if (size (mapping) == size (grove%tree)) then do i = 1, size (mapping) - call phs_tree_assign_s_mapping (grove%tree(i), mapping(i)) + call grove%tree(i)%assign_s_mapping (mapping(i)) end do else call msg_bug ("phs_grove_assign_s_mappings: array size mismatch") end if end subroutine phs_grove_assign_s_mappings @ %def phs_grove_assign_s_mappings @ \subsection{The forest type} This is a collection of trees and associated particles. In a given tree, each branch code corresponds to a particle in the [[prt]] array. Furthermore, we have an array of mass sums which is independent of the decay tree and of the particular event. The mappings directly correspond to the decay trees, and the decay groves collect the trees in classes. The permutation list consists of all permutations of outgoing particles that map the decay forest onto itself. The particle codes [[flv]] (one for each external particle) are needed for determining masses and such. The trees and associated information are collected in the [[grove]] array, together with a lookup table that associates tree indices to groves. Finally, the [[prt]] array serves as workspace for phase-space evaluation. The [[prt_combination]] is a list of index pairs, namely the particle momenta pairs that need to be combined in order to provide all momentum combinations that the phase-space trees need to know. <>= public :: phs_forest_t <>= type :: phs_forest_t private integer :: n_in, n_out, n_tot integer :: n_masses, n_angles, n_dimensions integer :: n_trees, n_equivalences type(flavor_t), dimension(:), allocatable :: flv type(phs_grove_t), dimension(:), allocatable :: grove integer, dimension(:), allocatable :: grove_lookup type(phs_prt_t), dimension(:), allocatable :: prt_in type(phs_prt_t), dimension(:), allocatable :: prt_out type(phs_prt_t), dimension(:), allocatable :: prt integer(TC), dimension(:,:), allocatable :: prt_combination type(mapping_t), dimension(:), allocatable :: s_mapping contains <> end type phs_forest_t @ %def phs_forest_t @ The initialization merely allocates memory. We have to know how many trees there are in each grove, so we can initialize everything. The number of groves is the size of the [[n_tree]] array. In the [[grove_lookup]] table we store the grove index that belongs to each absolute tree index. The difference between the absolute index and the relative (to the grove) index is stored, for each grove, as [[tree_count_offset]]. The particle array is allocated according to the total number of branches each tree has, but not filled. -<>= - public :: phs_forest_init +<>= + procedure :: init => phs_forest_init +<>= + module subroutine phs_forest_init (forest, n_tree, n_in, n_out) + class(phs_forest_t), intent(inout) :: forest + integer, dimension(:), intent(in) :: n_tree + integer, intent(in) :: n_in, n_out + end subroutine phs_forest_init <>= - subroutine phs_forest_init (forest, n_tree, n_in, n_out) - type(phs_forest_t), intent(inout) :: forest + module subroutine phs_forest_init (forest, n_tree, n_in, n_out) + class(phs_forest_t), intent(inout) :: forest integer, dimension(:), intent(in) :: n_tree integer, intent(in) :: n_in, n_out integer :: g, count, k_root forest%n_in = n_in forest%n_out = n_out forest%n_tot = n_in + n_out forest%n_masses = max (n_out - 2, 0) forest%n_angles = max (2*n_out - 2, 0) forest%n_dimensions = forest%n_masses + forest%n_angles forest%n_trees = sum (n_tree) forest%n_equivalences = 0 allocate (forest%grove (size (n_tree))) call phs_grove_init & (forest%grove, n_tree, n_in, n_out, forest%n_masses, & forest%n_angles) allocate (forest%grove_lookup (forest%n_trees)) count = 0 do g = 1, size (forest%grove) forest%grove(g)%tree_count_offset = count forest%grove_lookup (count+1:count+n_tree(g)) = g count = count + n_tree(g) end do allocate (forest%prt_in (n_in)) allocate (forest%prt_out (forest%n_out)) k_root = 2**forest%n_tot - 1 allocate (forest%prt (k_root)) allocate (forest%prt_combination (2, k_root)) allocate (forest%s_mapping (forest%n_trees)) end subroutine phs_forest_init @ %def phs_forest_init @ Assign the global (s-channel) mappings. -<>= - public :: phs_forest_set_s_mappings +<>= + procedure :: set_s_mappings => phs_forest_set_s_mappings +<>= + module subroutine phs_forest_set_s_mappings (forest) + class(phs_forest_t), intent(inout) :: forest + end subroutine phs_forest_set_s_mappings <>= - subroutine phs_forest_set_s_mappings (forest) - type(phs_forest_t), intent(inout) :: forest + module subroutine phs_forest_set_s_mappings (forest) + class(phs_forest_t), intent(inout) :: forest integer :: g, i0, i1, n do g = 1, size (forest%grove) - call phs_forest_get_grove_bounds (forest, g, i0, i1, n) + call forest%get_grove_bounds (g, i0, i1, n) call phs_grove_assign_s_mappings & (forest%grove(g), forest%s_mapping(i0:i1)) end do end subroutine phs_forest_set_s_mappings @ %def phs_forest_set_s_mappings @ The grove finalizer is called because it contains the equivalence list: -<>= - public :: phs_forest_final +<>= + procedure :: final => phs_forest_final +<>= + module subroutine phs_forest_final (forest) + class(phs_forest_t), intent(inout) :: forest + end subroutine phs_forest_final <>= - subroutine phs_forest_final (forest) - type(phs_forest_t), intent(inout) :: forest + module subroutine phs_forest_final (forest) + class(phs_forest_t), intent(inout) :: forest if (allocated (forest%grove)) then call phs_grove_final (forest%grove) deallocate (forest%grove) end if if (allocated (forest%grove_lookup)) deallocate (forest%grove_lookup) if (allocated (forest%prt)) deallocate (forest%prt) if (allocated (forest%s_mapping)) deallocate (forest%s_mapping) end subroutine phs_forest_final @ %def phs_forest_final @ \subsection{Screen output} Write the particles that are non-null, then the trees which point to them: -<>= - public :: phs_forest_write <>= procedure :: write => phs_forest_write +<>= + module subroutine phs_forest_write (forest, unit) + class(phs_forest_t), intent(in) :: forest + integer, intent(in), optional :: unit + end subroutine phs_forest_write <>= - subroutine phs_forest_write (forest, unit) + module subroutine phs_forest_write (forest, unit) class(phs_forest_t), intent(in) :: forest integer, intent(in), optional :: unit integer :: u integer :: i, g, k u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "Phase space forest:" write (u, "(3x,A,I0)") "n_in = ", forest%n_in write (u, "(3x,A,I0)") "n_out = ", forest%n_out write (u, "(3x,A,I0)") "n_tot = ", forest%n_tot write (u, "(3x,A,I0)") "n_masses = ", forest%n_masses write (u, "(3x,A,I0)") "n_angles = ", forest%n_angles write (u, "(3x,A,I0)") "n_dim = ", forest%n_dimensions write (u, "(3x,A,I0)") "n_trees = ", forest%n_trees write (u, "(3x,A,I0)") "n_equiv = ", forest%n_equivalences write (u, "(3x,A)", advance="no") "flavors =" if (allocated (forest%flv)) then do i = 1, size (forest%flv) write (u, "(1x,I0)", advance="no") forest%flv(i)%get_pdg () end do write (u, "(A)") else write (u, "(1x,A)") "[empty]" end if write (u, "(1x,A)") "Particle combinations:" if (allocated (forest%prt_combination)) then do k = 1, size (forest%prt_combination, 2) if (forest%prt_combination(1, k) /= 0) then write (u, "(3x,I0,1x,'<=',1x,I0,1x,'+',1x,I0)") & k, forest%prt_combination(:,k) end if end do else write (u, "(3x,A)") " [empty]" end if write (u, "(1x,A)") "Groves and trees:" if (allocated (forest%grove)) then do g = 1, size (forest%grove) write (u, "(3x,A,1x,I0)") "Grove ", g call phs_grove_write (forest%grove(g), unit) end do else write (u, "(3x,A)") " [empty]" end if write (u, "(1x,A,I0)") "Total number of equivalences: ", & forest%n_equivalences write (u, "(A)") write (u, "(1x,A)") "Global s-channel mappings:" if (allocated (forest%s_mapping)) then do i = 1, size (forest%s_mapping) associate (mapping => forest%s_mapping(i)) - if (mapping_is_s_channel (mapping) & - .or. mapping_is_on_shell (mapping)) then + if (mapping%is_s_channel () .or. mapping%is_on_shell ()) then write (u, "(1x,I0,':',1x)", advance="no") i - call mapping_write (forest%s_mapping(i), unit) + call forest%s_mapping(i)%write (unit) end if end associate end do else write (u, "(3x,A)") " [empty]" end if write (u, "(A)") write (u, "(1x,A)") "Incoming particles:" if (allocated (forest%prt_in)) then - if (any (phs_prt_is_defined (forest%prt_in))) then + if (any (forest%prt_in%is_defined ())) then do i = 1, size (forest%prt_in) - if (phs_prt_is_defined (forest%prt_in(i))) then + if (forest%prt_in(i)%is_defined ()) then write (u, "(1x,A,1x,I0)") "Particle", i - call phs_prt_write (forest%prt_in(i), u) + call forest%prt_in(i)%write (u) end if end do else write (u, "(3x,A)") "[all undefined]" end if else write (u, "(3x,A)") " [empty]" end if write (u, "(A)") write (u, "(1x,A)") "Outgoing particles:" if (allocated (forest%prt_out)) then - if (any (phs_prt_is_defined (forest%prt_out))) then + if (any (forest%prt_out%is_defined ())) then do i = 1, size (forest%prt_out) - if (phs_prt_is_defined (forest%prt_out(i))) then + if (forest%prt_out(i)%is_defined ()) then write (u, "(1x,A,1x,I0)") "Particle", i - call phs_prt_write (forest%prt_out(i), u) + call forest%prt_out(i)%write (u) end if end do else write (u, "(3x,A)") "[all undefined]" end if else write (u, "(1x,A)") " [empty]" end if write (u, "(A)") write (u, "(1x,A)") "Tree particles:" if (allocated (forest%prt)) then - if (any (phs_prt_is_defined (forest%prt))) then + if (any (forest%prt%is_defined ())) then do i = 1, size (forest%prt) - if (phs_prt_is_defined (forest%prt(i))) then + if (forest%prt(i)%is_defined ()) then write (u, "(1x,A,1x,I0)") "Particle", i - call phs_prt_write (forest%prt(i), u) + call forest%prt(i)%write (u) end if end do else write (u, "(3x,A)") "[all undefined]" end if else write (u, "(3x,A)") " [empty]" end if end subroutine phs_forest_write subroutine phs_grove_write (grove, unit) type(phs_grove_t), intent(in) :: grove integer, intent(in), optional :: unit integer :: u integer :: t u = given_output_unit (unit); if (u < 0) return do t = 1, size (grove%tree) write (u, "(3x,A,I0)") "Tree ", t - call phs_tree_write (grove%tree(t), unit) + call grove%tree(t)%write (unit) end do write (u, "(1x,A)") "Equivalence list:" call equivalence_list_write (grove%equivalence_list, unit) end subroutine phs_grove_write @ %def phs_grove_write phs_forest_write @ Deep copy. <>= public :: assignment(=) <>= interface assignment(=) module procedure phs_forest_assign end interface +<>= + module subroutine phs_forest_assign (forest_out, forest_in) + type(phs_forest_t), intent(out) :: forest_out + type(phs_forest_t), intent(in) :: forest_in + end subroutine phs_forest_assign <>= - subroutine phs_forest_assign (forest_out, forest_in) + module subroutine phs_forest_assign (forest_out, forest_in) type(phs_forest_t), intent(out) :: forest_out type(phs_forest_t), intent(in) :: forest_in forest_out%n_in = forest_in%n_in forest_out%n_out = forest_in%n_out forest_out%n_tot = forest_in%n_tot forest_out%n_masses = forest_in%n_masses forest_out%n_angles = forest_in%n_angles forest_out%n_dimensions = forest_in%n_dimensions forest_out%n_trees = forest_in%n_trees forest_out%n_equivalences = forest_in%n_equivalences if (allocated (forest_in%flv)) then allocate (forest_out%flv (size (forest_in%flv))) forest_out%flv = forest_in%flv end if if (allocated (forest_in%grove)) then allocate (forest_out%grove (size (forest_in%grove))) forest_out%grove = forest_in%grove end if if (allocated (forest_in%grove_lookup)) then allocate (forest_out%grove_lookup (size (forest_in%grove_lookup))) forest_out%grove_lookup = forest_in%grove_lookup end if if (allocated (forest_in%prt_in)) then allocate (forest_out%prt_in (size (forest_in%prt_in))) forest_out%prt_in = forest_in%prt_in end if if (allocated (forest_in%prt_out)) then allocate (forest_out%prt_out (size (forest_in%prt_out))) forest_out%prt_out = forest_in%prt_out end if if (allocated (forest_in%prt)) then allocate (forest_out%prt (size (forest_in%prt))) forest_out%prt = forest_in%prt end if if (allocated (forest_in%s_mapping)) then allocate (forest_out%s_mapping (size (forest_in%s_mapping))) forest_out%s_mapping = forest_in%s_mapping end if if (allocated (forest_in%prt_combination)) then allocate (forest_out%prt_combination & (2, size (forest_in%prt_combination, 2))) forest_out%prt_combination = forest_in%prt_combination end if end subroutine phs_forest_assign @ %def phs_forest_assign @ \subsection{Accessing contents} Get the number of integration parameters -<>= - public :: phs_forest_get_n_parameters +<>= + procedure :: get_n_parameters => phs_forest_get_n_parameters +<>= + module function phs_forest_get_n_parameters (forest) result (n) + integer :: n + class(phs_forest_t), intent(in) :: forest + end function phs_forest_get_n_parameters <>= - function phs_forest_get_n_parameters (forest) result (n) + module function phs_forest_get_n_parameters (forest) result (n) integer :: n - type(phs_forest_t), intent(in) :: forest + class(phs_forest_t), intent(in) :: forest n = forest%n_dimensions end function phs_forest_get_n_parameters @ %def phs_forest_get_n_parameters @ Get the number of integration channels -<>= - public :: phs_forest_get_n_channels +<>= + procedure :: get_n_channels => phs_forest_get_n_channels +<>= + module function phs_forest_get_n_channels (forest) result (n) + integer :: n + class(phs_forest_t), intent(in) :: forest + end function phs_forest_get_n_channels <>= - function phs_forest_get_n_channels (forest) result (n) + module function phs_forest_get_n_channels (forest) result (n) integer :: n - type(phs_forest_t), intent(in) :: forest + class(phs_forest_t), intent(in) :: forest n = forest%n_trees end function phs_forest_get_n_channels @ %def phs_forest_get_n_channels @ Get the number of groves -<>= - public :: phs_forest_get_n_groves +<>= + procedure :: get_n_groves => phs_forest_get_n_groves +<>= + module function phs_forest_get_n_groves (forest) result (n) + integer :: n + class(phs_forest_t), intent(in) :: forest + end function phs_forest_get_n_groves <>= - function phs_forest_get_n_groves (forest) result (n) + module function phs_forest_get_n_groves (forest) result (n) integer :: n - type(phs_forest_t), intent(in) :: forest + class(phs_forest_t), intent(in) :: forest n = size (forest%grove) end function phs_forest_get_n_groves @ %def phs_forest_get_n_groves @ Get the index bounds for a specific grove. -<>= - public :: phs_forest_get_grove_bounds +<>= + procedure :: get_grove_bounds => phs_forest_get_grove_bounds +<>= + module subroutine phs_forest_get_grove_bounds (forest, g, i0, i1, n) + class(phs_forest_t), intent(in) :: forest + integer, intent(in) :: g + integer, intent(out) :: i0, i1, n + end subroutine phs_forest_get_grove_bounds <>= - subroutine phs_forest_get_grove_bounds (forest, g, i0, i1, n) - type(phs_forest_t), intent(in) :: forest + module subroutine phs_forest_get_grove_bounds (forest, g, i0, i1, n) + class(phs_forest_t), intent(in) :: forest integer, intent(in) :: g integer, intent(out) :: i0, i1, n n = size (forest%grove(g)%tree) i0 = forest%grove(g)%tree_count_offset + 1 i1 = forest%grove(g)%tree_count_offset + n end subroutine phs_forest_get_grove_bounds @ %def phs_forest_get_grove_bounds @ Get the number of equivalences -<>= - public :: phs_forest_get_n_equivalences +<>= + procedure :: get_n_equivalences => phs_forest_get_n_equivalences +<>= + module function phs_forest_get_n_equivalences (forest) result (n) + integer :: n + class(phs_forest_t), intent(in) :: forest + end function phs_forest_get_n_equivalences <>= - function phs_forest_get_n_equivalences (forest) result (n) + module function phs_forest_get_n_equivalences (forest) result (n) integer :: n - type(phs_forest_t), intent(in) :: forest + class(phs_forest_t), intent(in) :: forest n = forest%n_equivalences end function phs_forest_get_n_equivalences @ %def phs_forest_get_n_equivalences @ Return true if a particular channel has a global (s-channel) mapping; also return the resonance mass and width for this mapping. -<>= - public :: phs_forest_get_s_mapping - public :: phs_forest_get_on_shell +<>= + procedure :: get_s_mapping => phs_forest_get_s_mapping + procedure :: get_on_shell => phs_forest_get_on_shell +<>= + module subroutine phs_forest_get_s_mapping & + (forest, channel, flag, mass, width) + class(phs_forest_t), intent(in) :: forest + integer, intent(in) :: channel + logical, intent(out) :: flag + real(default), intent(out) :: mass, width + end subroutine phs_forest_get_s_mapping + module subroutine phs_forest_get_on_shell (forest, channel, flag, mass) + class(phs_forest_t), intent(in) :: forest + integer, intent(in) :: channel + logical, intent(out) :: flag + real(default), intent(out) :: mass + end subroutine phs_forest_get_on_shell <>= - subroutine phs_forest_get_s_mapping (forest, channel, flag, mass, width) - type(phs_forest_t), intent(in) :: forest + module subroutine phs_forest_get_s_mapping & + (forest, channel, flag, mass, width) + class(phs_forest_t), intent(in) :: forest integer, intent(in) :: channel logical, intent(out) :: flag real(default), intent(out) :: mass, width - flag = mapping_is_s_channel (forest%s_mapping(channel)) + flag = forest%s_mapping(channel)%is_s_channel () if (flag) then - mass = mapping_get_mass (forest%s_mapping(channel)) - width = mapping_get_width (forest%s_mapping(channel)) + mass = forest%s_mapping(channel)%get_mass () + width = forest%s_mapping(channel)%get_width () else mass = 0 width = 0 end if end subroutine phs_forest_get_s_mapping - subroutine phs_forest_get_on_shell (forest, channel, flag, mass) - type(phs_forest_t), intent(in) :: forest + module subroutine phs_forest_get_on_shell (forest, channel, flag, mass) + class(phs_forest_t), intent(in) :: forest integer, intent(in) :: channel logical, intent(out) :: flag real(default), intent(out) :: mass - flag = mapping_is_on_shell (forest%s_mapping(channel)) + flag = forest%s_mapping(channel)%is_on_shell () if (flag) then - mass = mapping_get_mass (forest%s_mapping(channel)) + mass = forest%s_mapping(channel)%get_mass () else mass = 0 end if end subroutine phs_forest_get_on_shell @ %def phs_forest_get_s_mapping @ %def phs_forest_get_on_shell @ Extract the set of unique resonance histories, in form of an array. <>= procedure :: extract_resonance_history_set & => phs_forest_extract_resonance_history_set +<>= + module subroutine phs_forest_extract_resonance_history_set & + (forest, res_set, include_trivial) + class(phs_forest_t), intent(in) :: forest + type(resonance_history_set_t), intent(out) :: res_set + logical, intent(in), optional :: include_trivial + end subroutine phs_forest_extract_resonance_history_set <>= - subroutine phs_forest_extract_resonance_history_set & + module subroutine phs_forest_extract_resonance_history_set & (forest, res_set, include_trivial) class(phs_forest_t), intent(in) :: forest type(resonance_history_set_t), intent(out) :: res_set logical, intent(in), optional :: include_trivial type(resonance_history_t) :: rh integer :: g, t logical :: triv triv = .false.; if (present (include_trivial)) triv = include_trivial call res_set%init () do g = 1, size (forest%grove) associate (grove => forest%grove(g)) do t = 1, size (grove%tree) call grove%tree(t)%extract_resonance_history (rh) call res_set%enter (rh, include_trivial) end do end associate end do call res_set%freeze () end subroutine phs_forest_extract_resonance_history_set @ %def phs_forest_extract_resonance_history_set @ \subsection{Read the phase space setup from file} The phase space setup is stored in a file. The file may be generated by the [[cascades]] module below, or by other means. This file has to be read and parsed to create the PHS forest as the internal phase-space representation. Create lexer and syntax: <>= subroutine define_phs_forest_syntax (ifile) type(ifile_t) :: ifile call ifile_append (ifile, "SEQ phase_space_list = process_phase_space*") call ifile_append (ifile, "SEQ process_phase_space = " & // "process_def process_header phase_space") call ifile_append (ifile, "SEQ process_def = process process_list") call ifile_append (ifile, "KEY process") call ifile_append (ifile, "LIS process_list = process_tag*") call ifile_append (ifile, "IDE process_tag") call ifile_append (ifile, "SEQ process_header = " & // "md5sum_process = md5sum " & // "md5sum_model_par = md5sum " & // "md5sum_phs_config = md5sum " & // "sqrts = real " & // "m_threshold_s = real " & // "m_threshold_t = real " & // "off_shell = integer " & // "t_channel = integer " & // "keep_nonresonant = logical") call ifile_append (ifile, "KEY '='") call ifile_append (ifile, "KEY '-'") call ifile_append (ifile, "KEY md5sum_process") call ifile_append (ifile, "KEY md5sum_model_par") call ifile_append (ifile, "KEY md5sum_phs_config") call ifile_append (ifile, "KEY sqrts") call ifile_append (ifile, "KEY m_threshold_s") call ifile_append (ifile, "KEY m_threshold_t") call ifile_append (ifile, "KEY off_shell") call ifile_append (ifile, "KEY t_channel") call ifile_append (ifile, "KEY keep_nonresonant") call ifile_append (ifile, "QUO md5sum = '""' ... '""'") call ifile_append (ifile, "REA real") call ifile_append (ifile, "INT integer") call ifile_append (ifile, "IDE logical") call ifile_append (ifile, "SEQ phase_space = grove_def+") call ifile_append (ifile, "SEQ grove_def = grove tree_def+") call ifile_append (ifile, "KEY grove") call ifile_append (ifile, "SEQ tree_def = tree bincodes mapping*") call ifile_append (ifile, "KEY tree") call ifile_append (ifile, "SEQ bincodes = bincode*") call ifile_append (ifile, "INT bincode") call ifile_append (ifile, "SEQ mapping = map bincode channel signed_pdg") call ifile_append (ifile, "KEY map") call ifile_append (ifile, "ALT channel = & &s_channel | t_channel | u_channel | & &collinear | infrared | radiation | on_shell") call ifile_append (ifile, "KEY s_channel") ! call ifile_append (ifile, "KEY t_channel") !!! Key already exists call ifile_append (ifile, "KEY u_channel") call ifile_append (ifile, "KEY collinear") call ifile_append (ifile, "KEY infrared") call ifile_append (ifile, "KEY radiation") call ifile_append (ifile, "KEY on_shell") call ifile_append (ifile, "ALT signed_pdg = & &pdg | negative_pdg") call ifile_append (ifile, "SEQ negative_pdg = '-' pdg") call ifile_append (ifile, "INT pdg") end subroutine define_phs_forest_syntax @ %def define_phs_forest_syntax @ The model-file syntax and lexer are fixed, therefore stored as module variables: <>= type(syntax_t), target, save :: syntax_phs_forest @ %def syntax_phs_forest <>= public :: syntax_phs_forest_init +<>= + module subroutine syntax_phs_forest_init () + end subroutine syntax_phs_forest_init <>= - subroutine syntax_phs_forest_init () + module subroutine syntax_phs_forest_init () type(ifile_t) :: ifile call define_phs_forest_syntax (ifile) call syntax_init (syntax_phs_forest, ifile) call ifile_final (ifile) end subroutine syntax_phs_forest_init @ %def syntax_phs_forest_init <>= subroutine lexer_init_phs_forest (lexer) type(lexer_t), intent(out) :: lexer call lexer_init (lexer, & comment_chars = "#!", & quote_chars = '"', & quote_match = '"', & single_chars = "-", & special_class = ["="] , & keyword_list = syntax_get_keyword_list_ptr (syntax_phs_forest)) end subroutine lexer_init_phs_forest @ %def lexer_init_phs_forest <>= public :: syntax_phs_forest_final +<>= + module subroutine syntax_phs_forest_final () + end subroutine syntax_phs_forest_final <>= - subroutine syntax_phs_forest_final () + module subroutine syntax_phs_forest_final () call syntax_final (syntax_phs_forest) end subroutine syntax_phs_forest_final @ %def syntax_phs_forest_final <>= public :: syntax_phs_forest_write +<>= + module subroutine syntax_phs_forest_write (unit) + integer, intent(in), optional :: unit + end subroutine syntax_phs_forest_write <>= - subroutine syntax_phs_forest_write (unit) + module subroutine syntax_phs_forest_write (unit) integer, intent(in), optional :: unit call syntax_write (syntax_phs_forest, unit) end subroutine syntax_phs_forest_write @ %def syntax_phs_forest_write @ The concrete parser and interpreter. Generate an input stream for the external [[unit]], read the parse tree (with given [[syntax]] and [[lexer]]) from this stream, and transfer the contents of the parse tree to the PHS [[forest]]. We look for the matching [[process]] tag, count groves and trees for initializing the [[forest]], and fill the trees. If the optional parameters are set, compare the parameters stored in the file to those. Set [[match]] true if everything agrees. -<>= - public :: phs_forest_read -<>= - interface phs_forest_read - module procedure phs_forest_read_file - module procedure phs_forest_read_unit - module procedure phs_forest_read_parse_tree - end interface - +<>= + generic :: read => read_file, read_unit, read_parse_tree + procedure :: read_file => phs_forest_read_file + procedure :: read_unit => phs_forest_read_unit + procedure :: read_parse_tree => phs_forest_read_parse_tree +<>= + module subroutine phs_forest_read_file & + (forest, filename, process_id, n_in, n_out, model, found, & + md5sum_process, md5sum_model_par, & + md5sum_phs_config, phs_par, match) + class(phs_forest_t), intent(out) :: forest + type(string_t), intent(in) :: filename + type(string_t), intent(in) :: process_id + integer, intent(in) :: n_in, n_out + class(model_data_t), intent(in), target :: model + logical, intent(out) :: found + character(32), intent(in), optional :: & + md5sum_process, md5sum_model_par, md5sum_phs_config + type(phs_parameters_t), intent(in), optional :: phs_par + logical, intent(out), optional :: match + end subroutine phs_forest_read_file + module subroutine phs_forest_read_unit & + (forest, unit, process_id, n_in, n_out, model, found, & + md5sum_process, md5sum_model_par, md5sum_phs_config, & + phs_par, match) + class(phs_forest_t), intent(out) :: forest + integer, intent(in) :: unit + type(string_t), intent(in) :: process_id + integer, intent(in) :: n_in, n_out + class(model_data_t), intent(in), target :: model + logical, intent(out) :: found + character(32), intent(in), optional :: & + md5sum_process, md5sum_model_par, md5sum_phs_config + type(phs_parameters_t), intent(in), optional :: phs_par + logical, intent(out), optional :: match + end subroutine phs_forest_read_unit + module subroutine phs_forest_read_parse_tree & + (forest, parse_tree, process_id, n_in, n_out, model, found, & + md5sum_process, md5sum_model_par, md5sum_phs_config, & + phs_par, match) + class(phs_forest_t), intent(out) :: forest + type(parse_tree_t), intent(in), target :: parse_tree + type(string_t), intent(in) :: process_id + integer, intent(in) :: n_in, n_out + class(model_data_t), intent(in), target :: model + logical, intent(out) :: found + character(32), intent(in), optional :: & + md5sum_process, md5sum_model_par, md5sum_phs_config + type(phs_parameters_t), intent(in), optional :: phs_par + logical, intent(out), optional :: match + end subroutine phs_forest_read_parse_tree <>= - subroutine phs_forest_read_file & + module subroutine phs_forest_read_file & (forest, filename, process_id, n_in, n_out, model, found, & md5sum_process, md5sum_model_par, & md5sum_phs_config, phs_par, match) - type(phs_forest_t), intent(out) :: forest + class(phs_forest_t), intent(out) :: forest type(string_t), intent(in) :: filename type(string_t), intent(in) :: process_id integer, intent(in) :: n_in, n_out class(model_data_t), intent(in), target :: model logical, intent(out) :: found character(32), intent(in), optional :: & md5sum_process, md5sum_model_par, md5sum_phs_config type(phs_parameters_t), intent(in), optional :: phs_par logical, intent(out), optional :: match type(parse_tree_t), target :: parse_tree type(stream_t), target :: stream type(lexer_t) :: lexer call lexer_init_phs_forest (lexer) call stream_init (stream, char (filename)) call lexer_assign_stream (lexer, stream) call parse_tree_init (parse_tree, syntax_phs_forest, lexer) - call phs_forest_read (forest, parse_tree, & + call phs_forest_read_parse_tree (forest, parse_tree, & process_id, n_in, n_out, model, found, & md5sum_process, md5sum_model_par, md5sum_phs_config, phs_par, match) call stream_final (stream) call lexer_final (lexer) call parse_tree_final (parse_tree) end subroutine phs_forest_read_file - subroutine phs_forest_read_unit & + module subroutine phs_forest_read_unit & (forest, unit, process_id, n_in, n_out, model, found, & md5sum_process, md5sum_model_par, md5sum_phs_config, & phs_par, match) - type(phs_forest_t), intent(out) :: forest + class(phs_forest_t), intent(out) :: forest integer, intent(in) :: unit type(string_t), intent(in) :: process_id integer, intent(in) :: n_in, n_out class(model_data_t), intent(in), target :: model logical, intent(out) :: found character(32), intent(in), optional :: & md5sum_process, md5sum_model_par, md5sum_phs_config type(phs_parameters_t), intent(in), optional :: phs_par logical, intent(out), optional :: match type(parse_tree_t), target :: parse_tree type(stream_t), target :: stream type(lexer_t) :: lexer call lexer_init_phs_forest (lexer) call stream_init (stream, unit) call lexer_assign_stream (lexer, stream) call parse_tree_init (parse_tree, syntax_phs_forest, lexer) - call phs_forest_read (forest, parse_tree, & + call phs_forest_read_parse_tree (forest, parse_tree, & process_id, n_in, n_out, model, found, & md5sum_process, md5sum_model_par, md5sum_phs_config, & phs_par, match) call stream_final (stream) call lexer_final (lexer) call parse_tree_final (parse_tree) end subroutine phs_forest_read_unit - subroutine phs_forest_read_parse_tree & + module subroutine phs_forest_read_parse_tree & (forest, parse_tree, process_id, n_in, n_out, model, found, & md5sum_process, md5sum_model_par, md5sum_phs_config, & phs_par, match) - type(phs_forest_t), intent(out) :: forest + class(phs_forest_t), intent(out) :: forest type(parse_tree_t), intent(in), target :: parse_tree type(string_t), intent(in) :: process_id integer, intent(in) :: n_in, n_out class(model_data_t), intent(in), target :: model logical, intent(out) :: found character(32), intent(in), optional :: & md5sum_process, md5sum_model_par, md5sum_phs_config type(phs_parameters_t), intent(in), optional :: phs_par logical, intent(out), optional :: match type(parse_node_t), pointer :: node_header, node_phs, node_grove integer :: n_grove, g integer, dimension(:), allocatable :: n_tree integer :: t node_header => parse_tree_get_process_ptr (parse_tree, process_id) found = associated (node_header); if (.not. found) return if (present (match)) then call phs_forest_check_input (node_header, & md5sum_process, md5sum_model_par, md5sum_phs_config, phs_par, match) if (.not. match) return end if node_phs => parse_node_get_next_ptr (node_header) n_grove = parse_node_get_n_sub (node_phs) allocate (n_tree (n_grove)) do g = 1, n_grove node_grove => parse_node_get_sub_ptr (node_phs, g) n_tree(g) = parse_node_get_n_sub (node_grove) - 1 end do - call phs_forest_init (forest, n_tree, n_in, n_out) + call forest%init (n_tree, n_in, n_out) do g = 1, n_grove node_grove => parse_node_get_sub_ptr (node_phs, g) do t = 1, n_tree(g) call phs_tree_set (forest%grove(g)%tree(t), & parse_node_get_sub_ptr (node_grove, t+1), model) end do end do end subroutine phs_forest_read_parse_tree @ %def phs_forest @ Check the input for consistency. If any MD5 sum or phase-space parameter disagrees, the phase-space file cannot be used. The MD5 sum checks are skipped if the stored MD5 sum is empty. <>= subroutine phs_forest_check_input (pn_header, & md5sum_process, md5sum_model_par, md5sum_phs_config, phs_par, match) type(parse_node_t), intent(in), target :: pn_header character(32), intent(in) :: & md5sum_process, md5sum_model_par, md5sum_phs_config type(phs_parameters_t), intent(in), optional :: phs_par logical, intent(out) :: match type(parse_node_t), pointer :: pn_md5sum, pn_rval, pn_ival, pn_lval character(32) :: md5sum type(phs_parameters_t) :: phs_par_old character(1) :: lstr pn_md5sum => parse_node_get_sub_ptr (pn_header, 3) md5sum = parse_node_get_string (pn_md5sum) if (md5sum /= "" .and. md5sum /= md5sum_process) then call msg_message ("Phase space: discarding old configuration & &(process changed)") match = .false.; return end if pn_md5sum => parse_node_get_next_ptr (pn_md5sum, 3) md5sum = parse_node_get_string (pn_md5sum) if (md5sum /= "" .and. md5sum /= md5sum_model_par) then call msg_message ("Phase space: discarding old configuration & &(model parameters changed)") match = .false.; return end if pn_md5sum => parse_node_get_next_ptr (pn_md5sum, 3) md5sum = parse_node_get_string (pn_md5sum) if (md5sum /= "" .and. md5sum /= md5sum_phs_config) then call msg_message ("Phase space: discarding old configuration & &(configuration parameters changed)") match = .false.; return end if if (present (phs_par)) then pn_rval => parse_node_get_next_ptr (pn_md5sum, 3) phs_par_old%sqrts = parse_node_get_real (pn_rval) pn_rval => parse_node_get_next_ptr (pn_rval, 3) phs_par_old%m_threshold_s = parse_node_get_real (pn_rval) pn_rval => parse_node_get_next_ptr (pn_rval, 3) phs_par_old%m_threshold_t = parse_node_get_real (pn_rval) pn_ival => parse_node_get_next_ptr (pn_rval, 3) phs_par_old%off_shell = parse_node_get_integer (pn_ival) pn_ival => parse_node_get_next_ptr (pn_ival, 3) phs_par_old%t_channel = parse_node_get_integer (pn_ival) pn_lval => parse_node_get_next_ptr (pn_ival, 3) lstr = parse_node_get_string (pn_lval) read (lstr, "(L1)") phs_par_old%keep_nonresonant if (phs_par_old /= phs_par) then call msg_message & ("Phase space: discarding old configuration & &(configuration parameters changed)") match = .false.; return end if end if match = .true. end subroutine phs_forest_check_input @ %def phs_forest_check_input @ Initialize a specific tree in the forest, using the contents of the 'tree' node. First, count the bincodes, allocate an array and read them in, and make the tree. Each $t$-channel tree is flipped to $s$-channel. Then, find mappings and initialize them. <>= subroutine phs_tree_set (tree, node, model) type(phs_tree_t), intent(inout) :: tree type(parse_node_t), intent(in), target :: node class(model_data_t), intent(in), target :: model type(parse_node_t), pointer :: node_bincodes, node_mapping, pn_pdg integer :: n_bincodes, offset integer(TC), dimension(:), allocatable :: bincode integer :: b, n_mappings, m integer(TC) :: k type(string_t) :: type integer :: pdg node_bincodes => parse_node_get_sub_ptr (node, 2) if (associated (node_bincodes)) then select case (char (parse_node_get_rule_key (node_bincodes))) case ("bincodes") n_bincodes = parse_node_get_n_sub (node_bincodes) offset = 2 case default n_bincodes = 0 offset = 1 end select else n_bincodes = 0 offset = 2 end if allocate (bincode (n_bincodes)) do b = 1, n_bincodes bincode(b) = parse_node_get_integer & (parse_node_get_sub_ptr (node_bincodes, b)) end do call phs_tree_from_array (tree, bincode) - call phs_tree_flip_t_to_s_channel (tree) - call phs_tree_canonicalize (tree) + call tree%flip_t_to_s_channel () + call tree%canonicalize () n_mappings = parse_node_get_n_sub (node) - offset do m = 1, n_mappings node_mapping => parse_node_get_sub_ptr (node, m + offset) k = parse_node_get_integer & (parse_node_get_sub_ptr (node_mapping, 2)) type = parse_node_get_key & (parse_node_get_sub_ptr (node_mapping, 3)) pn_pdg => parse_node_get_sub_ptr (node_mapping, 4) select case (char (pn_pdg%get_rule_key ())) case ("pdg") pdg = pn_pdg%get_integer () case ("negative_pdg") pdg = - parse_node_get_integer (pn_pdg%get_sub_ptr (2)) end select - call phs_tree_init_mapping (tree, k, type, pdg, model) + call tree%init_mapping (k, type, pdg, model) end do end subroutine phs_tree_set @ %def phs_tree_set @ \subsection{Preparation} The trees that we read from file do not carry flavor information. This is set separately: The flavor list must be unique for a unique set of masses; if a given particle can have different flavor, the mass must be degenerate, so we can choose one of the possible flavor combinations. -<>= - public :: phs_forest_set_flavors +<>= + procedure :: set_flavors => phs_forest_set_flavors +<>= + module subroutine phs_forest_set_flavors (forest, flv, reshuffle, flv_extra) + class(phs_forest_t), intent(inout) :: forest + type(flavor_t), dimension(:), intent(in) :: flv + integer, intent(in), dimension(:), allocatable, optional :: reshuffle + type(flavor_t), intent(in), optional :: flv_extra + end subroutine phs_forest_set_flavors <>= - subroutine phs_forest_set_flavors (forest, flv, reshuffle, flv_extra) - type(phs_forest_t), intent(inout) :: forest + module subroutine phs_forest_set_flavors (forest, flv, reshuffle, flv_extra) + class(phs_forest_t), intent(inout) :: forest type(flavor_t), dimension(:), intent(in) :: flv integer, intent(in), dimension(:), allocatable, optional :: reshuffle type(flavor_t), intent(in), optional :: flv_extra integer :: i, n_flv0 if (present (reshuffle) .and. present (flv_extra)) then n_flv0 = size (flv) do i = 1, n_flv0 if (reshuffle(i) <= n_flv0) then forest%flv(i) = flv (reshuffle(i)) else forest%flv(i) = flv_extra end if end do else allocate (forest%flv (size (flv))) forest%flv = flv end if end subroutine phs_forest_set_flavors @ %def phs_forest_set_flavors @ -<>= - public :: phs_forest_set_momentum_links +<>= + procedure :: set_momentum_links => phs_forest_set_momentum_links +<>= + module subroutine phs_forest_set_momentum_links (forest, list) + class(phs_forest_t), intent(inout) :: forest + integer, intent(in), dimension(:), allocatable :: list + end subroutine phs_forest_set_momentum_links <>= - subroutine phs_forest_set_momentum_links (forest, list) - type(phs_forest_t), intent(inout) :: forest + module subroutine phs_forest_set_momentum_links (forest, list) + class(phs_forest_t), intent(inout) :: forest integer, intent(in), dimension(:), allocatable :: list integer :: g, t do g = 1, size (forest%grove) do t = 1, size (forest%grove(g)%tree) associate (tree => forest%grove(g)%tree(t)) call phs_tree_set_momentum_links (tree, list) -!!! call phs_tree_reshuffle_mappings (tree) + !!! call tree%reshuffle_mappings () end associate end do end do end subroutine phs_forest_set_momentum_links @ %def phs_forest_set_momentum_links @ Once the parameter set is fixed, the masses and the widths of the particles are known and the [[mass_sum]] arrays as well as the mapping parameters can be computed. Note that order is important: we first compute the mass sums, then the ordinary mappings. The resonances obtained here determine the effective masses, which in turn are used to implement step mappings for resonance decay products that are not mapped otherwise. -<>= - public :: phs_forest_set_parameters +<>= + procedure :: set_parameters => phs_forest_set_parameters +<>= + module subroutine phs_forest_set_parameters & + (forest, mapping_defaults, variable_limits) + class(phs_forest_t), intent(inout) :: forest + type(mapping_defaults_t), intent(in) :: mapping_defaults + logical, intent(in) :: variable_limits + end subroutine phs_forest_set_parameters <>= - subroutine phs_forest_set_parameters & + module subroutine phs_forest_set_parameters & (forest, mapping_defaults, variable_limits) - type(phs_forest_t), intent(inout) :: forest + class(phs_forest_t), intent(inout) :: forest type(mapping_defaults_t), intent(in) :: mapping_defaults logical, intent(in) :: variable_limits integer :: g, t do g = 1, size (forest%grove) do t = 1, size (forest%grove(g)%tree) - call phs_tree_set_mass_sum & - (forest%grove(g)%tree(t), forest%flv(forest%n_in+1:)) - call phs_tree_set_mapping_parameters (forest%grove(g)%tree(t), & - mapping_defaults, variable_limits) - call phs_tree_set_effective_masses (forest%grove(g)%tree(t)) + call forest%grove(g)%tree(t)%set_mass_sum (forest%flv(forest%n_in+1:)) + call forest%grove(g)%tree(t)%set_mapping_parameters & + (mapping_defaults, variable_limits) + call forest%grove(g)%tree(t)%set_effective_masses () if (mapping_defaults%step_mapping) then - call phs_tree_set_step_mappings (forest%grove(g)%tree(t), & - mapping_defaults%step_mapping_exp, variable_limits) + call forest%grove(g)%tree(t)%set_step_mappings & + (mapping_defaults%step_mapping_exp, variable_limits) end if end do end do end subroutine phs_forest_set_parameters @ %def phs_forest_set_parameters @ Generate the particle combination table. Scan all trees and merge their individual combination tables. At the end, valid entries are non-zero, and they indicate the indices of a pair of particles to be combined to a new particle. If a particle is accessible by more than one tree (this is usual), only keep the first possibility. -<>= - public :: phs_forest_setup_prt_combinations +<>= + procedure :: setup_prt_combinations => phs_forest_setup_prt_combinations +<>= + module subroutine phs_forest_setup_prt_combinations (forest) + class(phs_forest_t), intent(inout) :: forest + end subroutine phs_forest_setup_prt_combinations <>= - subroutine phs_forest_setup_prt_combinations (forest) - type(phs_forest_t), intent(inout) :: forest + module subroutine phs_forest_setup_prt_combinations (forest) + class(phs_forest_t), intent(inout) :: forest integer :: g, t integer, dimension(:,:), allocatable :: tree_prt_combination forest%prt_combination = 0 allocate (tree_prt_combination (2, size (forest%prt_combination, 2))) do g = 1, size (forest%grove) do t = 1, size (forest%grove(g)%tree) call phs_tree_setup_prt_combinations & (forest%grove(g)%tree(t), tree_prt_combination) where (tree_prt_combination /= 0 .and. forest%prt_combination == 0) forest%prt_combination = tree_prt_combination end where end do end do end subroutine phs_forest_setup_prt_combinations @ %def phs_forest_setup_prt_combinations @ \subsection{Accessing the particle arrays} Set the incoming particles from the contents of an interaction. -<>= - public :: phs_forest_set_prt_in -<>= - interface phs_forest_set_prt_in - module procedure phs_forest_set_prt_in_int, phs_forest_set_prt_in_mom - end interface phs_forest_set_prt_in +<>= + generic :: set_prt_in => set_prt_in_int, set_prt_in_mom + procedure :: set_prt_in_int => phs_forest_set_prt_in_int + procedure :: set_prt_in_mom => phs_forest_set_prt_in_mom +<>= + module subroutine phs_forest_set_prt_in_int (forest, int, lt_cm_to_lab) + class(phs_forest_t), intent(inout) :: forest + type(interaction_t), intent(in) :: int + type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab + end subroutine phs_forest_set_prt_in_int + module subroutine phs_forest_set_prt_in_mom (forest, mom, lt_cm_to_lab) + class(phs_forest_t), intent(inout) :: forest + type(vector4_t), dimension(size (forest%prt_in)), intent(in) :: mom + type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab + end subroutine phs_forest_set_prt_in_mom <>= - subroutine phs_forest_set_prt_in_int (forest, int, lt_cm_to_lab) - type(phs_forest_t), intent(inout) :: forest + module subroutine phs_forest_set_prt_in_int (forest, int, lt_cm_to_lab) + class(phs_forest_t), intent(inout) :: forest type(interaction_t), intent(in) :: int type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab if (present (lt_cm_to_lab)) then - call phs_prt_set_momentum (forest%prt_in, & - inverse (lt_cm_to_lab) * & + call forest%prt_in%set_momentum (inverse (lt_cm_to_lab) * & int%get_momenta (outgoing=.false.)) else - call phs_prt_set_momentum (forest%prt_in, & - int%get_momenta (outgoing=.false.)) + call forest%prt_in%set_momentum (int%get_momenta (outgoing=.false.)) end if associate (m_in => forest%flv(:forest%n_in)%get_mass ()) - call phs_prt_set_msq (forest%prt_in, m_in ** 2) + call forest%prt_in%set_msq (m_in ** 2) end associate - call phs_prt_set_defined (forest%prt_in) + call forest%prt_in%set_defined () end subroutine phs_forest_set_prt_in_int - subroutine phs_forest_set_prt_in_mom (forest, mom, lt_cm_to_lab) - type(phs_forest_t), intent(inout) :: forest + module subroutine phs_forest_set_prt_in_mom (forest, mom, lt_cm_to_lab) + class(phs_forest_t), intent(inout) :: forest type(vector4_t), dimension(size (forest%prt_in)), intent(in) :: mom type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab if (present (lt_cm_to_lab)) then - call phs_prt_set_momentum (forest%prt_in, & - inverse (lt_cm_to_lab) * mom) + call forest%prt_in%set_momentum (inverse (lt_cm_to_lab) * mom) else - call phs_prt_set_momentum (forest%prt_in, mom) + call forest%prt_in%set_momentum (mom) end if associate (m_in => forest%flv(:forest%n_in)%get_mass ()) - call phs_prt_set_msq (forest%prt_in, m_in ** 2) + call forest%prt_in%set_msq (m_in ** 2) end associate - call phs_prt_set_defined (forest%prt_in) + call forest%prt_in%set_defined () end subroutine phs_forest_set_prt_in_mom @ %def phs_forest_set_prt_in @ Set the outgoing particles from the contents of an interaction. -<>= - public :: phs_forest_set_prt_out -<>= - interface phs_forest_set_prt_out - module procedure phs_forest_set_prt_out_int, phs_forest_set_prt_out_mom - end interface phs_forest_set_prt_out +<>= + generic :: set_prt_out => set_prt_out_int, set_prt_out_mom + procedure :: set_prt_out_int => phs_forest_set_prt_out_int + procedure :: set_prt_out_mom => phs_forest_set_prt_out_mom +<>= + module subroutine phs_forest_set_prt_out_int (forest, int, lt_cm_to_lab) + class(phs_forest_t), intent(inout) :: forest + type(interaction_t), intent(in) :: int + type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab + end subroutine phs_forest_set_prt_out_int + module subroutine phs_forest_set_prt_out_mom (forest, mom, lt_cm_to_lab) + class(phs_forest_t), intent(inout) :: forest + type(vector4_t), dimension(size (forest%prt_out)), intent(in) :: mom + type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab + end subroutine phs_forest_set_prt_out_mom <>= - subroutine phs_forest_set_prt_out_int (forest, int, lt_cm_to_lab) - type(phs_forest_t), intent(inout) :: forest + module subroutine phs_forest_set_prt_out_int (forest, int, lt_cm_to_lab) + class(phs_forest_t), intent(inout) :: forest type(interaction_t), intent(in) :: int type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab if (present (lt_cm_to_lab)) then - call phs_prt_set_momentum (forest%prt_out, & - inverse (lt_cm_to_lab) * & + call forest%prt_out%set_momentum (inverse (lt_cm_to_lab) * & int%get_momenta (outgoing=.true.)) else - call phs_prt_set_momentum (forest%prt_out, & - int%get_momenta (outgoing=.true.)) + call forest%prt_out%set_momentum (int%get_momenta (outgoing=.true.)) end if associate (m_out => forest%flv(forest%n_in+1:)%get_mass ()) - call phs_prt_set_msq (forest%prt_out, m_out ** 2) + call forest%prt_out%set_msq (m_out ** 2) end associate - call phs_prt_set_defined (forest%prt_out) + call forest%prt_out%set_defined () end subroutine phs_forest_set_prt_out_int - subroutine phs_forest_set_prt_out_mom (forest, mom, lt_cm_to_lab) - type(phs_forest_t), intent(inout) :: forest + module subroutine phs_forest_set_prt_out_mom (forest, mom, lt_cm_to_lab) + class(phs_forest_t), intent(inout) :: forest type(vector4_t), dimension(size (forest%prt_out)), intent(in) :: mom type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab if (present (lt_cm_to_lab)) then - call phs_prt_set_momentum (forest%prt_out, & - inverse (lt_cm_to_lab) * mom) + call forest%prt_out%set_momentum (inverse (lt_cm_to_lab) * mom) else - call phs_prt_set_momentum (forest%prt_out, mom) + call forest%prt_out%set_momentum (mom) end if associate (m_out => forest%flv(forest%n_in+1:)%get_mass ()) - call phs_prt_set_msq (forest%prt_out, m_out ** 2) + call forest%prt_out%set_msq (m_out ** 2) end associate - call phs_prt_set_defined (forest%prt_out) + call forest%prt_out%set_defined () end subroutine phs_forest_set_prt_out_mom @ %def phs_forest_set_prt_out @ Combine particles as described by the particle combination table. Particle momentum sums will be calculated only if the resulting particle is contained in at least one of the trees in the current forest. The others are kept undefined. -<>= - public :: phs_forest_combine_particles +<>= + procedure :: combine_particles => phs_forest_combine_particles +<>= + module subroutine phs_forest_combine_particles (forest) + class(phs_forest_t), intent(inout) :: forest + end subroutine phs_forest_combine_particles <>= - subroutine phs_forest_combine_particles (forest) - type(phs_forest_t), intent(inout) :: forest + module subroutine phs_forest_combine_particles (forest) + class(phs_forest_t), intent(inout) :: forest integer :: k integer, dimension(2) :: kk do k = 1, size (forest%prt_combination, 2) kk = forest%prt_combination(:,k) if (kk(1) /= 0) then - call phs_prt_combine (forest%prt(k), & - forest%prt(kk(1)), forest%prt(kk(2))) + call forest%prt(k)%combine (forest%prt(kk(1)), forest%prt(kk(2))) end if end do end subroutine phs_forest_combine_particles @ %def phs_forest_combine_particles @ Extract the outgoing particles and insert into an interaction. -<>= - public :: phs_forest_get_prt_out +<>= + procedure :: get_prt_out => phs_forest_get_prt_out +<>= + module subroutine phs_forest_get_prt_out (forest, int, lt_cm_to_lab) + class(phs_forest_t), intent(in) :: forest + type(interaction_t), intent(inout) :: int + type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab + end subroutine phs_forest_get_prt_out <>= - subroutine phs_forest_get_prt_out (forest, int, lt_cm_to_lab) - type(phs_forest_t), intent(in) :: forest + module subroutine phs_forest_get_prt_out (forest, int, lt_cm_to_lab) + class(phs_forest_t), intent(in) :: forest type(interaction_t), intent(inout) :: int type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab if (present (lt_cm_to_lab)) then call int%set_momenta (lt_cm_to_lab * & - phs_prt_get_momentum (forest%prt_out), outgoing=.true.) + forest%prt_out%get_momentum (), outgoing=.true.) else - call int%set_momenta (phs_prt_get_momentum (forest%prt_out), & + call int%set_momenta (forest%prt_out%get_momentum (), & outgoing=.true.) end if end subroutine phs_forest_get_prt_out @ %def phs_forest_get_prt_out @ Extract the outgoing particle momenta -<>= - public :: phs_forest_get_momenta_out +<>= + procedure :: get_momenta_out => phs_forest_get_momenta_out +<>= + module function phs_forest_get_momenta_out (forest, lt_cm_to_lab) result (p) + class(phs_forest_t), intent(in) :: forest + type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab + type(vector4_t), dimension(size (forest%prt_out)) :: p + end function phs_forest_get_momenta_out <>= - function phs_forest_get_momenta_out (forest, lt_cm_to_lab) result (p) - type(phs_forest_t), intent(in) :: forest + module function phs_forest_get_momenta_out (forest, lt_cm_to_lab) result (p) + class(phs_forest_t), intent(in) :: forest type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab type(vector4_t), dimension(size (forest%prt_out)) :: p - p = phs_prt_get_momentum (forest%prt_out) + p = forest%prt_out%get_momentum () if (present (lt_cm_to_lab)) p = p * lt_cm_to_lab end function phs_forest_get_momenta_out @ %def phs_forest_get_momenta_out @ \subsection{Find equivalences among phase-space trees} Scan phase space for equivalences. We generate the complete set of unique permutations for the given list of outgoing particles, and use this for scanning equivalences within each grove. @ We scan all pairs of trees, using all permutations. This implies that trivial equivalences are included, and equivalences between different trees are recorded twice. This is intentional. <>= subroutine phs_grove_set_equivalences (grove, perm_array) type(phs_grove_t), intent(inout) :: grove type(permutation_t), dimension(:), intent(in) :: perm_array type(equivalence_t), pointer :: eq integer :: t1, t2, i do t1 = 1, size (grove%tree) do t2 = 1, size (grove%tree) SCAN_PERM: do i = 1, size (perm_array) if (phs_tree_equivalent & (grove%tree(t1), grove%tree(t2), perm_array(i))) then call equivalence_list_add & (grove%equivalence_list, t1, t2, perm_array(i)) eq => grove%equivalence_list%last call phs_tree_find_msq_permutation & (grove%tree(t1), grove%tree(t2), eq%perm, & eq%msq_perm) call phs_tree_find_angle_permutation & (grove%tree(t1), grove%tree(t2), eq%perm, & eq%angle_perm, eq%angle_sig) end if end do SCAN_PERM end do end do end subroutine phs_grove_set_equivalences @ %def phs_grove_set_equivalences -<>= - public :: phs_forest_set_equivalences +<>= + procedure :: set_equivalences => phs_forest_set_equivalences +<>= + module subroutine phs_forest_set_equivalences (forest) + class(phs_forest_t), intent(inout) :: forest + end subroutine phs_forest_set_equivalences <>= - subroutine phs_forest_set_equivalences (forest) - type(phs_forest_t), intent(inout) :: forest + module subroutine phs_forest_set_equivalences (forest) + class(phs_forest_t), intent(inout) :: forest type(permutation_t), dimension(:), allocatable :: perm_array integer :: i call permutation_array_make & (perm_array, forest%flv(forest%n_in+1:)%get_pdg ()) do i = 1, size (forest%grove) call phs_grove_set_equivalences (forest%grove(i), perm_array) end do forest%n_equivalences = sum (forest%grove%equivalence_list%length) end subroutine phs_forest_set_equivalences @ %def phs_forest_set_equivalences @ \subsection{Interface for channel equivalences} Here, we store the equivalence list in the appropriate containers that the [[phs_base]] module provides. There is one separate list for each channel. -<>= - public :: phs_forest_get_equivalences +<>= + procedure :: get_equivalences => phs_forest_get_equivalences +<>= + module subroutine phs_forest_get_equivalences & + (forest, channel, azimuthal_dependence) + class(phs_forest_t), intent(in) :: forest + type(phs_channel_t), dimension(:), intent(out) :: channel + logical, intent(in) :: azimuthal_dependence + end subroutine phs_forest_get_equivalences <>= - subroutine phs_forest_get_equivalences (forest, channel, azimuthal_dependence) - type(phs_forest_t), intent(in) :: forest + module subroutine phs_forest_get_equivalences & + (forest, channel, azimuthal_dependence) + class(phs_forest_t), intent(in) :: forest type(phs_channel_t), dimension(:), intent(out) :: channel logical, intent(in) :: azimuthal_dependence integer :: n_masses, n_angles integer :: mode_azimuthal_angle integer, dimension(:), allocatable :: n_eq type(equivalence_t), pointer :: eq integer, dimension(:), allocatable :: perm, mode integer :: g, c, j, left, right n_masses = forest%n_masses n_angles = forest%n_angles allocate (n_eq (forest%n_trees), source = 0) allocate (perm (forest%n_dimensions)) allocate (mode (forest%n_dimensions), source = EQ_IDENTITY) do g = 1, size (forest%grove) eq => forest%grove(g)%equivalence_list%first do while (associated (eq)) left = eq%left + forest%grove(g)%tree_count_offset n_eq(left) = n_eq(left) + 1 eq => eq%next end do end do do c = 1, size (channel) allocate (channel(c)%eq (n_eq(c))) do j = 1, n_eq(c) call channel(c)%eq(j)%init (forest%n_dimensions) end do end do n_eq = 0 if (azimuthal_dependence) then mode_azimuthal_angle = EQ_IDENTITY else mode_azimuthal_angle = EQ_INVARIANT end if do g = 1, size (forest%grove) eq => forest%grove(g)%equivalence_list%first do while (associated (eq)) left = eq%left + forest%grove(g)%tree_count_offset right = eq%right + forest%grove(g)%tree_count_offset do j = 1, n_masses perm(j) = permute (j, eq%msq_perm) mode(j) = EQ_IDENTITY end do do j = 1, n_angles perm(n_masses+j) = n_masses + permute (j, eq%angle_perm) if (j == 1) then mode(n_masses+j) = mode_azimuthal_angle ! first az. angle else if (mod(j,2) == 1) then mode(n_masses+j) = EQ_SYMMETRIC ! other az. angles else if (eq%angle_sig(j)) then mode(n_masses+j) = EQ_IDENTITY ! polar angle + else mode(n_masses+j) = EQ_INVERT ! polar angle - end if end do n_eq(left) = n_eq(left) + 1 associate (eq_cur => channel(left)%eq(n_eq(left))) eq_cur%c = right eq_cur%perm = perm eq_cur%mode = mode end associate eq => eq%next end do end do end subroutine phs_forest_get_equivalences @ %def phs_forest_get_equivalences @ \subsection{Phase-space evaluation} Given one row of the [[x]] parameter array and the corresponding channel index, compute first all relevant momenta and then recover the remainder of the [[x]] array, the Jacobians [[phs_factor]], and the phase-space [[volume]]. The output argument [[ok]] indicates whether this was successful. -<>= - public :: phs_forest_evaluate_selected_channel +<>= + procedure :: evaluate_selected_channel => phs_forest_evaluate_selected_channel +<>= + module subroutine phs_forest_evaluate_selected_channel & + (forest, channel, active, sqrts, x, phs_factor, volume, ok) + class(phs_forest_t), intent(inout) :: forest + integer, intent(in) :: channel + logical, dimension(:), intent(in) :: active + real(default), intent(in) :: sqrts + real(default), dimension(:,:), intent(inout) :: x + real(default), dimension(:), intent(out) :: phs_factor + real(default), intent(out) :: volume + logical, intent(out) :: ok + end subroutine phs_forest_evaluate_selected_channel <>= - subroutine phs_forest_evaluate_selected_channel & + module subroutine phs_forest_evaluate_selected_channel & (forest, channel, active, sqrts, x, phs_factor, volume, ok) - type(phs_forest_t), intent(inout) :: forest + class(phs_forest_t), intent(inout) :: forest integer, intent(in) :: channel logical, dimension(:), intent(in) :: active real(default), intent(in) :: sqrts real(default), dimension(:,:), intent(inout) :: x real(default), dimension(:), intent(out) :: phs_factor real(default), intent(out) :: volume logical, intent(out) :: ok integer :: g, t integer(TC) :: k, k_root, k_in g = forest%grove_lookup (channel) t = channel - forest%grove(g)%tree_count_offset - call phs_prt_set_undefined (forest%prt) - call phs_prt_set_undefined (forest%prt_out) + call forest%prt%set_undefined () + call forest%prt_out%set_undefined () k_in = forest%n_tot do k = 1,forest%n_in forest%prt(ibset(0,k_in-k)) = forest%prt_in(k) end do do k = 1, forest%n_out - call phs_prt_set_msq (forest%prt(ibset(0,k-1)), & - forest%flv(forest%n_in+k)%get_mass () ** 2) + call forest%prt(ibset(0,k-1))%set_msq & + (forest%flv(forest%n_in+k)%get_mass () ** 2) end do k_root = 2**forest%n_out - 1 select case (forest%n_in) case (1) forest%prt(k_root) = forest%prt_in(1) case (2) - call phs_prt_combine & - (forest%prt(k_root), forest%prt_in(1), forest%prt_in(2)) + call forest%prt(k_root)%combine (forest%prt_in(1), forest%prt_in(2)) end select - call phs_tree_compute_momenta_from_x (forest%grove(g)%tree(t), & - forest%prt, phs_factor(channel), volume, sqrts, x(:,channel), ok) + call forest%grove(g)%tree(t)%compute_momenta_from_x (forest%prt, & + phs_factor(channel), volume, sqrts, x(:,channel), ok) if (ok) then do k = 1, forest%n_out forest%prt_out(k) = forest%prt(ibset(0,k-1)) end do end if end subroutine phs_forest_evaluate_selected_channel @ %def phs_forest_evaluate_selected_channel @ The remainder: recover $x$ values for all channels except for the current channel. NOTE: OpenMP not used for the first loop. [[combine_particles]] is not a channel-local operation. -<>= - public :: phs_forest_evaluate_other_channels +<>= + procedure :: evaluate_other_channels => phs_forest_evaluate_other_channels +<>= + module subroutine phs_forest_evaluate_other_channels & + (forest, channel, active, sqrts, x, phs_factor, combine) + class(phs_forest_t), intent(inout) :: forest + integer, intent(in) :: channel + logical, dimension(:), intent(in) :: active + real(default), intent(in) :: sqrts + real(default), dimension(:,:), intent(inout) :: x + real(default), dimension(:), intent(inout) :: phs_factor + logical, intent(in) :: combine + end subroutine phs_forest_evaluate_other_channels <>= - subroutine phs_forest_evaluate_other_channels & + module subroutine phs_forest_evaluate_other_channels & (forest, channel, active, sqrts, x, phs_factor, combine) - type(phs_forest_t), intent(inout) :: forest + class(phs_forest_t), intent(inout) :: forest integer, intent(in) :: channel logical, dimension(:), intent(in) :: active real(default), intent(in) :: sqrts real(default), dimension(:,:), intent(inout) :: x real(default), dimension(:), intent(inout) :: phs_factor logical, intent(in) :: combine integer :: g, t, ch, n_channel g = forest%grove_lookup (channel) t = channel - forest%grove(g)%tree_count_offset n_channel = forest%n_trees if (combine) then do ch = 1, n_channel if (ch == channel) cycle if (active(ch)) then g = forest%grove_lookup(ch) t = ch - forest%grove(g)%tree_count_offset call phs_tree_combine_particles & (forest%grove(g)%tree(t), forest%prt) end if end do end if !OMP PARALLEL PRIVATE (g,t,ch) SHARED(active,forest,sqrts,x,channel) !OMP DO SCHEDULE(STATIC) do ch = 1, n_channel if (ch == channel) cycle if (active(ch)) then g = forest%grove_lookup(ch) t = ch - forest%grove(g)%tree_count_offset - call phs_tree_compute_x_from_momenta & - (forest%grove(g)%tree(t), & - forest%prt, phs_factor(ch), sqrts, x(:,ch)) + call forest%grove(g)%tree(t)%compute_x_from_momenta (forest%prt, & + phs_factor(ch), sqrts, x(:,ch)) end if end do !OMP END DO !OMP END PARALLEL end subroutine phs_forest_evaluate_other_channels @ %def phs_forest_evaluate_other_channels @ The complement: recover one row of the [[x]] array and the associated Jacobian entry, corresponding to [[channel]], from incoming and outgoing momenta. Also compute the phase-space volume. -<>= - public :: phs_forest_recover_channel +<>= + procedure :: recover_channel => phs_forest_recover_channel +<>= + module subroutine phs_forest_recover_channel & + (forest, channel, sqrts, x, phs_factor, volume) + class(phs_forest_t), intent(inout) :: forest + integer, intent(in) :: channel + real(default), intent(in) :: sqrts + real(default), dimension(:,:), intent(inout) :: x + real(default), dimension(:), intent(inout) :: phs_factor + real(default), intent(out) :: volume + end subroutine phs_forest_recover_channel <>= - subroutine phs_forest_recover_channel & + module subroutine phs_forest_recover_channel & (forest, channel, sqrts, x, phs_factor, volume) - type(phs_forest_t), intent(inout) :: forest + class(phs_forest_t), intent(inout) :: forest integer, intent(in) :: channel real(default), intent(in) :: sqrts real(default), dimension(:,:), intent(inout) :: x real(default), dimension(:), intent(inout) :: phs_factor real(default), intent(out) :: volume integer :: g, t integer(TC) :: k, k_in g = forest%grove_lookup (channel) t = channel - forest%grove(g)%tree_count_offset - call phs_prt_set_undefined (forest%prt) + call forest%prt%set_undefined () k_in = forest%n_tot forall (k = 1:forest%n_in) forest%prt(ibset(0,k_in-k)) = forest%prt_in(k) end forall forall (k = 1:forest%n_out) forest%prt(ibset(0,k-1)) = forest%prt_out(k) end forall - call phs_forest_combine_particles (forest) - call phs_tree_compute_volume & - (forest%grove(g)%tree(t), sqrts, volume) - call phs_tree_compute_x_from_momenta & - (forest%grove(g)%tree(t), & - forest%prt, phs_factor(channel), sqrts, x(:,channel)) + call forest%combine_particles () + call forest%grove(g)%tree(t)%compute_volume (sqrts, volume) + call forest%grove(g)%tree(t)%compute_x_from_momenta (forest%prt, & + phs_factor(channel), sqrts, x(:,channel)) end subroutine phs_forest_recover_channel @ %def phs_forest_recover_channel @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[phs_forests_ut.f90]]>>= <> module phs_forests_ut use unit_tests use phs_forests_uti <> <> contains <> end module phs_forests_ut @ %def phs_forests_ut @ <<[[phs_forests_uti.f90]]>>= <> module phs_forests_uti <> <> use io_units use format_defs, only: FMT_12 use lorentz use flavors use interactions use model_data use mappings use phs_base use resonances, only: resonance_history_set_t use phs_forests <> <> contains <> end module phs_forests_uti @ %def phs_forests_ut @ API: driver for the unit tests below. <>= public :: phs_forests_test <>= subroutine phs_forests_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine phs_forests_test @ %def phs_forests_test @ \subsubsection{Basic universal test} Write a possible phase-space file for a $2\to 3$ process and make the corresponding forest, print the forest. Choose some in-particle momenta and a random-number array and evaluate out-particles and phase-space factors. <>= call test (phs_forest_1, "phs_forest_1", & "check phs forest setup", & u, results) <>= public :: phs_forest_1 <>= subroutine phs_forest_1 (u) use os_interface integer, intent(in) :: u type(phs_forest_t) :: forest type(phs_channel_t), dimension(:), allocatable :: channel type(model_data_t), target :: model type(string_t) :: process_id type(flavor_t), dimension(5) :: flv type(string_t) :: filename type(interaction_t) :: int integer :: unit_fix type(mapping_defaults_t) :: mapping_defaults logical :: found_process, ok integer :: n_channel, ch, i logical, dimension(4) :: active = .true. real(default) :: sqrts = 1000 real(default), dimension(5,4) :: x real(default), dimension(4) :: factor real(default) :: volume write (u, "(A)") "* Test output: PHS forest" write (u, "(A)") "* Purpose: test PHS forest routines" write (u, "(A)") write (u, "(A)") "* Reading model file" call model%init_sm_test () write (u, "(A)") write (u, "(A)") "* Create phase-space file 'phs_forest_test.phs'" write (u, "(A)") call flv%init ([11, -11, 11, -11, 22], model) unit_fix = free_unit () open (file="phs_forest_test.phs", unit=unit_fix, action="write") write (unit_fix, *) "process foo" write (unit_fix, *) 'md5sum_process = "6ABA33BC2927925D0F073B1C1170780A"' write (unit_fix, *) 'md5sum_model_par = "1A0B151EE6E2DEB92D880320355A3EAB"' write (unit_fix, *) 'md5sum_phs_config = "B6A8877058809A8BDD54753CDAB83ACE"' write (unit_fix, *) "sqrts = 100.00000000000000" write (unit_fix, *) "m_threshold_s = 50.000000000000000" write (unit_fix, *) "m_threshold_t = 100.00000000000000" write (unit_fix, *) "off_shell = 2" write (unit_fix, *) "t_channel = 6" write (unit_fix, *) "keep_nonresonant = F" write (unit_fix, *) "" write (unit_fix, *) " grove" write (unit_fix, *) " tree 3 7" write (unit_fix, *) " map 3 s_channel 23" write (unit_fix, *) " tree 5 7" write (unit_fix, *) " tree 6 7" write (unit_fix, *) " grove" write (unit_fix, *) " tree 9 11" write (unit_fix, *) " map 9 t_channel 22" close (unit_fix) write (u, "(A)") write (u, "(A)") "* Read phase-space file 'phs_forest_test.phs'" call syntax_phs_forest_init () process_id = "foo" filename = "phs_forest_test.phs" - call phs_forest_read & - (forest, filename, process_id, 2, 3, model, found_process) + call forest%read (filename, process_id, 2, 3, model, found_process) write (u, "(A)") write (u, "(A)") "* Set parameters, flavors, equiv, momenta" write (u, "(A)") - call phs_forest_set_flavors (forest, flv) - call phs_forest_set_parameters (forest, mapping_defaults, .false.) - call phs_forest_setup_prt_combinations (forest) - call phs_forest_set_equivalences (forest) + call forest%set_flavors (flv) + call forest%set_parameters (mapping_defaults, .false.) + call forest%setup_prt_combinations () + call forest%set_equivalences () call int%basic_init (2, 0, 3) call int%set_momentum & (vector4_moving (500._default, 500._default, 3), 1) call int%set_momentum & (vector4_moving (500._default,-500._default, 3), 2) - call phs_forest_set_prt_in (forest, int) + call forest%set_prt_in (int) n_channel = 2 x = 0 x(:,n_channel) = [0.3, 0.4, 0.1, 0.9, 0.6] write (u, "(A)") " Input values:" write (u, "(3x,5(1x," // FMT_12 // "))") x(:,n_channel) write (u, "(A)") write (u, "(A)") "* Evaluating phase space" - call phs_forest_evaluate_selected_channel (forest, & - n_channel, active, sqrts, x, factor, volume, ok) - call phs_forest_evaluate_other_channels (forest, & - n_channel, active, sqrts, x, factor, combine=.true.) - call phs_forest_get_prt_out (forest, int) + call forest%evaluate_selected_channel (n_channel, active, sqrts, & + x, factor, volume, ok) + call forest%evaluate_other_channels (n_channel, active, sqrts, & + x, factor, combine=.true.) + call forest%get_prt_out (int) write (u, "(A)") " Output values:" do ch = 1, 4 write (u, "(3x,5(1x," // FMT_12 // "))") x(:,ch) end do call int%basic_write (u) write (u, "(A)") " Factors:" write (u, "(3x,5(1x," // FMT_12 // "))") factor write (u, "(A)") " Volume:" write (u, "(3x,5(1x," // FMT_12 // "))") volume - call phs_forest_write (forest, u) + call forest%write (u) write (u, "(A)") write (u, "(A)") "* Compute equivalences" n_channel = 4 allocate (channel (n_channel)) - call phs_forest_get_equivalences (forest, & - channel, .true.) + call forest%get_equivalences (channel, .true.) do i = 1, n_channel write (u, "(1x,I0,':')", advance = "no") ch call channel(i)%write (u) end do write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () - call phs_forest_final (forest) + call forest%final () call syntax_phs_forest_final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_forest_1" end subroutine phs_forest_1 @ %def phs_forest_1 @ \subsubsection{Resonance histories} Read a suitably nontrivial forest from file and recover the set of resonance histories. <>= call test (phs_forest_2, "phs_forest_2", & "handle phs forest resonance content", & u, results) <>= public :: phs_forest_2 <>= subroutine phs_forest_2 (u) use os_interface integer, intent(in) :: u integer :: unit_fix type(phs_forest_t) :: forest type(model_data_t), target :: model type(string_t) :: process_id type(string_t) :: filename logical :: found_process type(resonance_history_set_t) :: res_set integer :: i write (u, "(A)") "* Test output: phs_forest_2" write (u, "(A)") "* Purpose: test PHS forest routines" write (u, "(A)") write (u, "(A)") "* Reading model file" call model%init_sm_test () write (u, "(A)") write (u, "(A)") "* Create phase-space file 'phs_forest_2.phs'" write (u, "(A)") unit_fix = free_unit () open (file="phs_forest_2.phs", unit=unit_fix, action="write") write (unit_fix, *) "process foo" write (unit_fix, *) 'md5sum_process = "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"' write (unit_fix, *) 'md5sum_model_par = "1A0B151EE6E2DEB92D880320355A3EAB"' write (unit_fix, *) 'md5sum_phs_config = "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"' write (unit_fix, *) "sqrts = 100.00000000000000" write (unit_fix, *) "m_threshold_s = 50.000000000000000" write (unit_fix, *) "m_threshold_t = 100.00000000000000" write (unit_fix, *) "off_shell = 2" write (unit_fix, *) "t_channel = 6" write (unit_fix, *) "keep_nonresonant = F" write (unit_fix, *) "" write (unit_fix, *) " grove" write (unit_fix, *) " tree 3 7" write (unit_fix, *) " tree 3 7" write (unit_fix, *) " map 3 s_channel -24" write (unit_fix, *) " tree 5 7" write (unit_fix, *) " tree 3 7" write (unit_fix, *) " map 3 s_channel -24" write (unit_fix, *) " map 7 s_channel 23" write (unit_fix, *) " tree 5 7" write (unit_fix, *) " map 7 s_channel 25" write (unit_fix, *) " tree 3 11" write (unit_fix, *) " map 3 s_channel -24" close (unit_fix) write (u, "(A)") "* Read phase-space file 'phs_forest_2.phs'" call syntax_phs_forest_init () process_id = "foo" filename = "phs_forest_2.phs" - call phs_forest_read & - (forest, filename, process_id, 2, 3, model, found_process) + call forest%read (filename, process_id, 2, 3, model, found_process) write (u, "(A)") write (u, "(A)") "* Extract resonance history set" write (u, "(A)") call forest%extract_resonance_history_set (res_set) call res_set%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () - call phs_forest_final (forest) + call forest%final () call syntax_phs_forest_final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_forest_2" end subroutine phs_forest_2 @ %def phs_forest_2 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Finding phase space parameterizations} If the phase space configuration is not found in the appropriate file, we should generate one. The idea is to construct all Feynman diagrams subject to certain constraints which eliminate everything that is probably irrelevant for the integration. These Feynman diagrams (cascades) are grouped in groves by finding equivalence classes related by symmetry and ordered with respect to their importance (resonances). Finally, the result (or part of it) is written to file and used for the integration. This module may eventually disappear and be replaced by CAML code. In particular, we need here a set of Feynman rules (vertices with particle codes, but not the factors). Thus, the module works for the Standard Model only. Note that this module is stand-alone, it communicates to the main program only via the generated ASCII phase-space configuration file. <<[[cascades.f90]]>>= <> module cascades <> use kinds, only: TC, i8, i32 <> <> - use io_units - use constants, only: one - use format_defs, only: FMT_12, FMT_19 - use numeric_utils - use diagnostics - use hashes - use sorting use physics_defs, only: SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR use physics_defs, only: UNDEFINED use model_data use flavors - use lorentz use resonances, only: resonance_info_t use resonances, only: resonance_history_t use resonances, only: resonance_history_set_t use phs_forests <> <> <> <> <> + interface +<> + end interface + +end module cascades +@ %def cascades +@ +<<[[cascades_sub.f90]]>>= +<> + +submodule (cascades) cascades_s + + use io_units + use constants, only: one + use format_defs, only: FMT_12, FMT_19 + use numeric_utils + use diagnostics + use hashes + use sorting + use lorentz + + implicit none + contains <> -end module cascades -@ %def cascades +end submodule cascades_s + +@ %def cascades_s @ \subsection{The mapping modes} The valid mapping modes, to be used below. We will make use of the convention that mappings of internal particles have a positive value. Only for positive values, the flavor code is propagated when combining cascades. <>= integer, parameter :: & & EXTERNAL_PRT = -1, & & NO_MAPPING = 0, S_CHANNEL = 1, T_CHANNEL = 2, U_CHANNEL = 3, & & RADIATION = 4, COLLINEAR = 5, INFRARED = 6, & & STEP_MAPPING_E = 11, STEP_MAPPING_H = 12, & & ON_SHELL = 99 @ %def EXTERNAL_PRT @ %def NO_MAPPING S_CHANNEL T_CHANNEL U_CHANNEL @ %def RADIATION COLLINEAR INFRARED @ %def STEP_MAPPING_E STEP_MAPPING_H @ %def ON_SHELL <>= <> @ \subsection{The cascade type} A cascade is essentially the same as a decay tree (both definitions may be merged in a later version). It contains a linked tree of nodes, each of which representing an internal particle. In contrast to decay trees, each node has a definite particle code. These nodes need not be modified, therefore we can use pointers and do not have to copy them. Thus, physically each cascades has only a single node, the mother particle. However, to be able to compare trees quickly, we store in addition an array of binary codes which is always sorted in ascending order. This is accompanied by a corresponding list of particle codes. The index is the location of the corresponding cascade in the cascade set, this may be used to access the daughters directly. The real mass is the particle mass belonging to the particle code. The minimal mass is the sum of the real masses of all its daughters; this is the kinematical cutoff. The effective mass may be zero if the particle mass is below a certain threshold; it may be the real mass if the particle is resonant; or it may be some other value. The logical [[t_channel]] is set if this a $t$-channel line, while [[initial]] is true only for an initial particle. Note that both initial particles are also [[t_channel]] by definition, and that they are distinguished by the direction of the tree: One of them decays and is the root of the tree, while the other one is one of the leaves. The cascade is a list of nodes (particles) which are linked via the [[daughter]] entries. The node is the mother particle of the decay cascade. Much of the information in the nodes is repeated in arrays, to be accessible more easily. The arrays will be kept sorted by binary codes. The counter [[n_off_shell]] is increased for each internal line that is neither resonant nor log-enhanced. It is set to zero if the current line is resonant, since this implies on-shell particle production and subsequent decay. The counter [[n_t_channel]] is non-negative once an initial particle is included in the tree: then, it counts the number of $t$-channel lines. The [[multiplicity]] is the number of branchings to follow until all daughters are on-shell. A resonant or non-decaying particle has multiplicity one. Merging nodes, the multiplicities add unless the mother is a resonance. An initial or final node has multiplicity zero. The arrays correspond to the subnode tree [[tree]] of the current cascade. PDG codes are stored only for those positions which are resonant, with the exception of the last entry, i.e., the current node. Other positions, in particular external legs, are assigned undefined PDG code. A cascade is uniquely identified by its tree, the tree of PDG codes, and the tree of mappings. The tree of resonances is kept only to mask the PDG tree as described above. <>= type :: cascade_t private ! counters integer :: index = 0 integer :: grove = 0 ! status logical :: active = .false. logical :: complete = .false. logical :: incoming = .false. ! this node integer(TC) :: bincode = 0 type(flavor_t) :: flv integer :: pdg = UNDEFINED logical :: is_vector = .false. real(default) :: m_min = 0 real(default) :: m_rea = 0 real(default) :: m_eff = 0 integer :: mapping = NO_MAPPING logical :: on_shell = .false. logical :: resonant = .false. logical :: log_enhanced = .false. logical :: t_channel = .false. ! global tree properties integer :: multiplicity = 0 integer :: internal = 0 integer :: n_off_shell = 0 integer :: n_resonances = 0 integer :: n_log_enhanced = 0 integer :: n_t_channel = 0 integer :: res_hash = 0 ! the sub-node tree integer :: depth = 0 integer(TC), dimension(:), allocatable :: tree integer, dimension(:), allocatable :: tree_pdg integer, dimension(:), allocatable :: tree_mapping logical, dimension(:), allocatable :: tree_resonant ! branch connections logical :: has_children = .false. type(cascade_t), pointer :: daughter1 => null () type(cascade_t), pointer :: daughter2 => null () type(cascade_t), pointer :: mother => null () ! next in list type(cascade_t), pointer :: next => null () contains <> end type cascade_t @ %def cascade_t <>= subroutine cascade_init (cascade, depth) type(cascade_t), intent(out) :: cascade integer, intent(in) :: depth integer, save :: index = 0 index = cascade_index () cascade%index = index cascade%depth = depth cascade%active = .true. allocate (cascade%tree (depth)) allocate (cascade%tree_pdg (depth)) allocate (cascade%tree_mapping (depth)) allocate (cascade%tree_resonant (depth)) end subroutine cascade_init @ %def cascade_init @ Keep and increment a global index <>= function cascade_index (seed) result (index) integer :: index integer, intent(in), optional :: seed integer, save :: i = 0 if (present (seed)) i = seed i = i + 1 index = i end function cascade_index @ %def cascade_index @ We need three versions of writing cascades. This goes to the phase-space file. For t/u channel mappings, we use the absolute value of the PDG code. <>= subroutine cascade_write_file_format (cascade, model, unit) type(cascade_t), intent(in) :: cascade class(model_data_t), intent(in), target :: model integer, intent(in), optional :: unit type(flavor_t) :: flv integer :: u, i 2 format(3x,A,1x,I3,1x,A,1x,I9,1x,'!',1x,A) u = given_output_unit (unit); if (u < 0) return call write_reduced (cascade%tree, u) write (u, "(A)") do i = 1, cascade%depth call flv%init (cascade%tree_pdg(i), model) select case (cascade%tree_mapping(i)) case (NO_MAPPING, EXTERNAL_PRT) case (S_CHANNEL) write(u,2) 'map', & cascade%tree(i), 's_channel', cascade%tree_pdg(i), & char (flv%get_name ()) case (T_CHANNEL) write(u,2) 'map', & cascade%tree(i), 't_channel', abs (cascade%tree_pdg(i)), & char (flv%get_name ()) case (U_CHANNEL) write(u,2) 'map', & cascade%tree(i), 'u_channel', abs (cascade%tree_pdg(i)), & char (flv%get_name ()) case (RADIATION) write(u,2) 'map', & cascade%tree(i), 'radiation', cascade%tree_pdg(i), & char (flv%get_name ()) case (COLLINEAR) write(u,2) 'map', & cascade%tree(i), 'collinear', cascade%tree_pdg(i), & char (flv%get_name ()) case (INFRARED) write(u,2) 'map', & cascade%tree(i), 'infrared ', cascade%tree_pdg(i), & char (flv%get_name ()) case (ON_SHELL) write(u,2) 'map', & cascade%tree(i), 'on_shell ', cascade%tree_pdg(i), & char (flv%get_name ()) case default call msg_bug (" Impossible mapping mode encountered") end select end do contains subroutine write_reduced (array, unit) integer(TC), dimension(:), intent(in) :: array integer, intent(in) :: unit integer :: i write (u, "(3x,A,1x)", advance="no") "tree" do i = 1, size (array) if (decay_level (array(i)) > 1) then write (u, "(1x,I0)", advance="no") array(i) end if end do end subroutine write_reduced elemental function decay_level (k) result (l) integer(TC), intent(in) :: k integer :: l integer :: i l = 0 do i = 0, bit_size(k) - 1 if (btest(k,i)) l = l + 1 end do end function decay_level subroutine start_comment (u) integer, intent(in) :: u write(u, '(1x,A)', advance='no') '!' end subroutine start_comment end subroutine cascade_write_file_format @ %def cascade_write_file_format @ This creates metapost source for graphical display: <>= subroutine cascade_write_graph_format (cascade, count, unit) type(cascade_t), intent(in) :: cascade integer, intent(in) :: count integer, intent(in), optional :: unit integer :: u integer(TC) :: mask type(string_t) :: left_str, right_str u = given_output_unit (unit); if (u < 0) return mask = 2**((cascade%depth+3)/2) - 1 left_str = "" right_str = "" write (u, '(A)') "\begin{minipage}{105pt}" write (u, '(A)') "\vspace{30pt}" write (u, '(A)') "\begin{center}" write (u, '(A)') "\begin{fmfgraph*}(55,55)" call graph_write (cascade, mask) write (u, '(A)') "\fmfleft{" // char (extract (left_str, 2)) // "}" write (u, '(A)') "\fmfright{" // char (extract (right_str, 2)) // "}" write (u, '(A)') "\end{fmfgraph*}\\" write (u, '(A,I5,A)') "\fbox{$", count, "$}" write (u, '(A)') "\end{center}" write (u, '(A)') "\end{minipage}" write (u, '(A)') "%" contains recursive subroutine graph_write (cascade, mask, reverse) type(cascade_t), intent(in) :: cascade integer(TC), intent(in) :: mask logical, intent(in), optional :: reverse type(flavor_t) :: anti logical :: rev rev = .false.; if (present(reverse)) rev = reverse if (cascade%has_children) then if (.not.rev) then call vertex_write (cascade, cascade%daughter1, mask) call vertex_write (cascade, cascade%daughter2, mask) else call vertex_write (cascade, cascade%daughter2, mask, .true.) call vertex_write (cascade, cascade%daughter1, mask, .true.) end if if (cascade%complete) then call vertex_write (cascade, cascade%mother, mask, .true.) write (u, '(A,I0,A)') "\fmfv{d.shape=square}{v0}" end if else if (cascade%incoming) then anti = cascade%flv%anti () call external_write (cascade%bincode, anti%get_tex_name (), & left_str) else call external_write (cascade%bincode, cascade%flv%get_tex_name (), & right_str) end if end if end subroutine graph_write recursive subroutine vertex_write (cascade, daughter, mask, reverse) type(cascade_t), intent(in) :: cascade, daughter integer(TC), intent(in) :: mask logical, intent(in), optional :: reverse integer :: bincode if (cascade%complete) then bincode = 0 else bincode = cascade%bincode end if call graph_write (daughter, mask, reverse) if (daughter%has_children) then call line_write (bincode, daughter%bincode, daughter%flv, & mapping=daughter%mapping) else call line_write (bincode, daughter%bincode, daughter%flv) end if end subroutine vertex_write subroutine line_write (i1, i2, flv, mapping) integer(TC), intent(in) :: i1, i2 type(flavor_t), intent(in) :: flv integer, intent(in), optional :: mapping integer :: k1, k2 type(string_t) :: prt_type select case (flv%get_spin_type ()) case (SCALAR); prt_type = "plain" case (SPINOR); prt_type = "fermion" case (VECTOR); prt_type = "boson" case (VECTORSPINOR); prt_type = "fermion" case (TENSOR); prt_type = "dbl_wiggly" case default; prt_type = "dashes" end select if (flv%is_antiparticle ()) then k1 = i2; k2 = i1 else k1 = i1; k2 = i2 end if if (present (mapping)) then select case (mapping) case (S_CHANNEL) write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & & ",f=blue,lab=\sm\blue$" // & & char (flv%get_tex_name ()) // "$}" // & & "{v", k1, ",v", k2, "}" case (T_CHANNEL, U_CHANNEL) write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & & ",f=cyan,lab=\sm\cyan$" // & & char (flv%get_tex_name ()) // "$}" // & & "{v", k1, ",v", k2, "}" case (RADIATION) write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & & ",f=green,lab=\sm\green$" // & & char (flv%get_tex_name ()) // "$}" // & & "{v", k1, ",v", k2, "}" case (COLLINEAR) write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & & ",f=magenta,lab=\sm\magenta$" // & & char (flv%get_tex_name ()) // "$}" // & & "{v", k1, ",v", k2, "}" case (INFRARED) write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & & ",f=red,lab=\sm\red$" // & & char (flv%get_tex_name ()) // "$}" // & & "{v", k1, ",v", k2, "}" case default write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & & ",f=black}" // & & "{v", k1, ",v", k2, "}" end select else write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & & "}" // & & "{v", k1, ",v", k2, "}" end if end subroutine line_write subroutine external_write (bincode, name, ext_str) integer(TC), intent(in) :: bincode type(string_t), intent(in) :: name type(string_t), intent(inout) :: ext_str character(len=20) :: str write (str, '(A2,I0)') ",v", bincode ext_str = ext_str // trim (str) write (u, '(A,I0,A,I0,A)') "\fmflabel{\sm$" & // char (name) & // "\,(", bincode, ")" & // "$}{v", bincode, "}" end subroutine external_write end subroutine cascade_write_graph_format @ %def cascade_write_graph_format @ This is for screen/debugging output: <>= subroutine cascade_write (cascade, unit) type(cascade_t), intent(in) :: cascade integer, intent(in), optional :: unit integer :: u character(9) :: depth u = given_output_unit (unit); if (u < 0) return write (u, "(A,(1x,I7))") 'Cascade #', cascade%index write (u, "(A,(1x,I7))") ' Grove: #', cascade%grove write (u, "(A,3(1x,L1))") ' act/cmp/inc: ', & cascade%active, cascade%complete, cascade%incoming write (u, "(A,I0)") ' Bincode: ', cascade%bincode write (u, "(A)", advance="no") ' Flavor: ' call cascade%flv%write (unit) write (u, "(A,I9)") ' Active flavor:', cascade%pdg write (u, "(A,L1)") ' Is vector: ', cascade%is_vector write (u, "(A,3(1x," // FMT_19 // "))") ' Mass (m/r/e): ', & cascade%m_min, cascade%m_rea, cascade%m_eff write (u, "(A,I1)") ' Mapping: ', cascade%mapping write (u, "(A,3(1x,L1))") ' res/log/tch: ', & cascade%resonant, cascade%log_enhanced, cascade%t_channel write (u, "(A,(1x,I7))") ' Multiplicity: ', cascade%multiplicity write (u, "(A,2(1x,I7))") ' n intern/off: ', & cascade%internal, cascade%n_off_shell write (u, "(A,3(1x,I7))") ' n res/log/tch:', & cascade%n_resonances, cascade%n_log_enhanced, cascade%n_t_channel write (u, "(A,I7)") ' Depth: ', cascade%depth write (depth, "(I7)") cascade%depth write (u, "(A," // depth // "(1x,I7))") & ' Tree: ', cascade%tree write (u, "(A," // depth // "(1x,I7))") & ' Tree(PDG): ', cascade%tree_pdg write (u, "(A," // depth // "(1x,I7))") & ' Tree(mapping):', cascade%tree_mapping write (u, "(A," // depth // "(1x,L1))") & ' Tree(res): ', cascade%tree_resonant if (cascade%has_children) then write (u, "(A,I7,1x,I7)") ' Daughter1/2: ', & cascade%daughter1%index, cascade%daughter2%index end if if (associated (cascade%mother)) then write (u, "(A,I7)") ' Mother: ', cascade%mother%index end if end subroutine cascade_write @ %def cascade_write @ \subsection{Creating new cascades} This initializes a single-particle cascade (external, final state). The PDG entry in the tree is set undefined because the cascade is not resonant. However, the flavor entry is set, so the cascade flavor is identified nevertheless. <>= subroutine cascade_init_outgoing (cascade, flv, pos, m_thr) type(cascade_t), intent(out) :: cascade type(flavor_t), intent(in) :: flv integer, intent(in) :: pos real(default), intent(in) :: m_thr call cascade_init (cascade, 1) cascade%bincode = ibset (0_TC, pos-1) cascade%flv = flv cascade%pdg = cascade%flv%get_pdg () cascade%is_vector = flv%get_spin_type () == VECTOR cascade%m_min = flv%get_mass () cascade%m_rea = cascade%m_min if (cascade%m_rea >= m_thr) then cascade%m_eff = cascade%m_rea end if cascade%on_shell = .true. cascade%multiplicity = 1 cascade%tree(1) = cascade%bincode cascade%tree_pdg(1) = cascade%pdg cascade%tree_mapping(1) = EXTERNAL_PRT cascade%tree_resonant(1) = .false. end subroutine cascade_init_outgoing @ %def cascade_init_outgoing @ The same for an incoming line: <>= subroutine cascade_init_incoming (cascade, flv, pos, m_thr) type(cascade_t), intent(out) :: cascade type(flavor_t), intent(in) :: flv integer, intent(in) :: pos real(default), intent(in) :: m_thr call cascade_init (cascade, 1) cascade%incoming = .true. cascade%bincode = ibset (0_TC, pos-1) cascade%flv = flv%anti () cascade%pdg = cascade%flv%get_pdg () cascade%is_vector = flv%get_spin_type () == VECTOR cascade%m_min = flv%get_mass () cascade%m_rea = cascade%m_min if (cascade%m_rea >= m_thr) then cascade%m_eff = cascade%m_rea end if cascade%on_shell = .true. cascade%n_t_channel = 0 cascade%n_off_shell = 0 cascade%tree(1) = cascade%bincode cascade%tree_pdg(1) = cascade%pdg cascade%tree_mapping(1) = EXTERNAL_PRT cascade%tree_resonant(1) = .false. end subroutine cascade_init_incoming @ %def cascade_init_outgoing @ \subsection{Tools} This function returns true if the two cascades share no common external particle. This is a requirement for joining them. <>= interface operator(.disjunct.) module procedure cascade_disjunct end interface +<>= + module function cascade_disjunct (cascade1, cascade2) result (flag) + logical :: flag + type(cascade_t), intent(in) :: cascade1, cascade2 + end function cascade_disjunct <>= - function cascade_disjunct (cascade1, cascade2) result (flag) + module function cascade_disjunct (cascade1, cascade2) result (flag) logical :: flag type(cascade_t), intent(in) :: cascade1, cascade2 flag = iand (cascade1%bincode, cascade2%bincode) == 0 end function cascade_disjunct @ %def cascade_disjunct @ %def .disjunct. @ Compute a hash code for the resonance pattern of a cascade. We count the number of times each particle appears as a resonance. We pack the PDG codes of the resonances in two arrays (s-channel and t-channel), sort them both, concatenate the results, transfer to [[i8]] integers, and compute the hash code from this byte stream. For t/u-channel, we remove the sign for antiparticles since this is not well-defined. <>= subroutine cascade_assign_resonance_hash (cascade) type(cascade_t), intent(inout) :: cascade integer(i8), dimension(1) :: mold cascade%res_hash = hash (transfer & ([sort (pack (cascade%tree_pdg, & cascade%tree_resonant)), & sort (pack (abs (cascade%tree_pdg), & cascade%tree_mapping == T_CHANNEL .or. & cascade%tree_mapping == U_CHANNEL))], & mold)) end subroutine cascade_assign_resonance_hash @ %def cascade_assign_resonance_hash @ \subsection{Hash entries for cascades} We will set up a hash array which contains keys of and pointers to cascades. We hold a list of cascade (pointers) within each bucket. This is not for collision resolution, but for keeping similar, but unequal cascades together. <>= type :: cascade_p type(cascade_t), pointer :: cascade => null () type(cascade_p), pointer :: next => null () end type cascade_p @ %def cascade_p @ Here is the bucket or hash entry type: <>= type :: hash_entry_t integer(i32) :: hashval = 0 integer(i8), dimension(:), allocatable :: key type(cascade_p), pointer :: first => null () type(cascade_p), pointer :: last => null () end type hash_entry_t @ %def hash_entry_t <>= public :: hash_entry_init +<>= + module subroutine hash_entry_init (entry, entry_in) + type(hash_entry_t), intent(out) :: entry + type(hash_entry_t), intent(in) :: entry_in + end subroutine hash_entry_init <>= - subroutine hash_entry_init (entry, entry_in) + module subroutine hash_entry_init (entry, entry_in) type(hash_entry_t), intent(out) :: entry type(hash_entry_t), intent(in) :: entry_in type(cascade_p), pointer :: casc_iter, casc_copy entry%hashval = entry_in%hashval entry%key = entry_in%key casc_iter => entry_in%first do while (associated (casc_iter)) allocate (casc_copy) casc_copy = casc_iter casc_copy%next => null () if (associated (entry%first)) then entry%last%next => casc_copy else entry%first => casc_copy end if entry%last => casc_copy casc_iter => casc_iter%next end do end subroutine hash_entry_init @ %def hash_entry_init @ Finalize: just deallocate the list; the contents are just pointers. <>= subroutine hash_entry_final (hash_entry) type(hash_entry_t), intent(inout) :: hash_entry type(cascade_p), pointer :: current do while (associated (hash_entry%first)) current => hash_entry%first hash_entry%first => current%next deallocate (current) end do end subroutine hash_entry_final @ %def hash_entry_final @ Output: concise format for debugging, just list cascade indices. <>= subroutine hash_entry_write (hash_entry, unit) type(hash_entry_t), intent(in) :: hash_entry integer, intent(in), optional :: unit type(cascade_p), pointer :: current integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)", advance="no") "Entry:" do i = 1, size (hash_entry%key) write (u, "(1x,I0)", advance="no") hash_entry%key(i) end do write (u, "(1x,A)", advance="no") "->" current => hash_entry%first do while (associated (current)) write (u, "(1x,I7)", advance="no") current%cascade%index current => current%next end do write (u, *) end subroutine hash_entry_write @ %def hash_entry_write @ This function adds a cascade pointer to the bucket. If [[ok]] is present, check first if it is already there and return failure if yes. If [[cascade_ptr]] is also present, set it to the current cascade if successful. If not, set it to the cascade that is already there. <>= subroutine hash_entry_add_cascade_ptr (hash_entry, cascade, ok, cascade_ptr) type(hash_entry_t), intent(inout) :: hash_entry type(cascade_t), intent(in), target :: cascade logical, intent(out), optional :: ok type(cascade_t), optional, pointer :: cascade_ptr type(cascade_p), pointer :: current if (present (ok)) then call hash_entry_check_cascade (hash_entry, cascade, ok, cascade_ptr) if (.not. ok) return end if allocate (current) current%cascade => cascade if (associated (hash_entry%last)) then hash_entry%last%next => current else hash_entry%first => current end if hash_entry%last => current end subroutine hash_entry_add_cascade_ptr @ %def hash_entry_add_cascade_ptr @ This function checks whether a cascade is already in the bucket. For incomplete cascades, we look for an exact match. It should suffice to verify the tree, the PDG codes, and the mapping modes. This is the information that is written to the phase space file. For complete cascades, we ignore the PDG code at positions with mappings infrared, collinear, or t/u-channel. Thus a cascade which is distinguished only by PDG code at such places, is flagged existent. If the convention is followed that light particles come before heavier ones (in the model definition), this ensures that the lightest particle is kept in the appropriate place, corresponding to the strongest peak. For external cascades (incoming/outgoing) we take the PDG code into account even though it is zeroed in the PDG-code tree. <>= subroutine hash_entry_check_cascade (hash_entry, cascade, ok, cascade_ptr) type(hash_entry_t), intent(in), target :: hash_entry type(cascade_t), intent(in), target :: cascade logical, intent(out) :: ok type(cascade_t), optional, pointer :: cascade_ptr type(cascade_p), pointer :: current integer, dimension(:), allocatable :: tree_pdg ok = .true. allocate (tree_pdg (size (cascade%tree_pdg))) if (cascade%complete) then where (cascade%tree_mapping == INFRARED .or. & cascade%tree_mapping == COLLINEAR .or. & cascade%tree_mapping == T_CHANNEL .or. & cascade%tree_mapping == U_CHANNEL) tree_pdg = 0 elsewhere tree_pdg = cascade%tree_pdg end where else tree_pdg = cascade%tree_pdg end if current => hash_entry%first do while (associated (current)) if (current%cascade%depth == cascade%depth) then if (all (current%cascade%tree == cascade%tree)) then if (all (current%cascade%tree_mapping == cascade%tree_mapping)) & then if (all (current%cascade%tree_pdg .match. tree_pdg)) then if (present (cascade_ptr)) cascade_ptr => current%cascade ok = .false.; return end if end if end if end if current => current%next end do if (present (cascade_ptr)) cascade_ptr => cascade end subroutine hash_entry_check_cascade @ %def hash_entry_check_cascade @ For PDG codes, we specify that the undefined code matches any code. This is already defined for flavor objects, but here we need it for the codes themselves. <>= interface operator(.match.) module procedure pdg_match end interface +<>= + elemental module function pdg_match (pdg1, pdg2) result (flag) + logical :: flag + integer(TC), intent(in) :: pdg1, pdg2 + end function pdg_match <>= - elemental function pdg_match (pdg1, pdg2) result (flag) + elemental module function pdg_match (pdg1, pdg2) result (flag) logical :: flag integer(TC), intent(in) :: pdg1, pdg2 select case (pdg1) case (0) flag = .true. case default select case (pdg2) case (0) flag = .true. case default flag = pdg1 == pdg2 end select end select end function pdg_match @ %def .match. @ \subsection{The cascade set} The cascade set will later be transformed into the decay forest. It is set up as a linked list. In addition to the usual [[first]] and [[last]] pointers, there is a [[first_t]] pointer which points to the first t-channel cascade (after all s-channel cascades), and a [[first_k]] pointer which points to the first final cascade (with a keystone). As an auxiliary device, the object contains a hash array with associated parameters where an additional pointer is stored for each cascade. The keys are made from the relevant cascade data. This hash is used for fast detection (and thus avoidance) of double entries in the cascade list. <>= public :: cascade_set_t <>= type :: cascade_set_t private class(model_data_t), pointer :: model integer :: n_in, n_out, n_tot type(flavor_t), dimension(:,:), allocatable :: flv integer :: depth_out, depth_tot real(default) :: sqrts = 0 real(default) :: m_threshold_s = 0 real(default) :: m_threshold_t = 0 integer :: off_shell = 0 integer :: t_channel = 0 logical :: keep_nonresonant integer :: n_groves = 0 ! The cascade list type(cascade_t), pointer :: first => null () type(cascade_t), pointer :: last => null () type(cascade_t), pointer :: first_t => null () type(cascade_t), pointer :: first_k => null () ! The hashtable integer :: n_entries = 0 real :: fill_ratio = 0 integer :: n_entries_max = 0 integer(i32) :: mask = 0 logical :: fatal_beam_decay = .true. type(hash_entry_t), dimension(:), allocatable :: entry end type cascade_set_t @ %def cascade_set_t @ <>= interface cascade_set_init module procedure cascade_set_init_base module procedure cascade_set_init_from_cascade end interface @ %def cascade_set_init @ This might be broken. Test before using. +<>= + module subroutine cascade_set_init_from_cascade & + (cascade_set, cascade_set_in) + type(cascade_set_t), intent(out) :: cascade_set + type(cascade_set_t), intent(in), target :: cascade_set_in + end subroutine cascade_set_init_from_cascade <>= - subroutine cascade_set_init_from_cascade (cascade_set, cascade_set_in) + module subroutine cascade_set_init_from_cascade & + (cascade_set, cascade_set_in) type(cascade_set_t), intent(out) :: cascade_set type(cascade_set_t), intent(in), target :: cascade_set_in type(cascade_t), pointer :: casc_iter, casc_copy cascade_set%model => cascade_set_in%model cascade_set%n_in = cascade_set_in%n_in cascade_set%n_out = cascade_set_in%n_out cascade_set%n_tot = cascade_set_in%n_tot cascade_set%flv = cascade_set_in%flv cascade_set%depth_out = cascade_set_in%depth_out cascade_set%depth_tot = cascade_set_in%depth_tot cascade_set%sqrts = cascade_set_in%sqrts cascade_set%m_threshold_s = cascade_set_in%m_threshold_s cascade_set%m_threshold_t = cascade_set_in%m_threshold_t cascade_set%off_shell = cascade_set_in%off_shell cascade_set%t_channel = cascade_set_in%t_channel cascade_set%keep_nonresonant = cascade_set_in%keep_nonresonant cascade_set%n_groves = cascade_set_in%n_groves casc_iter => cascade_set_in%first do while (associated (casc_iter)) allocate (casc_copy) casc_copy = casc_iter casc_copy%next => null () if (associated (cascade_set%first)) then cascade_set%last%next => casc_copy else cascade_set%first => casc_copy end if cascade_set%last => casc_copy casc_iter => casc_iter%next end do cascade_set%n_entries = cascade_set_in%n_entries cascade_set%fill_ratio = cascade_set_in%fill_ratio cascade_set%n_entries_max = cascade_set_in%n_entries_max cascade_set%mask = cascade_set_in%mask cascade_set%fatal_beam_decay = cascade_set_in%fatal_beam_decay allocate (cascade_set%entry (0:cascade_set%mask)) cascade_set%entry = cascade_set_in%entry end subroutine cascade_set_init_from_cascade @ %def cascade_set_init_from_cascade @ Return true if there are cascades which are active and complete, so the phase space file would be nonempty. <>= public :: cascade_set_is_valid +<>= + module function cascade_set_is_valid (cascade_set) result (flag) + logical :: flag + type(cascade_set_t), intent(in) :: cascade_set + end function cascade_set_is_valid <>= - function cascade_set_is_valid (cascade_set) result (flag) + module function cascade_set_is_valid (cascade_set) result (flag) logical :: flag type(cascade_set_t), intent(in) :: cascade_set type(cascade_t), pointer :: cascade flag = .false. cascade => cascade_set%first_k do while (associated (cascade)) if (cascade%active .and. cascade%complete) then flag = .true. return end if cascade => cascade%next end do end function cascade_set_is_valid @ %def cascade_set_is_valid @ The initializer sets up the hash table with some initial size guessed by looking at the number of external particles. We choose 256 for 3 external particles and a factor of 4 for each additional particle, limited at $2^{30}$=1G. <>= real, parameter, public :: CASCADE_SET_FILL_RATIO = 0.1 +<>= + module subroutine cascade_set_init_base (cascade_set, model, & + n_in, n_out, phs_par, fatal_beam_decay, flv) + type(cascade_set_t), intent(out) :: cascade_set + class(model_data_t), intent(in), target :: model + integer, intent(in) :: n_in, n_out + type(phs_parameters_t), intent(in) :: phs_par + logical, intent(in) :: fatal_beam_decay + type(flavor_t), dimension(:,:), intent(in), optional :: flv + end subroutine cascade_set_init_base <>= - subroutine cascade_set_init_base (cascade_set, model, n_in, n_out, phs_par, & - fatal_beam_decay, flv) + module subroutine cascade_set_init_base (cascade_set, model, & + n_in, n_out, phs_par, fatal_beam_decay, flv) type(cascade_set_t), intent(out) :: cascade_set class(model_data_t), intent(in), target :: model integer, intent(in) :: n_in, n_out type(phs_parameters_t), intent(in) :: phs_par logical, intent(in) :: fatal_beam_decay type(flavor_t), dimension(:,:), intent(in), optional :: flv integer :: size_guess integer :: i, j cascade_set%model => model cascade_set%n_in = n_in cascade_set%n_out = n_out cascade_set%n_tot = n_in + n_out if (present (flv)) then allocate (cascade_set%flv (size (flv, 1), size (flv, 2))) do i = 1, size (flv, 2) do j = 1, size (flv, 1) call cascade_set%flv(j,i)%init (flv(j,i)%get_pdg (), model) end do end do end if select case (n_in) case (1); cascade_set%depth_out = 2 * n_out - 3 case (2); cascade_set%depth_out = 2 * n_out - 1 end select cascade_set%depth_tot = 2 * cascade_set%n_tot - 3 cascade_set%sqrts = phs_par%sqrts cascade_set%m_threshold_s = phs_par%m_threshold_s cascade_set%m_threshold_t = phs_par%m_threshold_t cascade_set%off_shell = phs_par%off_shell cascade_set%t_channel = phs_par%t_channel cascade_set%keep_nonresonant = phs_par%keep_nonresonant cascade_set%fill_ratio = CASCADE_SET_FILL_RATIO size_guess = ishft (256, min (2 * (cascade_set%n_tot - 3), 22)) cascade_set%n_entries_max = size_guess * cascade_set%fill_ratio cascade_set%mask = size_guess - 1 allocate (cascade_set%entry (0:cascade_set%mask)) cascade_set%fatal_beam_decay = fatal_beam_decay end subroutine cascade_set_init_base @ %def cascade_set_init_base @ The finalizer has to delete both the hash and the list. <>= public :: cascade_set_final +<>= + module subroutine cascade_set_final (cascade_set) + type(cascade_set_t), intent(inout), target :: cascade_set + end subroutine cascade_set_final <>= - subroutine cascade_set_final (cascade_set) + module subroutine cascade_set_final (cascade_set) type(cascade_set_t), intent(inout), target :: cascade_set type(cascade_t), pointer :: current integer :: i if (allocated (cascade_set%entry)) then do i = 0, cascade_set%mask call hash_entry_final (cascade_set%entry(i)) end do deallocate (cascade_set%entry) end if do while (associated (cascade_set%first)) current => cascade_set%first cascade_set%first => cascade_set%first%next deallocate (current) end do end subroutine cascade_set_final @ %def cascade_set_final @ Write the process in ASCII format, in columns that are headed by the corresponding bincode. <>= public :: cascade_set_write_process_bincode_format +<>= + module subroutine cascade_set_write_process_bincode_format & + (cascade_set, unit) + type(cascade_set_t), intent(in), target :: cascade_set + integer, intent(in), optional :: unit + end subroutine cascade_set_write_process_bincode_format <>= - subroutine cascade_set_write_process_bincode_format (cascade_set, unit) + module subroutine cascade_set_write_process_bincode_format & + (cascade_set, unit) type(cascade_set_t), intent(in), target :: cascade_set integer, intent(in), optional :: unit integer, dimension(:), allocatable :: bincode, field_width integer :: n_in, n_out, n_tot, n_flv integer :: u, f, i, bc character(20) :: str type(string_t) :: fmt_head type(string_t), dimension(:), allocatable :: fmt_proc u = given_output_unit (unit); if (u < 0) return if (.not. allocated (cascade_set%flv)) return write (u, "('!',1x,A)") "List of subprocesses with particle bincodes:" n_in = cascade_set%n_in n_out = cascade_set%n_out n_tot = cascade_set%n_tot n_flv = size (cascade_set%flv, 2) allocate (bincode (n_tot), field_width (n_tot), fmt_proc (n_tot)) bc = 1 do i = 1, n_out bincode(n_in + i) = bc bc = 2 * bc end do do i = n_in, 1, -1 bincode(i) = bc bc = 2 * bc end do do i = 1, n_tot write (str, "(I0)") bincode(i) field_width(i) = len_trim (str) do f = 1, n_flv field_width(i) = max (field_width(i), & len (cascade_set%flv(i,f)%get_name ())) end do end do fmt_head = "('!'" do i = 1, n_tot fmt_head = fmt_head // ",1x," fmt_proc(i) = "(1x," write (str, "(I0)") field_width(i) fmt_head = fmt_head // "I" // trim(str) fmt_proc(i) = fmt_proc(i) // "A" // trim(str) if (i == n_in) then fmt_head = fmt_head // ",1x,' '" end if end do do i = 1, n_tot fmt_proc(i) = fmt_proc(i) // ")" end do fmt_head = fmt_head // ")" write (u, char (fmt_head)) bincode do f = 1, n_flv write (u, "('!')", advance="no") do i = 1, n_tot write (u, char (fmt_proc(i)), advance="no") & char (cascade_set%flv(i,f)%get_name ()) if (i == n_in) write (u, "(1x,'=>')", advance="no") end do write (u, *) end do write (u, char (fmt_head)) bincode end subroutine cascade_set_write_process_bincode_format @ %def cascade_set_write_process_tex_format @ Write the process as a \LaTeX\ expression. <>= subroutine cascade_set_write_process_tex_format (cascade_set, unit) type(cascade_set_t), intent(in), target :: cascade_set integer, intent(in), optional :: unit integer :: u, f, i u = given_output_unit (unit); if (u < 0) return if (.not. allocated (cascade_set%flv)) return write (u, "(A)") "\begin{align*}" do f = 1, size (cascade_set%flv, 2) do i = 1, cascade_set%n_in if (i > 1) write (u, "(A)", advance="no") "\quad " write (u, "(A)", advance="no") & char (cascade_set%flv(i,f)%get_tex_name ()) end do write (u, "(A)", advance="no") "\quad &\to\quad " do i = cascade_set%n_in + 1, cascade_set%n_tot if (i > cascade_set%n_in + 1) write (u, "(A)", advance="no") "\quad " write (u, "(A)", advance="no") & char (cascade_set%flv(i,f)%get_tex_name ()) end do if (f < size (cascade_set%flv, 2)) then write (u, "(A)") "\\" else write (u, "(A)") "" end if end do write (u, "(A)") "\end{align*}" end subroutine cascade_set_write_process_tex_format @ %def cascade_set_write_process_tex_format @ Three output routines: phase-space file, graph source code, and screen output. This version generates the phase space file. It deals only with complete cascades. <>= public :: cascade_set_write_file_format +<>= + module subroutine cascade_set_write_file_format (cascade_set, unit) + type(cascade_set_t), intent(in), target :: cascade_set + integer, intent(in), optional :: unit + end subroutine cascade_set_write_file_format <>= - subroutine cascade_set_write_file_format (cascade_set, unit) + module subroutine cascade_set_write_file_format (cascade_set, unit) type(cascade_set_t), intent(in), target :: cascade_set integer, intent(in), optional :: unit type(cascade_t), pointer :: cascade integer :: u, grove, count logical :: first_in_grove u = given_output_unit (unit); if (u < 0) return count = 0 do grove = 1, cascade_set%n_groves first_in_grove = .true. cascade => cascade_set%first_k do while (associated (cascade)) if (cascade%active .and. cascade%complete) then if (cascade%grove == grove) then if (first_in_grove) then first_in_grove = .false. write (u, "(A)") write (u, "(1x,'!',1x,A,1x,I0,A)", advance='no') & 'Multiplicity =', cascade%multiplicity, "," select case (cascade%n_resonances) case (0) write (u, '(1x,A)', advance='no') 'no resonances, ' case (1) write (u, '(1x,A)', advance='no') '1 resonance, ' case default write (u, '(1x,I0,1x,A)', advance='no') & cascade%n_resonances, 'resonances, ' end select write (u, '(1x,I0,1x,A)', advance='no') & cascade%n_log_enhanced, 'logs, ' write (u, '(1x,I0,1x,A)', advance='no') & cascade%n_off_shell, 'off-shell, ' select case (cascade%n_t_channel) case (0); write (u, '(1x,A)') 's-channel graph' case (1); write (u, '(1x,A)') '1 t-channel line' case default write(u,'(1x,I0,1x,A)') & cascade%n_t_channel, 't-channel lines' end select write (u, '(1x,A,I0)') 'grove #', grove end if count = count + 1 write (u, "(1x,'!',1x,A,I0)") "Channel #", count call cascade_write_file_format (cascade, cascade_set%model, u) end if end if cascade => cascade%next end do end do end subroutine cascade_set_write_file_format @ %def cascade_set_write_file_format @ This is the graph output format, the driver-file <>= public :: cascade_set_write_graph_format +<>= + module subroutine cascade_set_write_graph_format & + (cascade_set, filename, process_id, unit) + type(cascade_set_t), intent(in), target :: cascade_set + type(string_t), intent(in) :: filename, process_id + integer, intent(in), optional :: unit + end subroutine cascade_set_write_graph_format <>= - subroutine cascade_set_write_graph_format & + module subroutine cascade_set_write_graph_format & (cascade_set, filename, process_id, unit) type(cascade_set_t), intent(in), target :: cascade_set type(string_t), intent(in) :: filename, process_id integer, intent(in), optional :: unit type(cascade_t), pointer :: cascade integer :: u, grove, count, pgcount logical :: first_in_grove u = given_output_unit (unit); if (u < 0) return write (u, '(A)') "\documentclass[10pt]{article}" write (u, '(A)') "\usepackage{amsmath}" write (u, '(A)') "\usepackage{feynmp}" write (u, '(A)') "\usepackage{url}" write (u, '(A)') "\usepackage{color}" write (u, *) write (u, '(A)') "\textwidth 18.5cm" write (u, '(A)') "\evensidemargin -1.5cm" write (u, '(A)') "\oddsidemargin -1.5cm" write (u, *) write (u, '(A)') "\newcommand{\blue}{\color{blue}}" write (u, '(A)') "\newcommand{\green}{\color{green}}" write (u, '(A)') "\newcommand{\red}{\color{red}}" write (u, '(A)') "\newcommand{\magenta}{\color{magenta}}" write (u, '(A)') "\newcommand{\cyan}{\color{cyan}}" write (u, '(A)') "\newcommand{\sm}{\footnotesize}" write (u, '(A)') "\setlength{\parindent}{0pt}" write (u, '(A)') "\setlength{\parsep}{20pt}" write (u, *) write (u, '(A)') "\begin{document}" write (u, '(A)') "\begin{fmffile}{" // char (filename) // "}" write (u, '(A)') "\fmfcmd{color magenta; magenta = red + blue;}" write (u, '(A)') "\fmfcmd{color cyan; cyan = green + blue;}" write (u, '(A)') "\begin{fmfshrink}{0.5}" write (u, '(A)') "\begin{flushleft}" write (u, *) write (u, '(A)') "\noindent" // & & "\textbf{\large\texttt{WHIZARD} phase space channels}" // & & "\hfill\today" write (u, *) write (u, '(A)') "\vspace{10pt}" write (u, '(A)') "\noindent" // & & "\textbf{Process:} \url{" // char (process_id) // "}" call cascade_set_write_process_tex_format (cascade_set, u) write (u, *) write (u, '(A)') "\noindent" // & & "\textbf{Note:} These are pseudo Feynman graphs that " write (u, '(A)') "visualize phase-space parameterizations " // & & "(``integration channels''). " write (u, '(A)') "They do \emph{not} indicate Feynman graphs used for the " // & & "matrix element." write (u, *) write (u, '(A)') "\textbf{Color code:} " // & & "{\blue resonance,} " // & & "{\cyan t-channel,} " // & & "{\green radiation,} " write (u, '(A)') "{\red infrared,} " // & & "{\magenta collinear,} " // & & "external/off-shell" write (u, *) write (u, '(A)') "\noindent" // & & "\textbf{Black square:} Keystone, indicates ordering of " // & & "phase space parameters." write (u, *) write (u, '(A)') "\vspace{-20pt}" count = 0 pgcount = 0 do grove = 1, cascade_set%n_groves first_in_grove = .true. cascade => cascade_set%first do while (associated (cascade)) if (cascade%active .and. cascade%complete) then if (cascade%grove == grove) then if (first_in_grove) then first_in_grove = .false. write (u, *) write (u, '(A)') "\vspace{20pt}" write (u, '(A)') "\begin{tabular}{l}" write (u, '(A,I5,A)') & & "\fbox{\bf Grove \boldmath$", grove, "$} \\[10pt]" write (u, '(A,I1,A)') "Multiplicity: ", & cascade%multiplicity, "\\" write (u, '(A,I1,A)') "Resonances: ", & cascade%n_resonances, "\\" write (u, '(A,I1,A)') "Log-enhanced: ", & cascade%n_log_enhanced, "\\" write (u, '(A,I1,A)') "Off-shell: ", & cascade%n_off_shell, "\\" write (u, '(A,I1,A)') "t-channel: ", & cascade%n_t_channel, "" write (u, '(A)') "\end{tabular}" end if count = count + 1 call cascade_write_graph_format (cascade, count, unit) if (pgcount >= 250) then write (u, '(A)') "\clearpage" pgcount = 0 end if end if end if cascade => cascade%next end do end do write (u, '(A)') "\end{flushleft}" write (u, '(A)') "\end{fmfshrink}" write (u, '(A)') "\end{fmffile}" write (u, '(A)') "\end{document}" end subroutine cascade_set_write_graph_format @ %def cascade_set_write_graph_format @ This is for screen output and debugging: <>= public :: cascade_set_write +<>= + module subroutine cascade_set_write & + (cascade_set, unit, active_only, complete_only) + type(cascade_set_t), intent(in), target :: cascade_set + integer, intent(in), optional :: unit + logical, intent(in), optional :: active_only, complete_only + end subroutine cascade_set_write <>= - subroutine cascade_set_write (cascade_set, unit, active_only, complete_only) + module subroutine cascade_set_write & + (cascade_set, unit, active_only, complete_only) type(cascade_set_t), intent(in), target :: cascade_set integer, intent(in), optional :: unit logical, intent(in), optional :: active_only, complete_only logical :: active, complete type(cascade_t), pointer :: cascade integer :: u, i u = given_output_unit (unit); if (u < 0) return active = .true.; if (present (active_only)) active = active_only complete = .false.; if (present (complete_only)) complete = complete_only write (u, "(A)") "Cascade set:" write (u, "(3x,A)", advance="no") "Model:" if (associated (cascade_set%model)) then write (u, "(1x,A)") char (cascade_set%model%get_name ()) else write (u, "(1x,A)") "[none]" end if write (u, "(3x,A)", advance="no") "n_in/out/tot =" write (u, "(3(1x,I7))") & cascade_set%n_in, cascade_set%n_out, cascade_set%n_tot write (u, "(3x,A)", advance="no") "depth_out/tot =" write (u, "(2(1x,I7))") cascade_set%depth_out, cascade_set%depth_tot write (u, "(3x,A)", advance="no") "mass thr(s/t) =" write (u, "(2(1x," // FMT_19 // "))") & cascade_set%m_threshold_s, cascade_set%m_threshold_t write (u, "(3x,A)", advance="no") "off shell =" write (u, "(1x,I7)") cascade_set%off_shell write (u, "(3x,A)", advance="no") "keep_nonreson =" write (u, "(1x,L1)") cascade_set%keep_nonresonant write (u, "(3x,A)", advance="no") "n_groves =" write (u, "(1x,I7)") cascade_set%n_groves write (u, "(A)") write (u, "(A)") "Cascade list:" if (associated (cascade_set%first)) then cascade => cascade_set%first do while (associated (cascade)) if (active .and. .not. cascade%active) cycle if (complete .and. .not. cascade%complete) cycle call cascade_write (cascade, unit) cascade => cascade%next end do else write (u, "(A)") "[empty]" end if write (u, "(A)") "Hash array" write (u, "(3x,A)", advance="no") "n_entries =" write (u, "(1x,I7)") cascade_set%n_entries write (u, "(3x,A)", advance="no") "fill_ratio =" write (u, "(1x," // FMT_12 // ")") cascade_set%fill_ratio write (u, "(3x,A)", advance="no") "n_entries_max =" write (u, "(1x,I7)") cascade_set%n_entries_max write (u, "(3x,A)", advance="no") "mask =" write (u, "(1x,I0)") cascade_set%mask do i = 0, ubound (cascade_set%entry, 1) if (allocated (cascade_set%entry(i)%key)) then write (u, "(1x,I7)") i call hash_entry_write (cascade_set%entry(i), u) end if end do end subroutine cascade_set_write @ %def cascade_set_write @ \subsection{Adding cascades} Add a deep copy of a cascade to the set. The copy has all content of the original, but the pointers are nullified. We do not care whether insertion was successful or not. The pointer argument, if present, is assigned to the input cascade, or to the hash entry if it is already present. The procedure is recursive: any daughter or mother entries are also deep-copied and added to the cascade set before the current copy is added. <>= recursive subroutine cascade_set_add_copy & (cascade_set, cascade_in, cascade_ptr) type(cascade_set_t), intent(inout), target :: cascade_set type(cascade_t), intent(in) :: cascade_in type(cascade_t), optional, pointer :: cascade_ptr type(cascade_t), pointer :: cascade logical :: ok allocate (cascade) cascade = cascade_in if (associated (cascade_in%daughter1)) call cascade_set_add_copy & (cascade_set, cascade_in%daughter1, cascade%daughter1) if (associated (cascade_in%daughter2)) call cascade_set_add_copy & (cascade_set, cascade_in%daughter2, cascade%daughter2) if (associated (cascade_in%mother)) call cascade_set_add_copy & (cascade_set, cascade_in%mother, cascade%mother) cascade%next => null () call cascade_set_add (cascade_set, cascade, ok, cascade_ptr) if (.not. ok) deallocate (cascade) end subroutine cascade_set_add_copy @ %def cascade_set_add_copy @ Add a cascade to the set. This does not deep-copy. We first try to insert it in the hash array. If successful, add it to the list. Failure indicates that it is already present, and we drop it. The hash key is built solely from the tree array, so neither particle codes nor resonances count, just topology. Technically, hash and list receive only pointers, so the cascade can be considered as being in either of both. We treat it as part of the list. <>= subroutine cascade_set_add (cascade_set, cascade, ok, cascade_ptr) type(cascade_set_t), intent(inout), target :: cascade_set type(cascade_t), intent(in), target :: cascade logical, intent(out) :: ok type(cascade_t), optional, pointer :: cascade_ptr integer(i8), dimension(1) :: mold call cascade_set_hash_insert & (cascade_set, transfer (cascade%tree, mold), cascade, ok, cascade_ptr) if (ok) call cascade_set_list_add (cascade_set, cascade) end subroutine cascade_set_add @ %def cascade_set_add @ Add a new cascade to the list: <>= subroutine cascade_set_list_add (cascade_set, cascade) type(cascade_set_t), intent(inout) :: cascade_set type(cascade_t), intent(in), target :: cascade if (associated (cascade_set%last)) then cascade_set%last%next => cascade else cascade_set%first => cascade end if cascade_set%last => cascade end subroutine cascade_set_list_add @ %def cascade_set_list_add @ Add a cascade entry to the hash array: <>= subroutine cascade_set_hash_insert & (cascade_set, key, cascade, ok, cascade_ptr) type(cascade_set_t), intent(inout), target :: cascade_set integer(i8), dimension(:), intent(in) :: key type(cascade_t), intent(in), target :: cascade logical, intent(out) :: ok type(cascade_t), optional, pointer :: cascade_ptr integer(i32) :: h if (cascade_set%n_entries >= cascade_set%n_entries_max) & call cascade_set_hash_expand (cascade_set) h = hash (key) call cascade_set_hash_insert_rec & (cascade_set, h, h, key, cascade, ok, cascade_ptr) end subroutine cascade_set_hash_insert @ %def cascade_set_hash_insert @ Double the hashtable size when necesssary: <>= subroutine cascade_set_hash_expand (cascade_set) type(cascade_set_t), intent(inout), target :: cascade_set type(hash_entry_t), dimension(:), allocatable, target :: table_tmp type(cascade_p), pointer :: current integer :: i, s allocate (table_tmp (0:cascade_set%mask)) table_tmp = cascade_set%entry deallocate (cascade_set%entry) s = 2 * size (table_tmp) cascade_set%n_entries = 0 cascade_set%n_entries_max = s * cascade_set%fill_ratio cascade_set%mask = s - 1 allocate (cascade_set%entry (0:cascade_set%mask)) do i = 0, ubound (table_tmp, 1) current => table_tmp(i)%first do while (associated (current)) call cascade_set_hash_insert_rec & (cascade_set, table_tmp(i)%hashval, table_tmp(i)%hashval, & table_tmp(i)%key, current%cascade) current => current%next end do end do end subroutine cascade_set_hash_expand @ %def cascade_set_hash_expand @ Insert the cascade at the bucket determined by the hash value. If the bucket is filled, check first for a collision (unequal keys). In that case, choose the following bucket and repeat. Otherwise, add the cascade to the bucket. If the bucket is empty, record the hash value, allocate and store the key, and then add the cascade to the bucket. If [[ok]] is present, before insertion we check whether the cascade is already stored, and return failure if yes. <>= recursive subroutine cascade_set_hash_insert_rec & (cascade_set, h, hashval, key, cascade, ok, cascade_ptr) type(cascade_set_t), intent(inout) :: cascade_set integer(i32), intent(in) :: h, hashval integer(i8), dimension(:), intent(in) :: key type(cascade_t), intent(in), target :: cascade logical, intent(out), optional :: ok type(cascade_t), optional, pointer :: cascade_ptr integer(i32) :: i i = iand (h, cascade_set%mask) if (allocated (cascade_set%entry(i)%key)) then if (size (cascade_set%entry(i)%key) /= size (key)) then call cascade_set_hash_insert_rec & (cascade_set, h + 1, hashval, key, cascade, ok, cascade_ptr) else if (any (cascade_set%entry(i)%key /= key)) then call cascade_set_hash_insert_rec & (cascade_set, h + 1, hashval, key, cascade, ok, cascade_ptr) else call hash_entry_add_cascade_ptr & (cascade_set%entry(i), cascade, ok, cascade_ptr) end if else cascade_set%entry(i)%hashval = hashval allocate (cascade_set%entry(i)%key (size (key))) cascade_set%entry(i)%key = key call hash_entry_add_cascade_ptr & (cascade_set%entry(i), cascade, ok, cascade_ptr) cascade_set%n_entries = cascade_set%n_entries + 1 end if end subroutine cascade_set_hash_insert_rec @ %def cascade_set_hash_insert_rec @ \subsection{External particles} We want to initialize the cascade set with the outgoing particles. In case of multiple processes, initial cascades are prepared for all of them. The hash array check ensures that no particle appears more than once at the same place. <>= interface cascade_set_add_outgoing module procedure cascade_set_add_outgoing1 module procedure cascade_set_add_outgoing2 end interface +<>= + module subroutine cascade_set_add_outgoing1 (cascade_set, flv) + type(cascade_set_t), intent(inout), target :: cascade_set + type(flavor_t), dimension(:), intent(in) :: flv + end subroutine cascade_set_add_outgoing1 + module subroutine cascade_set_add_outgoing2 (cascade_set, flv) + type(cascade_set_t), intent(inout), target :: cascade_set + type(flavor_t), dimension(:,:), intent(in) :: flv + end subroutine cascade_set_add_outgoing2 <>= - subroutine cascade_set_add_outgoing2 (cascade_set, flv) + module subroutine cascade_set_add_outgoing2 (cascade_set, flv) type(cascade_set_t), intent(inout), target :: cascade_set type(flavor_t), dimension(:,:), intent(in) :: flv integer :: pos, prc, n_out, n_prc type(cascade_t), pointer :: cascade logical :: ok n_out = size (flv, dim=1) n_prc = size (flv, dim=2) do prc = 1, n_prc do pos = 1, n_out allocate (cascade) call cascade_init_outgoing & (cascade, flv(pos,prc), pos, cascade_set%m_threshold_s) call cascade_set_add (cascade_set, cascade, ok) if (.not. ok) then deallocate (cascade) end if end do end do end subroutine cascade_set_add_outgoing2 - subroutine cascade_set_add_outgoing1 (cascade_set, flv) + module subroutine cascade_set_add_outgoing1 (cascade_set, flv) type(cascade_set_t), intent(inout), target :: cascade_set type(flavor_t), dimension(:), intent(in) :: flv integer :: pos, n_out type(cascade_t), pointer :: cascade logical :: ok n_out = size (flv, dim=1) do pos = 1, n_out allocate (cascade) call cascade_init_outgoing & (cascade, flv(pos), pos, cascade_set%m_threshold_s) call cascade_set_add (cascade_set, cascade, ok) if (.not. ok) then deallocate (cascade) end if end do end subroutine cascade_set_add_outgoing1 @ %def cascade_set_add_outgoing @ The incoming particles are added one at a time. Nevertheless, we may have several processes which are looped over. At the first opportunity, we set the pointer [[first_t]] in the cascade set which should point to the first t-channel cascade. Return the indices of the first and last cascade generated. <>= interface cascade_set_add_incoming module procedure cascade_set_add_incoming0 module procedure cascade_set_add_incoming1 end interface +<>= + module subroutine cascade_set_add_incoming1 (cascade_set, n1, n2, pos, flv) + type(cascade_set_t), intent(inout), target :: cascade_set + integer, intent(out) :: n1, n2 + integer, intent(in) :: pos + type(flavor_t), dimension(:), intent(in) :: flv + end subroutine cascade_set_add_incoming1 + module subroutine cascade_set_add_incoming0 (cascade_set, n1, n2, pos, flv) + type(cascade_set_t), intent(inout), target :: cascade_set + integer, intent(out) :: n1, n2 + integer, intent(in) :: pos + type(flavor_t), intent(in) :: flv + end subroutine cascade_set_add_incoming0 <>= - subroutine cascade_set_add_incoming1 (cascade_set, n1, n2, pos, flv) + module subroutine cascade_set_add_incoming1 (cascade_set, n1, n2, pos, flv) type(cascade_set_t), intent(inout), target :: cascade_set integer, intent(out) :: n1, n2 integer, intent(in) :: pos type(flavor_t), dimension(:), intent(in) :: flv integer :: prc, n_prc type(cascade_t), pointer :: cascade logical :: ok n1 = 0 n2 = 0 n_prc = size (flv) do prc = 1, n_prc allocate (cascade) call cascade_init_incoming & (cascade, flv(prc), pos, cascade_set%m_threshold_t) call cascade_set_add (cascade_set, cascade, ok) if (ok) then if (n1 == 0) n1 = cascade%index n2 = cascade%index if (.not. associated (cascade_set%first_t)) then cascade_set%first_t => cascade end if else deallocate (cascade) end if end do end subroutine cascade_set_add_incoming1 - subroutine cascade_set_add_incoming0 (cascade_set, n1, n2, pos, flv) + module subroutine cascade_set_add_incoming0 (cascade_set, n1, n2, pos, flv) type(cascade_set_t), intent(inout), target :: cascade_set integer, intent(out) :: n1, n2 integer, intent(in) :: pos type(flavor_t), intent(in) :: flv type(cascade_t), pointer :: cascade logical :: ok n1 = 0 n2 = 0 allocate (cascade) call cascade_init_incoming & (cascade, flv, pos, cascade_set%m_threshold_t) call cascade_set_add (cascade_set, cascade, ok) if (ok) then if (n1 == 0) n1 = cascade%index n2 = cascade%index if (.not. associated (cascade_set%first_t)) then cascade_set%first_t => cascade end if else deallocate (cascade) end if end subroutine cascade_set_add_incoming0 @ %def cascade_set_add_incoming @ \subsection{Cascade combination I: flavor assignment} We have two disjunct cascades, now use the vertex table to determine the possible flavors of the combination cascade. For each possibility, try to generate a new cascade. The total cascade depth has to be one less than the limit, because this is reached by setting the keystone. <>= subroutine cascade_match_pair (cascade_set, cascade1, cascade2, s_channel) type(cascade_set_t), intent(inout), target :: cascade_set type(cascade_t), intent(in), target :: cascade1, cascade2 logical, intent(in) :: s_channel integer, dimension(:), allocatable :: pdg3 integer :: i, depth_max type(flavor_t) :: flv if (s_channel) then depth_max = cascade_set%depth_out else depth_max = cascade_set%depth_tot end if if (cascade1%depth + cascade2%depth < depth_max) then call cascade_set%model%match_vertex ( & cascade1%flv%get_pdg (), & cascade2%flv%get_pdg (), & pdg3) do i = 1, size (pdg3) call flv%init (pdg3(i), cascade_set%model) if (s_channel) then call cascade_combine_s (cascade_set, cascade1, cascade2, flv) else call cascade_combine_t (cascade_set, cascade1, cascade2, flv) end if end do deallocate (pdg3) end if end subroutine cascade_match_pair @ %def cascade_match_pair @ The triplet version takes a third cascade, and we check whether this triplet has a matching vertex in the database. If yes, we make a keystone cascade. <>= subroutine cascade_match_triplet & (cascade_set, cascade1, cascade2, cascade3, s_channel) type(cascade_set_t), intent(inout), target :: cascade_set type(cascade_t), intent(in), target :: cascade1, cascade2, cascade3 logical, intent(in) :: s_channel integer :: depth_max depth_max = cascade_set%depth_tot if (cascade1%depth + cascade2%depth + cascade3%depth == depth_max) then if (cascade_set%model%check_vertex ( & cascade1%flv%get_pdg (), & cascade2%flv%get_pdg (), & cascade3%flv%get_pdg ())) then call cascade_combine_keystone & (cascade_set, cascade1, cascade2, cascade3, s_channel) end if end if end subroutine cascade_match_triplet @ %def cascade_match_triplet @ \subsection{Cascade combination II: kinematics setup and check} Having three matching flavors, we start constructing the combination cascade. We look at the mass hierarchies and determine whether the cascade is to be kept. In passing we set mapping modes, resonance properties and such. If successful, the cascade is finalized. For a resonant cascade, we prepare in addition a copy without the resonance. <>= subroutine cascade_combine_s (cascade_set, cascade1, cascade2, flv) type(cascade_set_t), intent(inout), target :: cascade_set type(cascade_t), intent(in), target :: cascade1, cascade2 type(flavor_t), intent(in) :: flv type(cascade_t), pointer :: cascade3, cascade4 logical :: keep keep = .false. allocate (cascade3) call cascade_init (cascade3, cascade1%depth + cascade2%depth + 1) cascade3%bincode = ior (cascade1%bincode, cascade2%bincode) cascade3%flv = flv%anti () cascade3%pdg = cascade3%flv%get_pdg () cascade3%is_vector = flv%get_spin_type () == VECTOR cascade3%m_min = cascade1%m_min + cascade2%m_min cascade3%m_rea = flv%get_mass () if (cascade3%m_rea > cascade_set%m_threshold_s) then cascade3%m_eff = cascade3%m_rea end if ! Potentially resonant cases [sqrts = m_rea for on-shell decay] if (cascade3%m_rea > cascade3%m_min & .and. cascade3%m_rea <= cascade_set%sqrts) then if (flv%get_width () /= 0) then if (cascade1%on_shell .or. cascade2%on_shell) then keep = .true. cascade3%mapping = S_CHANNEL cascade3%resonant = .true. end if else call warn_decay (flv) end if ! Collinear and IR singular cases else if (cascade3%m_rea < cascade_set%sqrts) then ! Massless splitting if (cascade1%m_eff == 0 .and. cascade2%m_eff == 0 & .and. cascade3%depth <= 3) then keep = .true. cascade3%log_enhanced = .true. if (cascade3%is_vector) then if (cascade1%is_vector .and. cascade2%is_vector) then cascade3%mapping = COLLINEAR ! three-vector-vertex else cascade3%mapping = INFRARED ! vector splitting into matter end if else if (cascade1%is_vector .or. cascade2%is_vector) then cascade3%mapping = COLLINEAR ! vector radiation off matter else cascade3%mapping = INFRARED ! scalar radiation/splitting end if end if ! IR radiation off massive particle else if (cascade3%m_eff > 0 .and. cascade1%m_eff > 0 & .and. cascade2%m_eff == 0 & .and. (cascade1%on_shell .or. cascade1%mapping == RADIATION) & .and. abs (cascade3%m_eff - cascade1%m_eff) & < cascade_set%m_threshold_s) & then keep = .true. cascade3%log_enhanced = .true. cascade3%mapping = RADIATION else if (cascade3%m_eff > 0 .and. cascade2%m_eff > 0 & .and. cascade1%m_eff == 0 & .and. (cascade2%on_shell .or. cascade2%mapping == RADIATION) & .and. abs (cascade3%m_eff - cascade2%m_eff) & < cascade_set%m_threshold_s) & then keep = .true. cascade3%log_enhanced = .true. cascade3%mapping = RADIATION end if end if ! Non-singular cases, including failed resonances if (.not. keep) then ! Two on-shell particles from a virtual mother if (cascade1%on_shell .or. cascade2%on_shell) then keep = .true. cascade3%m_eff = max (cascade3%m_min, & cascade1%m_eff + cascade2%m_eff) if (cascade3%m_eff < cascade_set%m_threshold_s) then cascade3%m_eff = 0 end if end if end if ! Complete and register the cascade (two in case of resonance) if (keep) then cascade3%on_shell = cascade3%resonant .or. cascade3%log_enhanced if (cascade3%resonant) then cascade3%pdg = cascade3%flv%get_pdg () if (cascade_set%keep_nonresonant) then allocate (cascade4) cascade4 = cascade3 cascade4%index = cascade_index () cascade4%pdg = UNDEFINED cascade4%mapping = NO_MAPPING cascade4%resonant = .false. cascade4%on_shell = .false. end if cascade3%m_min = cascade3%m_rea call cascade_fusion (cascade_set, cascade1, cascade2, cascade3) if (cascade_set%keep_nonresonant) then call cascade_fusion (cascade_set, cascade1, cascade2, cascade4) end if else call cascade_fusion (cascade_set, cascade1, cascade2, cascade3) end if else deallocate (cascade3) end if contains subroutine warn_decay (flv) type(flavor_t), intent(in) :: flv integer :: i integer, dimension(MAX_WARN_RESONANCE), save :: warned_code = 0 LOOP_WARNED: do i = 1, MAX_WARN_RESONANCE if (warned_code(i) == 0) then warned_code(i) = flv%get_pdg () write (msg_buffer, "(A)") & & " Intermediate decay of zero-width particle " & & // char (flv%get_name ()) & & // " may be possible." call msg_warning exit LOOP_WARNED else if (warned_code(i) == flv%get_pdg ()) then exit LOOP_WARNED end if end do LOOP_WARNED end subroutine warn_decay end subroutine cascade_combine_s @ %def cascade_combine_s <>= integer, parameter, public :: MAX_WARN_RESONANCE = 50 @ %def MAX_WARN_RESONANCE @ This is the t-channel version. [[cascade1]] is t-channel and contains the seed, [[cascade2]] is s-channel. We check for kinematically allowed beam decay (which is a fatal error), or massless splitting / soft radiation. The cascade is kept in all remaining cases and submitted for registration. <>= subroutine cascade_combine_t (cascade_set, cascade1, cascade2, flv) type(cascade_set_t), intent(inout), target :: cascade_set type(cascade_t), intent(in), target :: cascade1, cascade2 type(flavor_t), intent(in) :: flv type(cascade_t), pointer :: cascade3 allocate (cascade3) call cascade_init (cascade3, cascade1%depth + cascade2%depth + 1) cascade3%bincode = ior (cascade1%bincode, cascade2%bincode) cascade3%flv = flv%anti () cascade3%pdg = abs (cascade3%flv%get_pdg ()) cascade3%is_vector = flv%get_spin_type () == VECTOR if (cascade1%incoming) then cascade3%m_min = cascade2%m_min else cascade3%m_min = cascade1%m_min + cascade2%m_min end if cascade3%m_rea = flv%get_mass () if (cascade3%m_rea > cascade_set%m_threshold_t) then cascade3%m_eff = max (cascade3%m_rea, cascade2%m_eff) else if (cascade2%m_eff > cascade_set%m_threshold_t) then cascade3%m_eff = cascade2%m_eff else cascade3%m_eff = 0 end if ! Allowed decay of beam particle if (cascade1%incoming & .and. cascade1%m_rea > cascade2%m_rea + cascade3%m_rea) then call beam_decay (cascade_set%fatal_beam_decay) ! Massless splitting else if (cascade1%m_eff == 0 & .and. cascade2%m_eff < cascade_set%m_threshold_t & .and. cascade3%m_eff == 0) then cascade3%mapping = U_CHANNEL cascade3%log_enhanced = .true. ! IR radiation off massive particle else if (cascade1%m_eff /= 0 .and. cascade2%m_eff == 0 & .and. cascade3%m_eff /= 0 & .and. (cascade1%on_shell .or. cascade1%mapping == RADIATION) & .and. abs (cascade1%m_eff - cascade3%m_eff) & < cascade_set%m_threshold_t) & then cascade3%pdg = flv%get_pdg () cascade3%log_enhanced = .true. cascade3%mapping = RADIATION end if cascade3%t_channel = .true. call cascade_fusion (cascade_set, cascade1, cascade2, cascade3) contains subroutine beam_decay (fatal_beam_decay) logical, intent(in) :: fatal_beam_decay write (msg_buffer, "(1x,A,1x,'->',1x,A,1x,A)") & char (cascade1%flv%get_name ()), & char (cascade3%flv%get_name ()), & char (cascade2%flv%get_name ()) call msg_message write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") & char (cascade1%flv%get_name ()), cascade1%m_rea call msg_message write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") & char (cascade3%flv%get_name ()), cascade3%m_rea call msg_message write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") & char (cascade2%flv%get_name ()), cascade2%m_rea call msg_message if (fatal_beam_decay) then call msg_fatal (" Phase space: Initial beam particle can decay") else call msg_warning (" Phase space: Initial beam particle can decay") end if end subroutine beam_decay end subroutine cascade_combine_t @ %def cascade_combine_t @ Here we complete a decay cascade. The third input is the single-particle cascade for the initial particle. There is no resonance or mapping assignment. The only condition for keeping the cascade is the mass sum of the final state, which must be less than the available energy. Two modifications are necessary for scattering cascades: a pure s-channel diagram (cascade1 is the incoming particle) do not have a logarithmic mapping at top-level. And in a t-channel diagram, the last line exchanged is mapped t-channel, not u-channel. Finally, we can encounter the case of a $2\to 1$ process, where cascade1 is incoming, and cascade2 is the outgoing particle. In all three cases we register a new cascade with the modified mapping. <>= subroutine cascade_combine_keystone & (cascade_set, cascade1, cascade2, cascade3, s_channel) type(cascade_set_t), intent(inout), target :: cascade_set type(cascade_t), intent(in), target :: cascade1, cascade2, cascade3 logical, intent(in) :: s_channel type(cascade_t), pointer :: cascade4, cascade0 logical :: keep, ok keep = .false. allocate (cascade4) call cascade_init & (cascade4, cascade1%depth + cascade2%depth + cascade3%depth) cascade4%complete = .true. if (s_channel) then cascade4%bincode = ior (cascade1%bincode, cascade2%bincode) else cascade4%bincode = cascade3%bincode end if cascade4%flv = cascade3%flv cascade4%pdg = cascade3%pdg cascade4%mapping = EXTERNAL_PRT cascade4%is_vector = cascade3%is_vector cascade4%m_min = cascade1%m_min + cascade2%m_min cascade4%m_rea = cascade3%m_rea cascade4%m_eff = cascade3%m_rea if (cascade4%m_min < cascade_set%sqrts) then keep = .true. end if if (keep) then if (cascade1%incoming .and. cascade2%log_enhanced) then allocate (cascade0) cascade0 = cascade2 cascade0%next => null () cascade0%index = cascade_index () cascade0%mapping = NO_MAPPING cascade0%log_enhanced = .false. cascade0%n_log_enhanced = cascade0%n_log_enhanced - 1 cascade0%tree_mapping(cascade0%depth) = NO_MAPPING call cascade_keystone & (cascade_set, cascade1, cascade0, cascade3, cascade4, ok) if (ok) then call cascade_set_add (cascade_set, cascade0, ok) else deallocate (cascade0) end if else if (cascade1%t_channel .and. cascade1%mapping == U_CHANNEL) then allocate (cascade0) cascade0 = cascade1 cascade0%next => null () cascade0%index = cascade_index () cascade0%mapping = T_CHANNEL cascade0%tree_mapping(cascade0%depth) = T_CHANNEL call cascade_keystone & (cascade_set, cascade0, cascade2, cascade3, cascade4, ok) if (ok) then call cascade_set_add (cascade_set, cascade0, ok) else deallocate (cascade0) end if else if (cascade1%incoming .and. cascade2%depth == 1) then allocate (cascade0) cascade0 = cascade2 cascade0%next => null () cascade0%index = cascade_index () cascade0%mapping = ON_SHELL cascade0%tree_mapping(cascade0%depth) = ON_SHELL call cascade_keystone & (cascade_set, cascade1, cascade0, cascade3, cascade4, ok) if (ok) then call cascade_set_add (cascade_set, cascade0, ok) else deallocate (cascade0) end if else call cascade_keystone & (cascade_set, cascade1, cascade2, cascade3, cascade4, ok) end if else deallocate (cascade4) end if end subroutine cascade_combine_keystone @ %def cascade_combine_keystone @ \subsection{Cascade combination III: node connections and tree fusion} Here we assign global tree properties. If the allowed number of off-shell lines is exceeded, discard the new cascade. Otherwise, assign the trees, sort them, and assign connections. Finally, append the cascade to the list. This may fail (because in the hash array there is already an equivalent cascade). On failure, discard the cascade. <>= subroutine cascade_fusion (cascade_set, cascade1, cascade2, cascade3) type(cascade_set_t), intent(inout), target :: cascade_set type(cascade_t), intent(in), target :: cascade1, cascade2 type(cascade_t), pointer :: cascade3 integer :: i1, i2, i3, i4 logical :: ok cascade3%internal = (cascade3%depth - 3) / 2 if (cascade3%resonant) then cascade3%multiplicity = 1 cascade3%n_resonances = & cascade1%n_resonances + cascade2%n_resonances + 1 else cascade3%multiplicity = cascade1%multiplicity + cascade2%multiplicity cascade3%n_resonances = cascade1%n_resonances + cascade2%n_resonances end if if (cascade3%log_enhanced) then cascade3%n_log_enhanced = & cascade1%n_log_enhanced + cascade2%n_log_enhanced + 1 else cascade3%n_log_enhanced = & cascade1%n_log_enhanced + cascade2%n_log_enhanced end if if (cascade3%resonant) then cascade3%n_off_shell = 0 else if (cascade3%log_enhanced) then cascade3%n_off_shell = cascade1%n_off_shell + cascade2%n_off_shell else cascade3%n_off_shell = cascade1%n_off_shell + cascade2%n_off_shell + 1 end if if (cascade3%t_channel) then cascade3%n_t_channel = cascade1%n_t_channel + 1 end if if (cascade3%n_off_shell > cascade_set%off_shell) then deallocate (cascade3) else if (cascade3%n_t_channel > cascade_set%t_channel) then deallocate (cascade3) else i1 = cascade1%depth i2 = i1 + 1 i3 = i1 + cascade2%depth i4 = cascade3%depth cascade3%tree(:i1) = cascade1%tree where (cascade1%tree_mapping > NO_MAPPING) cascade3%tree_pdg(:i1) = cascade1%tree_pdg elsewhere cascade3%tree_pdg(:i1) = UNDEFINED end where cascade3%tree_mapping(:i1) = cascade1%tree_mapping cascade3%tree_resonant(:i1) = cascade1%tree_resonant cascade3%tree(i2:i3) = cascade2%tree where (cascade2%tree_mapping > NO_MAPPING) cascade3%tree_pdg(i2:i3) = cascade2%tree_pdg elsewhere cascade3%tree_pdg(i2:i3) = UNDEFINED end where cascade3%tree_mapping(i2:i3) = cascade2%tree_mapping cascade3%tree_resonant(i2:i3) = cascade2%tree_resonant cascade3%tree(i4) = cascade3%bincode cascade3%tree_pdg(i4) = cascade3%pdg cascade3%tree_mapping(i4) = cascade3%mapping cascade3%tree_resonant(i4) = cascade3%resonant call tree_sort (cascade3%tree, & cascade3%tree_pdg, cascade3%tree_mapping, cascade3%tree_resonant) cascade3%has_children = .true. cascade3%daughter1 => cascade1 cascade3%daughter2 => cascade2 call cascade_set_add (cascade_set, cascade3, ok) if (.not. ok) deallocate (cascade3) end if end subroutine cascade_fusion @ %def cascade_fusion @ Here we combine a cascade pair with an incoming particle, i.e., we set a keystone. Otherwise, this is similar. On the first opportunity, we set the [[first_k]] pointer in the cascade set. <>= subroutine cascade_keystone & (cascade_set, cascade1, cascade2, cascade3, cascade4, ok) type(cascade_set_t), intent(inout), target :: cascade_set type(cascade_t), intent(in), target :: cascade1, cascade2, cascade3 type(cascade_t), pointer :: cascade4 logical, intent(out) :: ok integer :: i1, i2, i3, i4 cascade4%internal = (cascade4%depth - 3) / 2 cascade4%multiplicity = cascade1%multiplicity + cascade2%multiplicity cascade4%n_resonances = cascade1%n_resonances + cascade2%n_resonances cascade4%n_off_shell = cascade1%n_off_shell + cascade2%n_off_shell cascade4%n_log_enhanced = & cascade1%n_log_enhanced + cascade2%n_log_enhanced cascade4%n_t_channel = cascade1%n_t_channel + cascade2%n_t_channel if (cascade4%n_off_shell > cascade_set%off_shell) then deallocate (cascade4) ok = .false. else if (cascade4%n_t_channel > cascade_set%t_channel) then deallocate (cascade4) ok = .false. else i1 = cascade1%depth i2 = i1 + 1 i3 = i1 + cascade2%depth i4 = cascade4%depth cascade4%tree(:i1) = cascade1%tree where (cascade1%tree_mapping > NO_MAPPING) cascade4%tree_pdg(:i1) = cascade1%tree_pdg elsewhere cascade4%tree_pdg(:i1) = UNDEFINED end where cascade4%tree_mapping(:i1) = cascade1%tree_mapping cascade4%tree_resonant(:i1) = cascade1%tree_resonant cascade4%tree(i2:i3) = cascade2%tree where (cascade2%tree_mapping > NO_MAPPING) cascade4%tree_pdg(i2:i3) = cascade2%tree_pdg elsewhere cascade4%tree_pdg(i2:i3) = UNDEFINED end where cascade4%tree_mapping(i2:i3) = cascade2%tree_mapping cascade4%tree_resonant(i2:i3) = cascade2%tree_resonant cascade4%tree(i4) = cascade4%bincode cascade4%tree_pdg(i4) = UNDEFINED cascade4%tree_mapping(i4) = cascade4%mapping cascade4%tree_resonant(i4) = .false. call tree_sort (cascade4%tree, & cascade4%tree_pdg, cascade4%tree_mapping, cascade4%tree_resonant) cascade4%has_children = .true. cascade4%daughter1 => cascade1 cascade4%daughter2 => cascade2 cascade4%mother => cascade3 call cascade_set_add (cascade_set, cascade4, ok) if (ok) then if (.not. associated (cascade_set%first_k)) then cascade_set%first_k => cascade4 end if else deallocate (cascade4) end if end if end subroutine cascade_keystone @ %def cascade_keystone @ Sort a tree (array of binary codes) and particle code array simultaneously, by ascending binary codes. A convenient method is to use the [[maxloc]] function iteratively, to find and remove the largest entry in the tree array one by one. <>= subroutine tree_sort (tree, pdg, mapping, resonant) integer(TC), dimension(:), intent(inout) :: tree integer, dimension(:), intent(inout) :: pdg, mapping logical, dimension(:), intent(inout) :: resonant integer(TC), dimension(size(tree)) :: tree_tmp integer, dimension(size(pdg)) :: pdg_tmp, mapping_tmp logical, dimension(size(resonant)) :: resonant_tmp integer, dimension(1) :: pos integer :: i tree_tmp = tree pdg_tmp = pdg mapping_tmp = mapping resonant_tmp = resonant do i = size(tree),1,-1 pos = maxloc (tree_tmp) tree(i) = tree_tmp (pos(1)) pdg(i) = pdg_tmp (pos(1)) mapping(i) = mapping_tmp (pos(1)) resonant(i) = resonant_tmp (pos(1)) tree_tmp(pos(1)) = 0 end do end subroutine tree_sort @ %def tree_sort @ \subsection{Cascade set generation} These procedures loop over cascades and build up the cascade set. After each iteration of the innermost loop, we set a breakpoint. s-channel: We use a nested scan to combine all cascades with all other cascades. <>= subroutine cascade_set_generate_s (cascade_set) type(cascade_set_t), intent(inout), target :: cascade_set type(cascade_t), pointer :: cascade1, cascade2 cascade1 => cascade_set%first LOOP1: do while (associated (cascade1)) cascade2 => cascade_set%first LOOP2: do while (associated (cascade2)) if (cascade2%index >= cascade1%index) exit LOOP2 if (cascade1 .disjunct. cascade2) then call cascade_match_pair (cascade_set, cascade1, cascade2, .true.) end if call terminate_now_if_signal () cascade2 => cascade2%next end do LOOP2 cascade1 => cascade1%next end do LOOP1 end subroutine cascade_set_generate_s @ %def cascade_set_generate_s @ The t-channel cascades are directed and have a seed (one of the incoming particles) and a target (the other one). We loop over all possible seeds and targets. Inside this, we loop over all t-channel cascades ([[cascade1]]) and s-channel cascades ([[cascade2]]) and try to combine them. <>= subroutine cascade_set_generate_t (cascade_set, pos_seed, pos_target) type(cascade_set_t), intent(inout), target :: cascade_set integer, intent(in) :: pos_seed, pos_target type(cascade_t), pointer :: cascade_seed, cascade_target type(cascade_t), pointer :: cascade1, cascade2 integer(TC) :: bc_seed, bc_target bc_seed = ibset (0_TC, pos_seed-1) bc_target = ibset (0_TC, pos_target-1) cascade_seed => cascade_set%first_t LOOP_SEED: do while (associated (cascade_seed)) if (cascade_seed%bincode == bc_seed) then cascade_target => cascade_set%first_t LOOP_TARGET: do while (associated (cascade_target)) if (cascade_target%bincode == bc_target) then cascade1 => cascade_set%first_t LOOP_T: do while (associated (cascade1)) if ((cascade1 .disjunct. cascade_target) & .and. .not. (cascade1 .disjunct. cascade_seed)) then cascade2 => cascade_set%first LOOP_S: do while (associated (cascade2)) if ((cascade2 .disjunct. cascade_target) & .and. (cascade2 .disjunct. cascade1)) then call cascade_match_pair & (cascade_set, cascade1, cascade2, .false.) end if call terminate_now_if_signal () cascade2 => cascade2%next end do LOOP_S end if call terminate_now_if_signal () cascade1 => cascade1%next end do LOOP_T end if call terminate_now_if_signal () cascade_target => cascade_target%next end do LOOP_TARGET end if call terminate_now_if_signal () cascade_seed => cascade_seed%next end do LOOP_SEED end subroutine cascade_set_generate_t @ %def cascade_set_generate_t @ This part completes the phase space for decay processes. It is similar to s-channel cascade generation, but combines two cascade with the particular cascade of the incoming particle. This particular cascade is expected to be pointed at by [[first_t]]. <>= subroutine cascade_set_generate_decay (cascade_set) type(cascade_set_t), intent(inout), target :: cascade_set type(cascade_t), pointer :: cascade1, cascade2 type(cascade_t), pointer :: cascade_in cascade_in => cascade_set%first_t cascade1 => cascade_set%first do while (associated (cascade1)) if (cascade1 .disjunct. cascade_in) then cascade2 => cascade1%next do while (associated (cascade2)) if ((cascade2 .disjunct. cascade1) & .and. (cascade2 .disjunct. cascade_in)) then call cascade_match_triplet (cascade_set, & cascade1, cascade2, cascade_in, .true.) end if call terminate_now_if_signal () cascade2 => cascade2%next end do end if call terminate_now_if_signal () cascade1 => cascade1%next end do end subroutine cascade_set_generate_decay @ %def cascade_set_generate_decay @ This part completes the phase space for scattering processes. We combine a t-channel cascade (containing the seed) with a s-channel cascade and the target. <>= subroutine cascade_set_generate_scattering & (cascade_set, ns1, ns2, nt1, nt2, pos_seed, pos_target) type(cascade_set_t), intent(inout), target :: cascade_set integer, intent(in) :: pos_seed, pos_target integer, intent(in) :: ns1, ns2, nt1, nt2 type(cascade_t), pointer :: cascade_seed, cascade_target type(cascade_t), pointer :: cascade1, cascade2 integer(TC) :: bc_seed, bc_target bc_seed = ibset (0_TC, pos_seed-1) bc_target = ibset (0_TC, pos_target-1) cascade_seed => cascade_set%first_t LOOP_SEED: do while (associated (cascade_seed)) if (cascade_seed%index < ns1) then cascade_seed => cascade_seed%next cycle LOOP_SEED else if (cascade_seed%index > ns2) then exit LOOP_SEED else if (cascade_seed%bincode == bc_seed) then cascade_target => cascade_set%first_t LOOP_TARGET: do while (associated (cascade_target)) if (cascade_target%index < nt1) then cascade_target => cascade_target%next cycle LOOP_TARGET else if (cascade_target%index > nt2) then exit LOOP_TARGET else if (cascade_target%bincode == bc_target) then cascade1 => cascade_set%first_t LOOP_T: do while (associated (cascade1)) if ((cascade1 .disjunct. cascade_target) & .and. .not. (cascade1 .disjunct. cascade_seed)) then cascade2 => cascade_set%first LOOP_S: do while (associated (cascade2)) if ((cascade2 .disjunct. cascade_target) & .and. (cascade2 .disjunct. cascade1)) then call cascade_match_triplet (cascade_set, & cascade1, cascade2, cascade_target, .false.) end if call terminate_now_if_signal () cascade2 => cascade2%next end do LOOP_S end if call terminate_now_if_signal () cascade1 => cascade1%next end do LOOP_T end if call terminate_now_if_signal () cascade_target => cascade_target%next end do LOOP_TARGET end if call terminate_now_if_signal () cascade_seed => cascade_seed%next end do LOOP_SEED end subroutine cascade_set_generate_scattering @ %def cascade_set_generate_scattering @ \subsection{Groves} Before assigning groves, assign hashcodes to the resonance patterns, so they can easily be compared. <>= subroutine cascade_set_assign_resonance_hash (cascade_set) type(cascade_set_t), intent(inout) :: cascade_set type(cascade_t), pointer :: cascade cascade => cascade_set%first_k do while (associated (cascade)) call cascade_assign_resonance_hash (cascade) cascade => cascade%next end do end subroutine cascade_set_assign_resonance_hash @ %def cascade_assign_resonance_hash @ After all cascades are recorded, we group the complete cascades in groves. A grove consists of cascades with identical multiplicity, number of resonances, log-enhanced, t-channel lines, and resonance flavors. <>= subroutine cascade_set_assign_groves (cascade_set) type(cascade_set_t), intent(inout), target :: cascade_set type(cascade_t), pointer :: cascade1, cascade2 integer :: multiplicity integer :: n_resonances, n_log_enhanced, n_t_channel, n_off_shell integer :: res_hash integer :: grove grove = 0 cascade1 => cascade_set%first_k do while (associated (cascade1)) if (cascade1%active .and. cascade1%complete & .and. cascade1%grove == 0) then grove = grove + 1 cascade1%grove = grove multiplicity = cascade1%multiplicity n_resonances = cascade1%n_resonances n_log_enhanced = cascade1%n_log_enhanced n_off_shell = cascade1%n_off_shell n_t_channel = cascade1%n_t_channel res_hash = cascade1%res_hash cascade2 => cascade1%next do while (associated (cascade2)) if (cascade2%grove == 0) then if (cascade2%multiplicity == multiplicity & .and. cascade2%n_resonances == n_resonances & .and. cascade2%n_log_enhanced == n_log_enhanced & .and. cascade2%n_off_shell == n_off_shell & .and. cascade2%n_t_channel == n_t_channel & .and. cascade2%res_hash == res_hash) then cascade2%grove = grove end if end if call terminate_now_if_signal () cascade2 => cascade2%next end do end if call terminate_now_if_signal () cascade1 => cascade1%next end do cascade_set%n_groves = grove end subroutine cascade_set_assign_groves @ %def cascade_set_assign_groves @ \subsection{Generate the phase space file} Generate a complete phase space configuration. For each flavor assignment: First, all s-channel graphs that can be built up from the outgoing particles. Then we distinguish (1) decay, where we complete the s-channel graphs by connecting to the input line, and (2) scattering, where we now generate t-channel graphs by introducing an incoming particle, and complete this by connecting to the other incoming particle. After all cascade sets have been generated, merge them into a common set. This eliminates redunancies between flavor assignments. <>= public :: cascade_set_generate +<>= + module subroutine cascade_set_generate & + (cascade_set, model, n_in, n_out, flv, phs_par, fatal_beam_decay) + type(cascade_set_t), intent(out) :: cascade_set + class(model_data_t), intent(in), target :: model + integer, intent(in) :: n_in, n_out + type(flavor_t), dimension(:,:), intent(in) :: flv + type(phs_parameters_t), intent(in) :: phs_par + logical, intent(in) :: fatal_beam_decay + end subroutine cascade_set_generate <>= - subroutine cascade_set_generate & + module subroutine cascade_set_generate & (cascade_set, model, n_in, n_out, flv, phs_par, fatal_beam_decay) type(cascade_set_t), intent(out) :: cascade_set class(model_data_t), intent(in), target :: model integer, intent(in) :: n_in, n_out type(flavor_t), dimension(:,:), intent(in) :: flv type(phs_parameters_t), intent(in) :: phs_par logical, intent(in) :: fatal_beam_decay type(cascade_set_t), dimension(:), allocatable :: cset type(cascade_t), pointer :: cascade integer :: i if (phase_space_vanishes (phs_par%sqrts, n_in, flv)) return call cascade_set_init (cascade_set, model, n_in, n_out, phs_par, & fatal_beam_decay, flv) allocate (cset (size (flv, 2))) do i = 1, size (cset) call cascade_set_generate_single (cset(i), & model, n_in, n_out, flv(:,i), phs_par, fatal_beam_decay) cascade => cset(i)%first_k do while (associated (cascade)) if (cascade%active .and. cascade%complete) then call cascade_set_add_copy (cascade_set, cascade) end if cascade => cascade%next end do call cascade_set_final (cset(i)) end do cascade_set%first_k => cascade_set%first call cascade_set_assign_resonance_hash (cascade_set) call cascade_set_assign_groves (cascade_set) end subroutine cascade_set_generate @ %def cascade_set_generate @ This generates phase space for a single channel, without assigning groves. <>= subroutine cascade_set_generate_single (cascade_set, & model, n_in, n_out, flv, phs_par, fatal_beam_decay) type(cascade_set_t), intent(out) :: cascade_set class(model_data_t), intent(in), target :: model integer, intent(in) :: n_in, n_out type(flavor_t), dimension(:), intent(in) :: flv type(phs_parameters_t), intent(in) :: phs_par logical, intent(in) :: fatal_beam_decay integer :: n11, n12, n21, n22 call cascade_set_init (cascade_set, model, n_in, n_out, phs_par, & fatal_beam_decay) call cascade_set_add_outgoing (cascade_set, flv(n_in+1:)) call cascade_set_generate_s (cascade_set) select case (n_in) case(1) call cascade_set_add_incoming & (cascade_set, n11, n12, n_out + 1, flv(1)) call cascade_set_generate_decay (cascade_set) case(2) call cascade_set_add_incoming & (cascade_set, n11, n12, n_out + 1, flv(2)) call cascade_set_add_incoming & (cascade_set, n21, n22, n_out + 2, flv(1)) call cascade_set_generate_t (cascade_set, n_out + 1, n_out + 2) call cascade_set_generate_t (cascade_set, n_out + 2, n_out + 1) call cascade_set_generate_scattering & (cascade_set, n11, n12, n21, n22, n_out + 1, n_out + 2) call cascade_set_generate_scattering & (cascade_set, n21, n22, n11, n12, n_out + 2, n_out + 1) end select end subroutine cascade_set_generate_single @ %def cascade_set_generate_single @ Sanity check: Before anything else is done, check if there could possibly be any phase space. <>= public :: phase_space_vanishes +<>= + module function phase_space_vanishes (sqrts, n_in, flv) result (flag) + logical :: flag + real(default), intent(in) :: sqrts + integer, intent(in) :: n_in + type(flavor_t), dimension(:,:), intent(in) :: flv + end function phase_space_vanishes <>= - function phase_space_vanishes (sqrts, n_in, flv) result (flag) + module function phase_space_vanishes (sqrts, n_in, flv) result (flag) logical :: flag real(default), intent(in) :: sqrts integer, intent(in) :: n_in type(flavor_t), dimension(:,:), intent(in) :: flv real(default), dimension(:,:), allocatable :: mass real(default), dimension(:), allocatable :: mass_in, mass_out integer :: n_prt, n_flv, i, j flag = .false. if (sqrts <= 0) then call msg_error ("Phase space vanishes (sqrts must be positive)") flag = .true.; return end if n_prt = size (flv, 1) n_flv = size (flv, 2) allocate (mass (n_prt, n_flv), mass_in (n_flv), mass_out (n_flv)) mass = flv%get_mass () mass_in = sum (mass(:n_in,:), 1) mass_out = sum (mass(n_in+1:,:), 1) if (any (mass_in > sqrts)) then call msg_error ("Mass sum of incoming particles " & // "is more than available energy") flag = .true.; return end if if (any (mass_out > sqrts)) then call msg_error ("Mass sum of outgoing particles " & // "is more than available energy") flag = .true.; return end if end function phase_space_vanishes @ %def phase_space_vanishes @ \subsection{Return the resonance histories for subtraction} This appears to be essential (re-export of some imported assignment?)! <>= public :: assignment(=) @ Extract the resonance set from a complete cascade. <>= procedure :: extract_resonance_history => cascade_extract_resonance_history +<>= + module subroutine cascade_extract_resonance_history & + (cascade, res_hist, model, n_out) + class(cascade_t), intent(in), target :: cascade + type(resonance_history_t), intent(out) :: res_hist + class(model_data_t), intent(in), target :: model + integer, intent(in) :: n_out + end subroutine cascade_extract_resonance_history <>= - subroutine cascade_extract_resonance_history & + module subroutine cascade_extract_resonance_history & (cascade, res_hist, model, n_out) class(cascade_t), intent(in), target :: cascade type(resonance_history_t), intent(out) :: res_hist class(model_data_t), intent(in), target :: model integer, intent(in) :: n_out type(resonance_info_t) :: resonance integer :: i, mom_id, pdg if (debug_on) call msg_debug2 (D_PHASESPACE, "cascade_extract_resonance_history") if (cascade%n_resonances > 0) then if (cascade%has_children) then if (debug_on) call msg_debug2 (D_PHASESPACE, "cascade has resonances and children") do i = 1, size(cascade%tree_resonant) if (cascade%tree_resonant (i)) then mom_id = cascade%tree (i) pdg = cascade%tree_pdg (i) call resonance%init (mom_id, pdg, model, n_out) if (debug2_active (D_PHASESPACE)) then print *, 'D: Adding resonance' call resonance%write () end if call res_hist%add_resonance (resonance) end if end do end if end if end subroutine cascade_extract_resonance_history @ %def cascade_extract_resonance_history @ <>= public :: cascade_set_get_n_trees +<>= + module function cascade_set_get_n_trees (cascade_set) result (n) + type(cascade_set_t), intent(in), target :: cascade_set + integer :: n + end function cascade_set_get_n_trees <>= - function cascade_set_get_n_trees (cascade_set) result (n) + module function cascade_set_get_n_trees (cascade_set) result (n) type(cascade_set_t), intent(in), target :: cascade_set integer :: n type(cascade_t), pointer :: cascade integer :: grove if (debug_on) call msg_debug (D_PHASESPACE, "cascade_set_get_n_trees") n = 0 do grove = 1, cascade_set%n_groves cascade => cascade_set%first_k do while (associated (cascade)) if (cascade%active .and. cascade%complete) then if (cascade%grove == grove) then n = n + 1 end if end if cascade => cascade%next end do end do if (debug_on) call msg_debug (D_PHASESPACE, "n", n) end function cascade_set_get_n_trees @ %def cascade_set_get_n_trees @ Distill the set of resonance histories from the cascade set. The result is an array which contains each valid history exactly once. <>= public :: cascade_set_get_resonance_histories +<>= + module subroutine cascade_set_get_resonance_histories & + (cascade_set, n_filter, res_hists) + type(cascade_set_t), intent(in), target :: cascade_set + integer, intent(in), optional :: n_filter + type(resonance_history_t), dimension(:), allocatable, intent(out) :: & + res_hists + end subroutine cascade_set_get_resonance_histories <>= - subroutine cascade_set_get_resonance_histories (cascade_set, n_filter, res_hists) + module subroutine cascade_set_get_resonance_histories & + (cascade_set, n_filter, res_hists) type(cascade_set_t), intent(in), target :: cascade_set integer, intent(in), optional :: n_filter - type(resonance_history_t), dimension(:), allocatable, intent(out) :: res_hists + type(resonance_history_t), dimension(:), allocatable, intent(out) :: & + res_hists type(resonance_history_t), dimension(:), allocatable :: tmp type(cascade_t), pointer :: cascade type(resonance_history_t) :: res_hist type(resonance_history_set_t) :: res_hist_set integer :: grove, i, n_hists logical :: included, add_to_list - if (debug_on) call msg_debug (D_PHASESPACE, "cascade_set_get_resonance_histories") + if (debug_on) call msg_debug & + (D_PHASESPACE, "cascade_set_get_resonance_histories") call res_hist_set%init (n_filter = n_filter) do grove = 1, cascade_set%n_groves cascade => cascade_set%first_k do while (associated (cascade)) if (cascade%active .and. cascade%complete) then if (cascade%grove == grove) then if (debug_on) call msg_debug2 (D_PHASESPACE, "grove", grove) call cascade%extract_resonance_history & (res_hist, cascade_set%model, cascade_set%n_out) call res_hist_set%enter (res_hist) end if end if cascade => cascade%next end do end do call res_hist_set%freeze () call res_hist_set%to_array (res_hists) end subroutine cascade_set_get_resonance_histories @ %def cascade_set_get_resonance_histories @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[cascades_ut.f90]]>>= <> module cascades_ut use unit_tests use cascades_uti <> <> contains <> end module cascades_ut @ %def cascades_ut @ <<[[cascades_uti.f90]]>>= <> module cascades_uti <> <> use numeric_utils use flavors use model_data use phs_forests, only: phs_parameters_t use resonances, only: resonance_history_t use cascades <> <> contains <> end module cascades_uti @ %def cascades_ut @ API: driver for the unit tests below. <>= public :: cascades_test <>= subroutine cascades_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine cascades_test @ %def cascades_test \subsubsection{Check cascade setup} @ Checking the basic setup up of the phase space cascade parameterizations. <>= call test (cascades_1, "cascades_1", & "check cascade setup", & u, results) <>= public :: cascades_1 <>= subroutine cascades_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t), dimension(5,2) :: flv type(cascade_set_t) :: cascade_set type(phs_parameters_t) :: phs_par write (u, "(A)") "* Test output: cascades_1" write (u, "(A)") "* Purpose: test cascade phase space functions" write (u, "(A)") write (u, "(A)") "* Initializing" write (u, "(A)") call model%init_sm_test () call flv(1,1)%init ( 2, model) call flv(2,1)%init (-2, model) call flv(3,1)%init ( 1, model) call flv(4,1)%init (-1, model) call flv(5,1)%init (21, model) call flv(1,2)%init ( 2, model) call flv(2,2)%init (-2, model) call flv(3,2)%init ( 2, model) call flv(4,2)%init (-2, model) call flv(5,2)%init (21, model) phs_par%sqrts = 1000._default phs_par%off_shell = 2 write (u, "(A)") write (u, "(A)") "* Generating the cascades" write (u, "(A)") call cascade_set_generate (cascade_set, model, 2, 3, flv, phs_par,.true.) call cascade_set_write (cascade_set, u) call cascade_set_write_file_format (cascade_set, u) write (u, "(A)") "* Cleanup" write (u, "(A)") call cascade_set_final (cascade_set) call model%final () write (u, *) write (u, "(A)") "* Test output end: cascades_1" end subroutine cascades_1 @ %def cascades_1 @ \subsubsection{Check resonance history} <>= call test(cascades_2, "cascades_2", & "Check resonance history", u, results) <>= public :: cascades_2 <>= subroutine cascades_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t), dimension(5,1) :: flv type(cascade_set_t) :: cascade_set type(phs_parameters_t) :: phs_par type(resonance_history_t), dimension(:), allocatable :: res_hists integer :: n, i write (u, "(A)") "* Test output: cascades_2" write (u, "(A)") "* Purpose: Check resonance history" write (u, "(A)") write (u, "(A)") "* Initializing" write (u, "(A)") call model%init_sm_test () call flv(1,1)%init ( 2, model) call flv(2,1)%init (-2, model) call flv(3,1)%init ( 1, model) call flv(4,1)%init (-1, model) call flv(5,1)%init (22, model) phs_par%sqrts = 1000._default phs_par%off_shell = 2 write (u, "(A)") write (u, "(A)") "* Generating the cascades" write (u, "(A)") call cascade_set_generate (cascade_set, model, 2, 3, flv, phs_par,.true.) call cascade_set_get_resonance_histories (cascade_set, res_hists = res_hists) n = cascade_set_get_n_trees (cascade_set) call assert_equal (u, n, 24, "Number of trees") do i = 1, size(res_hists) call res_hists(i)%write (u) write (u, "(A)") end do write (u, "(A)") "* Cleanup" write (u, "(A)") call cascade_set_final (cascade_set) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: cascades_2" end subroutine cascades_2 @ %def cascades_2 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{WOOD phase space} - -This is the module that interfaces the [[phs_forests]] phase-space -treatment and the [[cascades]] module for generating phase-space -channels. As an extension of the [[phs_base]] abstract type, -the phase-space configuration and instance implement the standard API. - -(Currently, this is the only generic phase-space implementation of -\whizard. For trivial two-particle phase space, there is -[[phs_wood]] as an alternative.) -<<[[phs_wood.f90]]>>= +\section{A lexer for O'Mega's phase-space output} +This module provides three data types. One of them is the type +[[dag_string_t]] which should contain the information of all Feynman +diagrams in the factorized form which is provided by O'Mega in its +phase-space outout. This output is translated into a string of tokens (in +the form of an a array of the type [[dag_token_t]]) which have a certain +meaning. The purpose of this module is only to identify these tokens +correctly and to provide some procedures and interfaces which allow us to +use these strings in a similar way as variables of the basic character +type or the type [[iso_varying_string]]. Both [[character]] and +[[iso_varying_string]] have some disadvantages at least if one wants to +keep support for some older compiler versions. These can be circumvented +by the [[dag_string_t]] type. Finally the [[dag_chain_t]] type is used +to create a larger string in several steps without always recreating the +string, which is done in the form of a simple linked list. In the end +one can create a single [[dag_string]] out of this list, which is more +useful. +<<[[cascades2_lexer.f90]]>>= <> -module phs_wood +module cascades2_lexer <> -<> - use io_units - use constants - use numeric_utils - use diagnostics - use os_interface - use md5 - use physics_defs - use lorentz - use model_data - use flavors - use process_constants - use sf_mappings - use sf_base - use phs_base - use mappings - use resonances, only: resonance_history_set_t - use phs_forests - use cascades - use cascades2 + use kinds, only: TC, i8 <> -<> +<> -<> +<> -contains +<> -<> +<> -end module phs_wood -@ %def phs_wood -@ -\subsection{Configuration} -<>= - public :: phs_wood_config_t -<>= - type, extends (phs_config_t) :: phs_wood_config_t - character(32) :: md5sum_forest = "" - type(string_t) :: phs_path - integer :: io_unit = 0 - logical :: io_unit_keep_open = .false. - logical :: use_equivalences = .false. - logical :: fatal_beam_decay = .true. - type(mapping_defaults_t) :: mapping_defaults - type(phs_parameters_t) :: par - type(string_t) :: run_id - type(cascade_set_t), allocatable :: cascade_set - logical :: use_cascades2 = .false. - type(feyngraph_set_t), allocatable :: feyngraph_set - type(phs_forest_t) :: forest - type(os_data_t) :: os_data - logical :: is_combined_integration = .false. - contains - <> - end type phs_wood_config_t + interface +<> + end interface -@ %def phs_wood_config_t -@ Finalizer. We should delete the cascade set and the forest subobject. +end module cascades2_lexer -Also close the I/O unit, just in case. (We assume that [[io_unit]] is -not standard input/output.) -<>= - procedure :: final => phs_wood_config_final -<>= - subroutine phs_wood_config_final (object) - class(phs_wood_config_t), intent(inout) :: object - logical :: opened - if (object%io_unit /= 0) then - inquire (unit = object%io_unit, opened = opened) - if (opened) close (object%io_unit) - end if - call object%clear_phase_space () - call phs_forest_final (object%forest) - end subroutine phs_wood_config_final +@ %def cascades2_lexer +@ +<<[[cascades2_lexer_sub.f90]]>>= +<> -@ %def phs_wood_config_final -@ -<>= - procedure :: increase_n_par => phs_wood_config_increase_n_par -<>= - subroutine phs_wood_config_increase_n_par (phs_config) - class(phs_wood_config_t), intent(inout) :: phs_config - if (phs_config%is_combined_integration) then - phs_config%n_par = phs_config%n_par + 3 - end if - end subroutine phs_wood_config_increase_n_par +submodule (cascades2_lexer) cascades2_lexer_s -@ %def phs_wood_config_increase_n_par -@ Output. The contents of the PHS forest are not printed explicitly. -<>= - procedure :: write => phs_wood_config_write -<>= - subroutine phs_wood_config_write (object, unit, include_id) - class(phs_wood_config_t), intent(in) :: object - integer, intent(in), optional :: unit - logical, intent(in), optional :: include_id - integer :: u - u = given_output_unit (unit) - write (u, "(1x,A)") & - "Partonic phase-space configuration (phase-space forest):" - call object%base_write (unit) - write (u, "(1x,A)") "Phase-space configuration parameters:" - call object%par%write (u) - call object%mapping_defaults%write (u) - write (u, "(3x,A,A,A)") "Run ID: '", char (object%run_id), "'" - end subroutine phs_wood_config_write + implicit none -@ %def phs_wood_config_write -@ Print the PHS forest contents. -<>= - procedure :: write_forest => phs_wood_config_write_forest -<>= - subroutine phs_wood_config_write_forest (object, unit) - class(phs_wood_config_t), intent(in) :: object - integer, intent(in), optional :: unit - integer :: u - u = given_output_unit (unit) - call phs_forest_write (object%forest, u) - end subroutine phs_wood_config_write_forest +contains -@ %def phs_wood_config_write_forest -@ Set the phase-space parameters that the configuration generator requests. -<>= - procedure :: set_parameters => phs_wood_config_set_parameters -<>= - subroutine phs_wood_config_set_parameters (phs_config, par) - class(phs_wood_config_t), intent(inout) :: phs_config - type(phs_parameters_t), intent(in) :: par - phs_config%par = par - end subroutine phs_wood_config_set_parameters +<> -@ %def phs_wood_config_set_parameters -@ Enable the generation of channel equivalences (when calling [[configure]]). -<>= - procedure :: enable_equivalences => phs_wood_config_enable_equivalences -<>= - subroutine phs_wood_config_enable_equivalences (phs_config) - class(phs_wood_config_t), intent(inout) :: phs_config - phs_config%use_equivalences = .true. - end subroutine phs_wood_config_enable_equivalences +end submodule cascades2_lexer_s -@ %def phs_wood_config_enable_equivalences -@ Set the phase-space mapping parameters that the configuration generator -requests.g -<>= - procedure :: set_mapping_defaults => phs_wood_config_set_mapping_defaults -<>= - subroutine phs_wood_config_set_mapping_defaults (phs_config, mapping_defaults) - class(phs_wood_config_t), intent(inout) :: phs_config - type(mapping_defaults_t), intent(in) :: mapping_defaults - phs_config%mapping_defaults = mapping_defaults - end subroutine phs_wood_config_set_mapping_defaults +@ %def cascades2_lexer_s +@ +This is the token type. By default the variable [[type]] is [[EMPTY_TK]] +but can obtain other values corresponding to the parameters defined below. +The type of the token corresponds to a particular sequence of characters. +When the token corresponds to a node of a tree, i.e. some particle in the +Feynman diagram, the type is [[NODE_TK]] and the [[particle_name]] variable +is holding the name of the particle. O'Megas output contains in +addition to the particle name some numbers which indicate the external +momenta that are flowing through this line. These numbers are translated +into a binary code and saved in the variable [[bincode]]. In this case +the number 1 corresponds to a bit set at position 0, 2 corresponds to a +bit set at position 1, etc. Instead of numbers which are composed out of +several digits, letters are used, i.e. A instead of 10 (bit at position 9), +B instead of 11 (bit at position 10), etc.\\ +When the DAG is reconstructed from a [[dag_string]] which was built from +O'Mega's output, this string is modified such that a substring (a set of +tokens) is replaced by a single token where the type variable is one of +the three parameters [[DAG_NODE_TK]], [[DAG_OPTIONS_TK]] and +[[DAG_COMBINATION_TK]]. These parameters correspond to the three types +[[dag_node_t]], [[dag_options_t]] and [[dag_combination_t]] (see [[cascades2]] +for more information. In this case, since these objects are organized +in arrays, the [[index]] variable holds the corresponding position in +the array.\\ +In any case, we want to be able to reproduce the character string from +which a token (or a string) has been created. The variable [[char_len]] +is the length of this string. For tokens with the type [[DAG_NODE_TK]], +[[DAG_OPTIONS_TK]] and [[DAG_COMBINATION_TK]] we use output of the form +[[]], [[]] or [[]] which is useful for debugging the parser. +Here 23 is the [[index]] and [[N]], [[O]] or [[C]] obviously corresponds +to the [[type]]. +<>= + integer, parameter :: PRT_NAME_LEN = 20 +@ %def PRT_NAME_LEN +<>= + public :: dag_token_t +<>= + type :: dag_token_t + integer :: type = EMPTY_TK + integer :: char_len = 0 + integer(TC) :: bincode = 0 + character(len=PRT_NAME_LEN) :: particle_name="" + integer :: index = 0 + contains + <> + end type dag_token_t -@ %def phs_wood_config_set_mapping_defaults -@ Define the input stream for the phase-space file as an open logical unit. -The unit must be connected. -<>= - procedure :: set_input => phs_wood_config_set_input -<>= - subroutine phs_wood_config_set_input (phs_config, unit) - class(phs_wood_config_t), intent(inout) :: phs_config - integer, intent(in) :: unit - phs_config%io_unit = unit - rewind (unit) - end subroutine phs_wood_config_set_input +@ %def dag_token_t +@ This is the string type. It also holds the number of characters in the +corresponding character string. It contains an array of tokens. If the +[[dag_string]] is constructed using the type [[dag_chain_t]], which creates +a linked list, we also need the pointer [[next]]. +<>= + public :: dag_string_t +<>= + type :: dag_string_t + integer :: char_len = 0 + type(dag_token_t), dimension(:), allocatable :: t + type(dag_string_t), pointer :: next => null () + contains + <> + end type dag_string_t -@ %def phs_wood_config_set_input -@ -\subsection{Phase-space generation} -This subroutine generates a phase space configuration using the -[[cascades]] module. Note that this may take time, and the -[[cascade_set]] subobject may consume a large amount of memory. -<>= - procedure :: generate_phase_space => phs_wood_config_generate_phase_space -<>= - subroutine phs_wood_config_generate_phase_space (phs_config) - class(phs_wood_config_t), intent(inout) :: phs_config - integer :: off_shell, extra_off_shell - logical :: valid - integer :: unit_fds - type(string_t) :: file_name - logical :: file_exists - call msg_message ("Phase space: generating configuration ...") - off_shell = phs_config%par%off_shell - if (phs_config%use_cascades2) then - file_name = char (phs_config%id) // ".fds" - inquire (file=char (file_name), exist=file_exists) - if (.not. file_exists) call msg_fatal & - ("The O'Mega input file " // char (file_name) // & - " does not exist. " // "Please make sure that the " // & - "variable ?omega_write_phs_output has been set correctly.") - unit_fds = free_unit () - open (unit=unit_fds, file=char(file_name), status='old', action='read') - do extra_off_shell = 0, max (phs_config%n_tot - 3, 0) - phs_config%par%off_shell = off_shell + extra_off_shell - allocate (phs_config%feyngraph_set) - call feyngraph_set_generate (phs_config%feyngraph_set, & - phs_config%model, phs_config%n_in, phs_config%n_out, & - phs_config%flv, & - phs_config%par, phs_config%fatal_beam_decay, unit_fds, & - phs_config%vis_channels) - if (feyngraph_set_is_valid (phs_config%feyngraph_set)) then - exit - else - call msg_message ("Phase space: ... failed. & - &Increasing phs_off_shell ...") - call phs_config%feyngraph_set%final () - deallocate (phs_config%feyngraph_set) - end if - end do - close (unit_fds) +@ %def dag_string_t +@ This is the chain of [[dag_strings]]. It allows us to construct a large +string by appending new strings to the linked list, which can later be +merged to a single string. This is very useful because the file written +by O'Mega contains large strings where each string contains all Feynman +diagrams in a factorized form, but these large strings are cut into +several pieces and distributed over many lines. As the file can become +large, rewriting a new [[dag_string]] (or [[iso_varying_string]]) would +consume more and more time with each additional line. For recreating a +single [[dag_string]] out of this chain, we need the total character +length and the sum of all sizes of the [[dag_token]] arrays [[t]]. +<>= + public :: dag_chain_t +<>= + type :: dag_chain_t + integer :: char_len = 0 + integer :: t_size = 0 + type(dag_string_t), pointer :: first => null () + type(dag_string_t), pointer :: last => null () + contains + <> + end type dag_chain_t + +@ %def dag_chain_t +@ We define two parameters holding the characters corresponding to a +backslash and a blanc space. +<>= + character(len=1), parameter, public :: BACKSLASH_CHAR = "\\" + character(len=1), parameter :: BLANC_CHAR = " " +@ %def BACKSLASH_CHAR BLANC_CHAR +@ These are the parameters which correspond to meaningful types +of [[token]]. +<>= + integer, parameter, public :: NEW_LINE_TK = -2 + integer, parameter :: BLANC_SPACE_TK = -1 + integer, parameter :: EMPTY_TK = 0 + integer, parameter, public :: NODE_TK = 1 + integer, parameter, public :: DAG_NODE_TK = 2 + integer, parameter, public :: DAG_OPTIONS_TK = 3 + integer, parameter, public :: DAG_COMBINATION_TK = 4 + integer, parameter, public :: COLON_TK = 11 + integer, parameter, public :: COMMA_TK = 12 + integer, parameter, public :: VERTICAL_BAR_TK = 13 + integer, parameter, public :: OPEN_PAR_TK = 21 + integer, parameter, public :: CLOSED_PAR_TK = 22 + integer, parameter, public :: OPEN_CURLY_TK = 31 + integer, parameter, public :: CLOSED_CURLY_TK = 32 + +@ %def NEW_LINE_TK BLANC_SPACE_TK EMPTY_TK NODE_TK +@ %def COLON_TK COMMA_TK VERTICAL_LINE_TK OPEN_PAR_TK +@ %def CLOSED_PAR_TK OPEN_CURLY_TK CLOSED_CURLY_TK +@ Different sorts of assignment. This contains the conversion +of a [[character]] variable into a [[dag_token]] or [[dag_string]]. +<>= + public :: assignment (=) +<>= + interface assignment (=) + module procedure dag_token_assign_from_char_string + module procedure dag_token_assign_from_dag_token + module procedure dag_string_assign_from_dag_token + module procedure dag_string_assign_from_char_string + module procedure dag_string_assign_from_dag_string + module procedure dag_string_assign_from_dag_token_array + end interface assignment (=) + +@ %def interfaces +<>= + procedure :: init_dag_object_token => dag_token_init_dag_object_token +<>= + module subroutine dag_token_init_dag_object_token (dag_token, type, index) + class(dag_token_t), intent(out) :: dag_token + integer, intent(in) :: index + integer :: type + end subroutine dag_token_init_dag_object_token +<>= + module subroutine dag_token_init_dag_object_token (dag_token, type, index) + class(dag_token_t), intent(out) :: dag_token + integer, intent(in) :: index + integer :: type + dag_token%type = type + dag_token%char_len = integer_n_dec_digits (index) + 3 + dag_token%index = index + contains + function integer_n_dec_digits (number) result (n_digits) + integer, intent(in) :: number + integer :: n_digits + integer :: div_number + n_digits = 0 + div_number = number + do + div_number = div_number / 10 + n_digits = n_digits + 1 + if (div_number == 0) exit + end do + end function integer_n_dec_digits + end subroutine dag_token_init_dag_object_token + +@ %def dag_token_init_dag_object_token +<>= + elemental module subroutine dag_token_assign_from_char_string & + (dag_token, char_string) + type(dag_token_t), intent(out) :: dag_token + character(len=*), intent(in) :: char_string + end subroutine dag_token_assign_from_char_string +<>= + elemental module subroutine dag_token_assign_from_char_string & + (dag_token, char_string) + type(dag_token_t), intent(out) :: dag_token + character(len=*), intent(in) :: char_string + integer :: i, j + logical :: set_bincode + integer :: bit_pos + character(len=10) :: index_char + dag_token%char_len = len (char_string) + if (dag_token%char_len == 1) then + select case (char_string(1:1)) + case (BACKSLASH_CHAR) + dag_token%type = NEW_LINE_TK + case (" ") + dag_token%type = BLANC_SPACE_TK + case (":") + dag_token%type = COLON_TK + case (",") + dag_token%type = COMMA_TK + case ("|") + dag_token%type = VERTICAL_BAR_TK + case ("(") + dag_token%type = OPEN_PAR_TK + case (")") + dag_token%type = CLOSED_PAR_TK + case ("{") + dag_token%type = OPEN_CURLY_TK + case ("}") + dag_token%type = CLOSED_CURLY_TK + end select + else if (char_string(1:1) == "<") then + select case (char_string(2:2)) + case ("N") + dag_token%type = DAG_NODE_TK + case ("O") + dag_token%type = DAG_OPTIONS_TK + case ("C") + dag_token%type = DAG_COMBINATION_TK + end select + read(char_string(3:dag_token%char_len-1), fmt="(I10)") dag_token%index else - allocate (phs_config%cascade_set) - do extra_off_shell = 0, max (phs_config%n_tot - 3, 0) - phs_config%par%off_shell = off_shell + extra_off_shell - call cascade_set_generate (phs_config%cascade_set, & - phs_config%model, phs_config%n_in, phs_config%n_out, & - phs_config%flv, & - phs_config%par, phs_config%fatal_beam_decay) - if (cascade_set_is_valid (phs_config%cascade_set)) then - exit - else - call msg_message ("Phase space: ... failed. & - &Increasing phs_off_shell ...") - end if + dag_token%bincode = 0 + set_bincode = .false. + do i=1, dag_token%char_len + select case (char_string(i:i)) + case ("[") + dag_token%type = NODE_TK + if (i > 1) then + do j = 1, i - 1 + dag_token%particle_name(j:j) = char_string(j:j) + end do + end if + set_bincode = .true. + case ("]") + set_bincode = .false. + case default + dag_token%type = NODE_TK + if (set_bincode) then + select case (char_string(i:i)) + case ("1", "2", "3", "4", "5", "6", "7", "8", "9") + read (char_string(i:i), fmt="(I1)") bit_pos + case ("A") + bit_pos = 10 + case ("B") + bit_pos = 11 + case ("C") + bit_pos = 12 + end select + dag_token%bincode = ibset(dag_token%bincode, bit_pos - 1) + end if + end select + if (dag_token%type /= NODE_TK) exit end do end if - if (phs_config%use_cascades2) then - valid = feyngraph_set_is_valid (phs_config%feyngraph_set) - else - valid = cascade_set_is_valid (phs_config%cascade_set) - end if - if (valid) then - call msg_message ("Phase space: ... success.") - else - call msg_fatal ("Phase-space: generation failed") - end if - end subroutine phs_wood_config_generate_phase_space + end subroutine dag_token_assign_from_char_string -@ %def phs_wood_config_generate_phase_space -@ Using the generated phase-space configuration, write an appropriate -phase-space file to the stored (or explicitly specified) I/O unit. -<>= - procedure :: write_phase_space => phs_wood_config_write_phase_space -<>= - subroutine phs_wood_config_write_phase_space (phs_config, & - filename_vis, unit) - class(phs_wood_config_t), intent(in) :: phs_config - integer, intent(in), optional :: unit - type(string_t), intent(in), optional :: filename_vis - type(string_t) :: setenv_tex, setenv_mp, pipe, pipe_dvi - integer :: u, unit_tex, unit_dev, status - if (allocated (phs_config%cascade_set) .or. allocated (phs_config%feyngraph_set)) then - if (present (unit)) then - u = unit - else - u = phs_config%io_unit - end if - write (u, "(1x,A,A)") "process ", char (phs_config%id) - write (u, "(A)") - if (phs_config%use_cascades2) then - call feyngraph_set_write_process_bincode_format (phs_config%feyngraph_set, u) - else - call cascade_set_write_process_bincode_format (phs_config%cascade_set, u) - end if - write (u, "(A)") - write (u, "(3x,A,A,A32,A)") "md5sum_process = ", & - '"', phs_config%md5sum_process, '"' - write (u, "(3x,A,A,A32,A)") "md5sum_model_par = ", & - '"', phs_config%md5sum_model_par, '"' - write (u, "(3x,A,A,A32,A)") "md5sum_phs_config = ", & - '"', phs_config%md5sum_phs_config, '"' - call phs_config%par%write (u) - if (phs_config%use_cascades2) then - call feyngraph_set_write_file_format (phs_config%feyngraph_set, u) - else - call cascade_set_write_file_format (phs_config%cascade_set, u) - end if - if (phs_config%vis_channels) then - unit_tex = free_unit () - open (unit=unit_tex, file=char(filename_vis // ".tex"), & - action="write", status="replace") - if (phs_config%use_cascades2) then - call feyngraph_set_write_graph_format (phs_config%feyngraph_set, & - filename_vis // "-graphs", phs_config%id, unit_tex) - else - call cascade_set_write_graph_format (phs_config%cascade_set, & - filename_vis // "-graphs", phs_config%id, unit_tex) - end if - close (unit_tex) - call msg_message ("Phase space: visualizing channels in file " & - // char(trim(filename_vis)) // "...") - if (phs_config%os_data%event_analysis_ps) then - BLOCK: do - unit_dev = free_unit () - open (file = "/dev/null", unit = unit_dev, & - action = "write", iostat = status) - if (status /= 0) then - pipe = "" - pipe_dvi = "" - else - pipe = " > /dev/null" - pipe_dvi = " 2>/dev/null 1>/dev/null" - end if - close (unit_dev) - if (phs_config%os_data%whizard_texpath /= "") then - setenv_tex = "TEXINPUTS=" // & - phs_config%os_data%whizard_texpath // ":$TEXINPUTS " - setenv_mp = "MPINPUTS=" // & - phs_config%os_data%whizard_texpath // ":$MPINPUTS " - else - setenv_tex = "" - setenv_mp = "" - end if - call os_system_call (setenv_tex // & - phs_config%os_data%latex // " " // & - filename_vis // ".tex " // pipe, status) - if (status /= 0) exit BLOCK - if (phs_config%os_data%mpost /= "") then - call os_system_call (setenv_mp // & - phs_config%os_data%mpost // " " // & - filename_vis // "-graphs.mp" // pipe, status) - else - call msg_fatal ("Could not use MetaPOST.") - end if - if (status /= 0) exit BLOCK - call os_system_call (setenv_tex // & - phs_config%os_data%latex // " " // & - filename_vis // ".tex" // pipe, status) - if (status /= 0) exit BLOCK - call os_system_call & - (phs_config%os_data%dvips // " -o " // filename_vis & - // ".ps " // filename_vis // ".dvi" // pipe_dvi, status) - if (status /= 0) exit BLOCK - if (phs_config%os_data%event_analysis_pdf) then - call os_system_call (phs_config%os_data%ps2pdf // " " // & - filename_vis // ".ps", status) - if (status /= 0) exit BLOCK - end if - exit BLOCK - end do BLOCK - if (status /= 0) then - call msg_error ("Unable to compile analysis output file") +@ %def dag_token_assign_from_char_string +<>= + elemental module subroutine dag_token_assign_from_dag_token & + (token_out, token_in) + type(dag_token_t), intent(out) :: token_out + type(dag_token_t), intent(in) :: token_in + end subroutine dag_token_assign_from_dag_token +<>= + elemental module subroutine dag_token_assign_from_dag_token & + (token_out, token_in) + type(dag_token_t), intent(out) :: token_out + type(dag_token_t), intent(in) :: token_in + token_out%type = token_in%type + token_out%char_len = token_in%char_len + token_out%bincode = token_in%bincode + token_out%particle_name = token_in%particle_name + token_out%index = token_in%index + end subroutine dag_token_assign_from_dag_token + +@ %def dag_token_assign_from_dag_token +<>= + elemental module subroutine dag_string_assign_from_dag_token & + (dag_string, dag_token) + type(dag_string_t), intent(out) :: dag_string + type(dag_token_t), intent(in) :: dag_token + end subroutine dag_string_assign_from_dag_token +<>= + elemental module subroutine dag_string_assign_from_dag_token & + (dag_string, dag_token) + type(dag_string_t), intent(out) :: dag_string + type(dag_token_t), intent(in) :: dag_token + allocate (dag_string%t(1)) + dag_string%t(1) = dag_token + dag_string%char_len = dag_token%char_len + end subroutine dag_string_assign_from_dag_token + +@ %def dag_string_assign_from_dag_token +<>= + module subroutine dag_string_assign_from_dag_token_array & + (dag_string, dag_token) + type(dag_string_t), intent(out) :: dag_string + type(dag_token_t), dimension(:), intent(in) :: dag_token + end subroutine dag_string_assign_from_dag_token_array +<>= + module subroutine dag_string_assign_from_dag_token_array & + (dag_string, dag_token) + type(dag_string_t), intent(out) :: dag_string + type(dag_token_t), dimension(:), intent(in) :: dag_token + allocate (dag_string%t(size(dag_token))) + dag_string%t = dag_token + dag_string%char_len = sum(dag_token%char_len) + end subroutine dag_string_assign_from_dag_token_array + +@ %def dag_string_assign_from_dag_token_array +<>= + elemental module subroutine dag_string_assign_from_char_string & + (dag_string, char_string) + type(dag_string_t), intent(out) :: dag_string + character(len=*), intent(in) :: char_string + end subroutine dag_string_assign_from_char_string +<>= + elemental module subroutine dag_string_assign_from_char_string & + (dag_string, char_string) + type(dag_string_t), intent(out) :: dag_string + character(len=*), intent(in) :: char_string + type(dag_token_t), dimension(:), allocatable :: token + integer :: token_pos + integer :: i + character(len=len(char_string)) :: node_char + integer :: node_char_len + node_char = "" + dag_string%char_len = len (char_string) + if (dag_string%char_len > 0) then + allocate (token(dag_string%char_len)) + token_pos = 0 + node_char_len = 0 + do i=1, dag_string%char_len + select case (char_string(i:i)) + case (BACKSLASH_CHAR, " ", ":", ",", "|", "(", ")", "{", "}") + if (node_char_len > 0) then + token_pos = token_pos + 1 + token(token_pos) = node_char(:node_char_len) + node_char_len = 0 end if - end if + token_pos = token_pos + 1 + token(token_pos) = char_string(i:i) + case default + node_char_len = node_char_len + 1 + node_char(node_char_len:node_char_len) = char_string(i:i) + end select + end do + if (node_char_len > 0) then + token_pos = token_pos + 1 + token(token_pos) = node_char(:node_char_len) + end if + if (token_pos > 0) then + allocate (dag_string%t(token_pos)) + dag_string%t = token(:token_pos) + deallocate (token) end if - else - call msg_fatal ("Phase-space configuration: & - &no phase space object generated") end if - end subroutine phs_wood_config_write_phase_space + end subroutine dag_string_assign_from_char_string -@ %def phs_config_write_phase_space -@ Clear the phase-space configuration. This is useful since the -object may become \emph{really} large. -<>= - procedure :: clear_phase_space => phs_wood_config_clear_phase_space -<>= - subroutine phs_wood_config_clear_phase_space (phs_config) - class(phs_wood_config_t), intent(inout) :: phs_config - if (allocated (phs_config%cascade_set)) then - call cascade_set_final (phs_config%cascade_set) - deallocate (phs_config%cascade_set) - end if - if (allocated (phs_config%feyngraph_set)) then - call phs_config%feyngraph_set%final () - deallocate (phs_config%feyngraph_set) +@ %def dag_string_assign_from_char_string +<>= + elemental module subroutine dag_string_assign_from_dag_string & + (string_out, string_in) + type(dag_string_t), intent(out) :: string_out + type(dag_string_t), intent(in) :: string_in + end subroutine dag_string_assign_from_dag_string +<>= + elemental module subroutine dag_string_assign_from_dag_string & + (string_out, string_in) + type(dag_string_t), intent(out) :: string_out + type(dag_string_t), intent(in) :: string_in + if (allocated (string_in%t)) then + allocate (string_out%t (size(string_in%t))) + string_out%t = string_in%t end if - end subroutine phs_wood_config_clear_phase_space - -@ %def phs_wood_config_clear_phase_space -@ -Extract the set of resonance histories -<>= - procedure :: extract_resonance_history_set & - => phs_wood_config_extract_resonance_history_set -<>= - subroutine phs_wood_config_extract_resonance_history_set & - (phs_config, res_set, include_trivial) - class(phs_wood_config_t), intent(in) :: phs_config - type(resonance_history_set_t), intent(out) :: res_set - logical, intent(in), optional :: include_trivial - call phs_config%forest%extract_resonance_history_set & - (res_set, include_trivial) - end subroutine phs_wood_config_extract_resonance_history_set + string_out%char_len = string_in%char_len + end subroutine dag_string_assign_from_dag_string -@ %def phs_wood_config_extract_resonance_history_set -@ -\subsection{Phase-space configuration} -We read the phase-space configuration from the stored I/O unit. If -this is not set, we assume that we have to generate a phase space -configuration. When done, we open a scratch file and write the -configuration. +@ %def dag_string_assign_from_dag_string +@ Concatenate strings/tokens. The result is always a [[dag_string]]. +<>= + public :: operator (//) +<>= + interface operator (//) + module procedure concat_dag_token_dag_token + module procedure concat_dag_string_dag_token + module procedure concat_dag_token_dag_string + module procedure concat_dag_string_dag_string + end interface operator (//) -If [[rebuild]] is set, we should trash any existing phase space file -and build a new one. Otherwise, we try to use an old one, which we -check for existence and integrity. If [[ignore_mismatch]] is set, we -reuse an existing file even if it does not match the current setup. -<>= - procedure :: configure => phs_wood_config_configure -<>= - subroutine phs_wood_config_configure (phs_config, sqrts, & - sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, ignore_mismatch, & - nlo_type, subdir) - class(phs_wood_config_t), intent(inout) :: phs_config - real(default), intent(in) :: sqrts - logical, intent(in), optional :: sqrts_fixed - logical, intent(in), optional :: lab_is_cm - logical, intent(in), optional :: azimuthal_dependence - logical, intent(in), optional :: rebuild - logical, intent(in), optional :: ignore_mismatch - integer, intent(in), optional :: nlo_type - type(string_t), intent(in), optional :: subdir - type(string_t) :: filename, filename_vis - logical :: variable_limits - logical :: ok, exist, found, check, match, rebuild_phs - integer :: g, c0, c1, n - if (present (nlo_type)) then - phs_config%nlo_type = nlo_type +@ %def interfaces +<>= + module function concat_dag_token_dag_token & + (token1, token2) result (res_string) + type(dag_token_t), intent(in) :: token1, token2 + type(dag_string_t) :: res_string + end function concat_dag_token_dag_token +<>= + module function concat_dag_token_dag_token & + (token1, token2) result (res_string) + type(dag_token_t), intent(in) :: token1, token2 + type(dag_string_t) :: res_string + if (token1%type == EMPTY_TK) then + call dag_string_assign_from_dag_token (res_string, token2) + else if (token2%type == EMPTY_TK) then + call dag_string_assign_from_dag_token (res_string, token1) else - phs_config%nlo_type = BORN + allocate (res_string%t(2)) + res_string%t(1) = token1 + res_string%t(2) = token2 + res_string%char_len = token1%char_len + token2%char_len end if - phs_config%sqrts = sqrts - phs_config%par%sqrts = sqrts - if (present (sqrts_fixed)) & - phs_config%sqrts_fixed = sqrts_fixed - if (present (lab_is_cm)) & - phs_config%lab_is_cm = lab_is_cm - if (present (azimuthal_dependence)) & - phs_config%azimuthal_dependence = azimuthal_dependence - if (present (rebuild)) then - rebuild_phs = rebuild + end function concat_dag_token_dag_token + +@ %def concat_dag_token_dag_token +<>= + module function concat_dag_string_dag_token & + (dag_string, dag_token) result (res_string) + type(dag_string_t), intent(in) :: dag_string + type(dag_token_t), intent(in) :: dag_token + type(dag_string_t) :: res_string + end function concat_dag_string_dag_token +<>= + module function concat_dag_string_dag_token & + (dag_string, dag_token) result (res_string) + type(dag_string_t), intent(in) :: dag_string + type(dag_token_t), intent(in) :: dag_token + type(dag_string_t) :: res_string + integer :: t_size + if (dag_string%char_len == 0) then + call dag_string_assign_from_dag_token (res_string, dag_token) + else if (dag_token%type == EMPTY_TK) then + res_string = dag_string else - rebuild_phs = .true. + t_size = size (dag_string%t) + allocate (res_string%t(t_size+1)) + res_string%t(:t_size) = dag_string%t + res_string%t(t_size+1) = dag_token + res_string%char_len = dag_string%char_len + dag_token%char_len end if - if (present (ignore_mismatch)) then - check = .not. ignore_mismatch - if (ignore_mismatch) & - call msg_warning ("Reading phs file: MD5 sum check disabled") + end function concat_dag_string_dag_token + +@ %def concat_dag_string_dag_token +<>= + module function concat_dag_token_dag_string & + (dag_token, dag_string) result (res_string) + type(dag_token_t), intent(in) :: dag_token + type(dag_string_t), intent(in) :: dag_string + type(dag_string_t) :: res_string + integer :: t_size + end function concat_dag_token_dag_string +<>= + module function concat_dag_token_dag_string & + (dag_token, dag_string) result (res_string) + type(dag_token_t), intent(in) :: dag_token + type(dag_string_t), intent(in) :: dag_string + type(dag_string_t) :: res_string + integer :: t_size + if (dag_token%type == EMPTY_TK) then + res_string = dag_string + else if (dag_string%char_len == 0) then + call dag_string_assign_from_dag_token (res_string, dag_token) else - check = .true. - end if - phs_config%md5sum_forest = "" - call phs_config%compute_md5sum (include_id = .false.) - if (phs_config%io_unit == 0) then - filename = phs_config%make_phs_filename (subdir) - filename_vis = phs_config%make_phs_filename (subdir) // "-vis" - if (.not. rebuild_phs) then - if (check) then - call phs_config%read_phs_file (exist, found, match, subdir=subdir) - rebuild_phs = .not. (exist .and. found .and. match) - else - call phs_config%read_phs_file (exist, found, subdir=subdir) - rebuild_phs = .not. (exist .and. found) - end if - end if - if (.not. mpi_is_comm_master ()) then - rebuild_phs = .false. - call msg_message ("MPI: Workers do not build phase space configuration.") - end if - if (rebuild_phs) then - call phs_config%generate_phase_space () - phs_config%io_unit = free_unit () - if (phs_config%id /= "") then - call msg_message ("Phase space: writing configuration file '" & - // char (filename) // "'") - open (phs_config%io_unit, file = char (filename), & - status = "replace", action = "readwrite") - else - open (phs_config%io_unit, status = "scratch", action = "readwrite") - end if - call phs_config%write_phase_space (filename_vis) - rewind (phs_config%io_unit) - else - call msg_message ("Phase space: keeping configuration file '" & - // char (filename) // "'") - end if + t_size = size (dag_string%t) + allocate (res_string%t(t_size+1)) + res_string%t(2:t_size+1) = dag_string%t + res_string%t(1) = dag_token + res_string%char_len = dag_token%char_len + dag_string%char_len end if - if (phs_config%io_unit == 0) then - ok = .true. + end function concat_dag_token_dag_string + +@ %def concat_dag_token_dag_string +<>= + module function concat_dag_string_dag_string & + (string1, string2) result (res_string) + type(dag_string_t), intent(in) :: string1, string2 + type(dag_string_t) :: res_string + end function concat_dag_string_dag_string +<>= + module function concat_dag_string_dag_string & + (string1, string2) result (res_string) + type(dag_string_t), intent(in) :: string1, string2 + type(dag_string_t) :: res_string + integer :: t1_size, t2_size, t_size + if (string1%char_len == 0) then + res_string = string2 + else if (string2%char_len == 0) then + res_string = string1 else - call phs_forest_read (phs_config%forest, phs_config%io_unit, & - phs_config%id, phs_config%n_in, phs_config%n_out, & - phs_config%model, ok) - if (.not. phs_config%io_unit_keep_open) then - close (phs_config%io_unit) - phs_config%io_unit = 0 - end if - end if - if (ok) then - call phs_forest_set_flavors (phs_config%forest, phs_config%flv(:,1)) - variable_limits = .not. phs_config%lab_is_cm - call phs_forest_set_parameters & - (phs_config%forest, phs_config%mapping_defaults, variable_limits) - call phs_forest_setup_prt_combinations (phs_config%forest) - phs_config%n_channel = phs_forest_get_n_channels (phs_config%forest) - phs_config%n_par = phs_forest_get_n_parameters (phs_config%forest) - allocate (phs_config%channel (phs_config%n_channel)) - if (phs_config%use_equivalences) then - call phs_forest_set_equivalences (phs_config%forest) - call phs_forest_get_equivalences (phs_config%forest, & - phs_config%channel, phs_config%azimuthal_dependence) - phs_config%provides_equivalences = .true. - end if - call phs_forest_set_s_mappings (phs_config%forest) - call phs_config%record_on_shell () - if (phs_config%mapping_defaults%enable_s_mapping) then - call phs_config%record_s_mappings () + t1_size = size (string1%t) + t2_size = size (string2%t) + t_size = t1_size + t2_size + if (t_size > 0) then + allocate (res_string%t(t_size)) + res_string%t(:t1_size) = string1%t + res_string%t(t1_size+1:) = string2%t + res_string%char_len = string1%char_len + string2%char_len end if - allocate (phs_config%chain (phs_config%n_channel), source = 0) - do g = 1, phs_forest_get_n_groves (phs_config%forest) - call phs_forest_get_grove_bounds (phs_config%forest, g, c0, c1, n) - phs_config%chain (c0:c1) = g - end do - phs_config%provides_chains = .true. - call phs_config%compute_md5sum_forest () - else - write (msg_buffer, "(A,A,A)") & - "Phase space: process '", & - char (phs_config%id), "' not found in configuration file" - call msg_fatal () end if - end subroutine phs_wood_config_configure + end function concat_dag_string_dag_string -@ %def phs_wood_config_configure -@ The MD5 sum of the forest is computed in addition to the MD5 sum of -the configuration. The reason is that the forest may depend on a -user-provided external file. On the other hand, this MD5 sum encodes -all information that is relevant for further processing. Therefore, -the [[get_md5sum]] method returns this result, once it is available. -<>= - procedure :: compute_md5sum_forest => phs_wood_config_compute_md5sum_forest -<>= - subroutine phs_wood_config_compute_md5sum_forest (phs_config) - class(phs_wood_config_t), intent(inout) :: phs_config - integer :: u - u = free_unit () - open (u, status = "scratch", action = "readwrite") - call phs_config%write_forest (u) - rewind (u) - phs_config%md5sum_forest = md5sum (u) - close (u) - end subroutine phs_wood_config_compute_md5sum_forest +@ %def concat_dag_string_dag_string +@ Compare strings/tokens/characters. Each character is relevant, including +all blanc spaces. An exception is the [[newline]] character which is not +treated by the types used in this module (not to confused with the type +parameter [[NEW_LINE_TK]] which corresponds to the backslash character +and simply tells us that the string continues on the next line in the file). +<>= + public :: operator (==) +<>= + interface operator (==) + module procedure dag_token_eq_dag_token + module procedure dag_string_eq_dag_string + module procedure dag_token_eq_dag_string + module procedure dag_string_eq_dag_token + module procedure dag_token_eq_char_string + module procedure char_string_eq_dag_token + module procedure dag_string_eq_char_string + module procedure char_string_eq_dag_string + end interface operator (==) -@ %def phs_wood_config_compute_md5sum_forest -@ Create filenames according to standard conventions. The [[id]] is the -process name including the suffix [[_iX]] where [[X]] stands for the component -identifier (an integer). The [[run_id]] may be set or unset. +@ %def interfaces +<>= + elemental module function dag_token_eq_dag_token & + (token1, token2) result (flag) + type(dag_token_t), intent(in) :: token1, token2 + logical :: flag + end function dag_token_eq_dag_token +<>= + elemental module function dag_token_eq_dag_token & + (token1, token2) result (flag) + type(dag_token_t), intent(in) :: token1, token2 + logical :: flag + flag = (token1%type == token2%type) .and. & + (token1%char_len == token2%char_len) .and. & + (token1%bincode == token2%bincode) .and. & + (token1%index == token2%index) .and. & + (token1%particle_name == token2%particle_name) + end function dag_token_eq_dag_token -The convention for file names that include the run ID is to separate prefix, run -ID, and any extensions by dots. We construct the file name by concatenating -the individual elements accordingly. If there is no run ID, we nevertheless -replace [[_iX]] by [[.iX]]. -<>= - procedure :: make_phs_filename => phs_wood_make_phs_filename -<>= - function phs_wood_make_phs_filename (phs_config, subdir) result (filename) - class(phs_wood_config_t), intent(in) :: phs_config - type(string_t), intent(in), optional :: subdir - type(string_t) :: filename - type(string_t) :: basename, suffix, comp_code, comp_index - basename = phs_config%id - call split (basename, suffix, "_", back=.true.) - comp_code = extract (suffix, 1, 1) - comp_index = extract (suffix, 2) - if (comp_code == "i" .and. verify (comp_index, "1234567890") == 0) then - suffix = "." // comp_code // comp_index - else - basename = phs_config%id - suffix = "" - end if - if (phs_config%run_id /= "") then - filename = basename // "." // phs_config%run_id // suffix // ".phs" - else - filename = basename // suffix // ".phs" - end if - if (present (subdir)) then - filename = subdir // "/" // filename +@ %def dag_token_eq_dag_token +<>= + elemental module function dag_string_eq_dag_string & + (string1, string2) result (flag) + type(dag_string_t), intent(in) :: string1, string2 + logical :: flag + end function dag_string_eq_dag_string +<>= + elemental module function dag_string_eq_dag_string & + (string1, string2) result (flag) + type(dag_string_t), intent(in) :: string1, string2 + logical :: flag + flag = (string1%char_len == string2%char_len) .and. & + (allocated (string1%t) .eqv. allocated (string2%t)) + if (flag) then + if (allocated (string1%t)) flag = all (string1%t == string2%t) end if - end function phs_wood_make_phs_filename + end function dag_string_eq_dag_string -@ %def phs_wood_make_phs_filename -@ -<>= - procedure :: reshuffle_flavors => phs_wood_config_reshuffle_flavors -<>= - subroutine phs_wood_config_reshuffle_flavors (phs_config, reshuffle, flv_extra) - class(phs_wood_config_t), intent(inout) :: phs_config - integer, intent(in), dimension(:), allocatable :: reshuffle - type(flavor_t), intent(in) :: flv_extra - call phs_forest_set_flavors (phs_config%forest, phs_config%flv(:,1), reshuffle, flv_extra) - end subroutine phs_wood_config_reshuffle_flavors +@ %def dag_string_eq_dag_string +<>= + elemental module function dag_token_eq_dag_string & + (dag_token, dag_string) result (flag) + type(dag_token_t), intent(in) :: dag_token + type(dag_string_t), intent(in) :: dag_string + logical :: flag + end function dag_token_eq_dag_string +<>= + elemental module function dag_token_eq_dag_string & + (dag_token, dag_string) result (flag) + type(dag_token_t), intent(in) :: dag_token + type(dag_string_t), intent(in) :: dag_string + logical :: flag + flag = size (dag_string%t) == 1 .and. & + dag_string%char_len == dag_token%char_len + if (flag) flag = (dag_string%t(1) == dag_token) + end function dag_token_eq_dag_string -@ %def phs_wood_config_reshuffle_flavors -@ -<>= - procedure :: set_momentum_links => phs_wood_config_set_momentum_links -<>= - subroutine phs_wood_config_set_momentum_links (phs_config, reshuffle) - class(phs_wood_config_t), intent(inout) :: phs_config - integer, intent(in), dimension(:), allocatable :: reshuffle - call phs_forest_set_momentum_links (phs_config%forest, reshuffle) - end subroutine phs_wood_config_set_momentum_links +@ %def dag_token_eq_dag_string +<>= + elemental module function dag_string_eq_dag_token & + (dag_string, dag_token) result (flag) + type(dag_token_t), intent(in) :: dag_token + type(dag_string_t), intent(in) :: dag_string + logical :: flag + end function dag_string_eq_dag_token +<>= + elemental module function dag_string_eq_dag_token & + (dag_string, dag_token) result (flag) + type(dag_token_t), intent(in) :: dag_token + type(dag_string_t), intent(in) :: dag_string + logical :: flag + flag = (dag_token == dag_string) + end function dag_string_eq_dag_token -@ %def phs_wood_config_set_momentum_links -@ Identify resonances which are marked by s-channel mappings for the -whole phase space and report them to the channel array. -<>= - procedure :: record_s_mappings => phs_wood_config_record_s_mappings -<>= - subroutine phs_wood_config_record_s_mappings (phs_config) - class(phs_wood_config_t), intent(inout) :: phs_config +@ %def dag_string_eq_dag_token +<>= + elemental module function dag_token_eq_char_string & + (dag_token, char_string) result (flag) + type(dag_token_t), intent(in) :: dag_token + character(len=*), intent(in) :: char_string + logical :: flag + end function dag_token_eq_char_string +<>= + elemental module function dag_token_eq_char_string & + (dag_token, char_string) result (flag) + type(dag_token_t), intent(in) :: dag_token + character(len=*), intent(in) :: char_string logical :: flag - real(default) :: mass, width - integer :: c - do c = 1, phs_config%n_channel - call phs_forest_get_s_mapping (phs_config%forest, c, flag, mass, width) - if (flag) then - if (mass == 0) then - call msg_fatal ("Phase space: s-channel resonance " & - // " has zero mass") - end if - if (width == 0) then - call msg_fatal ("Phase space: s-channel resonance " & - // " has zero width") - end if - call phs_config%channel(c)%set_resonant (mass, width) - end if - end do - end subroutine phs_wood_config_record_s_mappings + flag = (char (dag_token) == char_string) + end function dag_token_eq_char_string -@ %def phs_wood_config_record_s_mappings -@ Identify on-shell mappings for the whole phase space and report them -to the channel array. -<>= - procedure :: record_on_shell => phs_wood_config_record_on_shell -<>= - subroutine phs_wood_config_record_on_shell (phs_config) - class(phs_wood_config_t), intent(inout) :: phs_config +@ %def dag_token_eq_char_string +<>= + elemental module function char_string_eq_dag_token & + (char_string, dag_token) result (flag) + type(dag_token_t), intent(in) :: dag_token + character(len=*), intent(in) :: char_string + logical :: flag + end function char_string_eq_dag_token +<>= + elemental module function char_string_eq_dag_token & + (char_string, dag_token) result (flag) + type(dag_token_t), intent(in) :: dag_token + character(len=*), intent(in) :: char_string logical :: flag - real(default) :: mass - integer :: c - do c = 1, phs_config%n_channel - call phs_forest_get_on_shell (phs_config%forest, c, flag, mass) - if (flag) then - call phs_config%channel(c)%set_on_shell (mass) - end if - end do - end subroutine phs_wood_config_record_on_shell + flag = (char (dag_token) == char_string) + end function char_string_eq_dag_token -@ %def phs_wood_config_record_on_shell -@ Return the most relevant MD5 sum. This overrides the method of the -base type. -<>= - procedure :: get_md5sum => phs_wood_config_get_md5sum -<>= - function phs_wood_config_get_md5sum (phs_config) result (md5sum) - class(phs_wood_config_t), intent(in) :: phs_config - character(32) :: md5sum - if (phs_config%md5sum_forest /= "") then - md5sum = phs_config%md5sum_forest - else - md5sum = phs_config%md5sum_phs_config - end if - end function phs_wood_config_get_md5sum +@ %def char_string_eq_dag_token +<>= + elemental module function dag_string_eq_char_string & + (dag_string, char_string) result (flag) + type(dag_string_t), intent(in) :: dag_string + character(len=*), intent(in) :: char_string + logical :: flag + end function dag_string_eq_char_string +<>= + elemental module function dag_string_eq_char_string & + (dag_string, char_string) result (flag) + type(dag_string_t), intent(in) :: dag_string + character(len=*), intent(in) :: char_string + logical :: flag + flag = (char (dag_string) == char_string) + end function dag_string_eq_char_string -@ %def phs_wood_config_get_md5sum -@ Check whether a phase-space configuration for the current process exists. -We look for the phase-space file that should correspond to the current -process. If we find it, we check the MD5 sums stored in the file against the -MD5 sums in the current configuration (if required). +@ %def dag_string_eq_char_string +<>= + elemental module function char_string_eq_dag_string & + (char_string, dag_string) result (flag) + type(dag_string_t), intent(in) :: dag_string + character(len=*), intent(in) :: char_string + logical :: flag + end function char_string_eq_dag_string +<>= + elemental module function char_string_eq_dag_string & + (char_string, dag_string) result (flag) + type(dag_string_t), intent(in) :: dag_string + character(len=*), intent(in) :: char_string + logical :: flag + flag = (char (dag_string) == char_string) + end function char_string_eq_dag_string -If successful, read the PHS file. -<>= - procedure :: read_phs_file => phs_wood_read_phs_file -<>= - subroutine phs_wood_read_phs_file (phs_config, exist, found, match, subdir) - class(phs_wood_config_t), intent(inout) :: phs_config - logical, intent(out) :: exist - logical, intent(out) :: found - logical, intent(out), optional :: match - type(string_t), intent(in), optional :: subdir - type(string_t) :: filename - integer :: u - filename = phs_config%make_phs_filename (subdir) - inquire (file = char (filename), exist = exist) - if (exist) then - u = free_unit () - open (u, file = char (filename), action = "read", status = "old") - call phs_forest_read (phs_config%forest, u, & - phs_config%id, phs_config%n_in, phs_config%n_out, & - phs_config%model, found, & - phs_config%md5sum_process, & - phs_config%md5sum_model_par, & - phs_config%md5sum_phs_config, & - match = match) - close (u) - else - found = .false. - if (present (match)) match = .false. - end if - end subroutine phs_wood_read_phs_file +@ %def char_string_eq_dag_string +<>= + public :: operator (/=) +<>= + interface operator (/=) + module procedure dag_token_ne_dag_token + module procedure dag_string_ne_dag_string + module procedure dag_token_ne_dag_string + module procedure dag_string_ne_dag_token + module procedure dag_token_ne_char_string + module procedure char_string_ne_dag_token + module procedure dag_string_ne_char_string + module procedure char_string_ne_dag_string + end interface operator (/=) -@ %def phs_wood_read_phs_file -@ Startup message, after configuration is complete. -<>= - procedure :: startup_message => phs_wood_config_startup_message -<>= - subroutine phs_wood_config_startup_message (phs_config, unit) - class(phs_wood_config_t), intent(in) :: phs_config - integer, intent(in), optional :: unit - integer :: n_groves, n_eq - n_groves = phs_forest_get_n_groves (phs_config%forest) - n_eq = phs_forest_get_n_equivalences (phs_config%forest) - call phs_config%base_startup_message (unit) - if (phs_config%n_channel == 1) then - write (msg_buffer, "(A,2(I0,A))") & - "Phase space: found ", phs_config%n_channel, & - " channel, collected in ", n_groves, & - " grove." - else if (n_groves == 1) then - write (msg_buffer, "(A,2(I0,A))") & - "Phase space: found ", phs_config%n_channel, & - " channels, collected in ", n_groves, & - " grove." - else - write (msg_buffer, "(A,2(I0,A))") & - "Phase space: found ", phs_config%n_channel, & - " channels, collected in ", & - phs_forest_get_n_groves (phs_config%forest), & - " groves." - end if - call msg_message (unit = unit) - if (phs_config%use_equivalences) then - if (n_eq == 1) then - write (msg_buffer, "(A,I0,A)") & - "Phase space: Using ", n_eq, & - " equivalence between channels." - else - write (msg_buffer, "(A,I0,A)") & - "Phase space: Using ", n_eq, & - " equivalences between channels." - end if - else - write (msg_buffer, "(A)") & - "Phase space: no equivalences between channels used." - end if - call msg_message (unit = unit) - write (msg_buffer, "(A,2(1x,I0,1x,A))") & - "Phase space: wood" - call msg_message (unit = unit) - end subroutine phs_wood_config_startup_message +@ %def interfaces +<>= + elemental module function dag_token_ne_dag_token & + (token1, token2) result (flag) + type(dag_token_t), intent(in) :: token1, token2 + logical :: flag + end function dag_token_ne_dag_token +<>= + elemental module function dag_token_ne_dag_token & + (token1, token2) result (flag) + type(dag_token_t), intent(in) :: token1, token2 + logical :: flag + flag = .not. (token1 == token2) + end function dag_token_ne_dag_token -@ %def phs_wood_config_startup_message -@ Allocate an instance: the actual phase-space object. -<>= - procedure, nopass :: allocate_instance => phs_wood_config_allocate_instance -<>= - subroutine phs_wood_config_allocate_instance (phs) - class(phs_t), intent(inout), pointer :: phs - allocate (phs_wood_t :: phs) - end subroutine phs_wood_config_allocate_instance +@ %def dag_token_ne_dag_token +<>= + elemental module function dag_string_ne_dag_string & + (string1, string2) result (flag) + type(dag_string_t), intent(in) :: string1, string2 + logical :: flag + end function dag_string_ne_dag_string +<>= + elemental module function dag_string_ne_dag_string & + (string1, string2) result (flag) + type(dag_string_t), intent(in) :: string1, string2 + logical :: flag + flag = .not. (string1 == string2) + end function dag_string_ne_dag_string -@ %def phs_wood_config_allocate_instance -@ -\subsection{Kinematics implementation} -We generate $\cos\theta$ and $\phi$ uniformly, covering the solid angle. -<>= - public :: phs_wood_t -<>= - type, extends (phs_t) :: phs_wood_t - real(default) :: sqrts = 0 - type(phs_forest_t) :: forest - real(default), dimension(3) :: r_real - integer :: n_r_born = 0 - contains - <> - end type phs_wood_t +@ %def dag_string_ne_dag_string +<>= + elemental module function dag_token_ne_dag_string & + (dag_token, dag_string) result (flag) + type(dag_token_t), intent(in) :: dag_token + type(dag_string_t), intent(in) :: dag_string + logical :: flag + end function dag_token_ne_dag_string +<>= + elemental module function dag_token_ne_dag_string & + (dag_token, dag_string) result (flag) + type(dag_token_t), intent(in) :: dag_token + type(dag_string_t), intent(in) :: dag_string + logical :: flag + flag = .not. (dag_token == dag_string) + end function dag_token_ne_dag_string -@ %def phs_wood_t -@ Output. The [[verbose]] setting is irrelevant, we just display the contents -of the base object. -<>= - procedure :: write => phs_wood_write -<>= - subroutine phs_wood_write (object, unit, verbose) - class(phs_wood_t), intent(in) :: object - integer, intent(in), optional :: unit - logical, intent(in), optional :: verbose - integer :: u - u = given_output_unit (unit) - call object%base_write (u) - end subroutine phs_wood_write +@ %def dag_token_ne_dag_string +<>= + elemental module function dag_string_ne_dag_token & + (dag_string, dag_token) result (flag) + type(dag_token_t), intent(in) :: dag_token + type(dag_string_t), intent(in) :: dag_string + logical :: flag + end function dag_string_ne_dag_token +<>= + elemental module function dag_string_ne_dag_token & + (dag_string, dag_token) result (flag) + type(dag_token_t), intent(in) :: dag_token + type(dag_string_t), intent(in) :: dag_string + logical :: flag + flag = .not. (dag_string == dag_token) + end function dag_string_ne_dag_token -@ %def phs_wood_write -@ Write the forest separately. -<>= - procedure :: write_forest => phs_wood_write_forest -<>= - subroutine phs_wood_write_forest (object, unit) - class(phs_wood_t), intent(in) :: object - integer, intent(in), optional :: unit - integer :: u - u = given_output_unit (unit) - call phs_forest_write (object%forest, u) - end subroutine phs_wood_write_forest +@ %def dag_string_ne_dag_token +<>= + elemental module function dag_token_ne_char_string & + (dag_token, char_string) result (flag) + type(dag_token_t), intent(in) :: dag_token + character(len=*), intent(in) :: char_string + logical :: flag + end function dag_token_ne_char_string +<>= + elemental module function dag_token_ne_char_string & + (dag_token, char_string) result (flag) + type(dag_token_t), intent(in) :: dag_token + character(len=*), intent(in) :: char_string + logical :: flag + flag = .not. (dag_token == char_string) + end function dag_token_ne_char_string -@ %def phs_wood_write_forest -@ Finalizer. -<>= - procedure :: final => phs_wood_final -<>= - subroutine phs_wood_final (object) - class(phs_wood_t), intent(inout) :: object - call phs_forest_final (object%forest) - end subroutine phs_wood_final +@ %def dag_token_ne_char_string +<>= + elemental module function char_string_ne_dag_token & + (char_string, dag_token) result (flag) + type(dag_token_t), intent(in) :: dag_token + character(len=*), intent(in) :: char_string + logical :: flag + end function char_string_ne_dag_token +<>= + elemental module function char_string_ne_dag_token & + (char_string, dag_token) result (flag) + type(dag_token_t), intent(in) :: dag_token + character(len=*), intent(in) :: char_string + logical :: flag + flag = .not. (char_string == dag_token) + end function char_string_ne_dag_token -@ %def phs_wood_final -@ Initialization. We allocate arrays ([[base_init]]) and adjust the -phase-space volume. The two-particle phase space volume is -\begin{equation} - \Phi_2 = \frac{1}{4(2\pi)^5} = 2.55294034614 \times 10^{-5} -\end{equation} -independent of the particle masses. -<>= - procedure :: init => phs_wood_init -<>= - subroutine phs_wood_init (phs, phs_config) - class(phs_wood_t), intent(out) :: phs - class(phs_config_t), intent(in), target :: phs_config - call phs%base_init (phs_config) - select type (phs_config) - type is (phs_wood_config_t) - phs%forest = phs_config%forest - if (phs_config%is_combined_integration) then - phs%n_r_born = phs_config%n_par - 3 - end if - end select - end subroutine phs_wood_init +@ %def char_string_ne_dag_token +<>= + elemental module function dag_string_ne_char_string & + (dag_string, char_string) result (flag) + type(dag_string_t), intent(in) :: dag_string + character(len=*), intent(in) :: char_string + logical :: flag + end function dag_string_ne_char_string +<>= + elemental module function dag_string_ne_char_string & + (dag_string, char_string) result (flag) + type(dag_string_t), intent(in) :: dag_string + character(len=*), intent(in) :: char_string + logical :: flag + flag = .not. (dag_string == char_string) + end function dag_string_ne_char_string -@ %def phs_wood_init -@ -\subsection{Evaluation} -We compute the outgoing momenta from the incoming momenta and -the input parameter set [[r_in]] in channel [[r_in]]. We also compute the -[[r]] parameters and Jacobians [[f]] for all other channels. +@ %def dag_string_ne_char_string +<>= + elemental module function char_string_ne_dag_string & + (char_string, dag_string) result (flag) + type(dag_string_t), intent(in) :: dag_string + character(len=*), intent(in) :: char_string + logical :: flag + end function char_string_ne_dag_string +<>= + elemental module function char_string_ne_dag_string & + (char_string, dag_string) result (flag) + type(dag_string_t), intent(in) :: dag_string + character(len=*), intent(in) :: char_string + logical :: flag + flag = .not. (char_string == dag_string) + end function char_string_ne_dag_string -We do \emph{not} need to a apply a transformation from/to the c.m.\ frame, -because in [[phs_base]] the momenta are already boosted to the c.m.\ frame -before assigning them in the [[phs]] object, and inversely boosted when -extracting them. -<>= - procedure :: evaluate_selected_channel => phs_wood_evaluate_selected_channel - procedure :: evaluate_other_channels => phs_wood_evaluate_other_channels -<>= - subroutine phs_wood_evaluate_selected_channel (phs, c_in, r_in) - class(phs_wood_t), intent(inout) :: phs - integer, intent(in) :: c_in - real(default), intent(in), dimension(:) :: r_in - logical :: ok - phs%q_defined = .false. - if (phs%p_defined) then - call phs_forest_set_prt_in (phs%forest, phs%p) - phs%r(:,c_in) = r_in - call phs_forest_evaluate_selected_channel (phs%forest, & - c_in, phs%active_channel, & - phs%sqrts_hat, phs%r, phs%f, phs%volume, ok) - select type (config => phs%config) - type is (phs_wood_config_t) - if (config%is_combined_integration) then - if (phs%n_r_born >= 0) then - phs%r_real = r_in (phs%n_r_born + 1 : phs%n_r_born + 3) - else - call msg_fatal ("n_r_born should be larger than 0!") - end if - end if - end select - if (ok) then - phs%q = phs_forest_get_momenta_out (phs%forest) - phs%q_defined = .true. - end if - end if - end subroutine phs_wood_evaluate_selected_channel +@ %def char_string_ne_dag_string +@ Convert a [[dag_token]] or [[dag_string]] to character. +<>= + public :: char +<>= + interface char + module procedure char_dag_token + module procedure char_dag_string + end interface char - subroutine phs_wood_evaluate_other_channels (phs, c_in) - class(phs_wood_t), intent(inout) :: phs - integer, intent(in) :: c_in - integer :: c - if (phs%q_defined) then - call phs_forest_evaluate_other_channels (phs%forest, & - c_in, phs%active_channel, & - phs%sqrts_hat, phs%r, phs%f, combine=.true.) - select type (config => phs%config) - type is (phs_wood_config_t) - if (config%is_combined_integration) then - if (phs%n_r_born >= 0) then - do c = 1, size (phs%r, 2) - phs%r(phs%n_r_born + 1 : phs%n_r_born + 3, c) = phs%r_real - end do +@ %def interfaces +<>= + pure module function char_dag_token (dag_token) result (char_string) + type(dag_token_t), intent(in) :: dag_token + character (dag_token%char_len) :: char_string + end function char_dag_token +<>= + pure module function char_dag_token (dag_token) result (char_string) + type(dag_token_t), intent(in) :: dag_token + character (dag_token%char_len) :: char_string + integer :: i + integer :: name_len + integer :: bc_pos + integer :: n_digits + character(len=9) :: fmt_spec + select case (dag_token%type) + case (EMPTY_TK) + char_string = "" + case (NEW_LINE_TK) + char_string = BACKSLASH_CHAR + case (BLANC_SPACE_TK) + char_string = " " + case (COLON_TK) + char_string = ":" + case (COMMA_TK) + char_string = "," + case (VERTICAL_BAR_TK) + char_string = "|" + case (OPEN_PAR_TK) + char_string = "(" + case (CLOSED_PAR_TK) + char_string = ")" + case (OPEN_CURLY_TK) + char_string = "{" + case (CLOSED_CURLY_TK) + char_string = "}" + case (DAG_NODE_TK, DAG_OPTIONS_TK, DAG_COMBINATION_TK) + n_digits = dag_token%char_len - 3 + fmt_spec = "" + if (n_digits > 9) then + write (fmt_spec, fmt="(A,I2,A)") "(A,I", n_digits, ",A)" + else + write (fmt_spec, fmt="(A,I1,A)") "(A,I", n_digits, ",A)" + end if + select case (dag_token%type) + case (DAG_NODE_TK) + write (char_string, fmt=fmt_spec) "" + case (DAG_OPTIONS_TK) + write (char_string, fmt=fmt_spec) "" + case (DAG_COMBINATION_TK) + write (char_string, fmt=fmt_spec) "" + end select + case (NODE_TK) + name_len = len_trim (dag_token%particle_name) + char_string = dag_token%particle_name + bc_pos = name_len + 1 + char_string(bc_pos:bc_pos) = "[" + do i=0, bit_size (dag_token%bincode) - 1 + if (btest (dag_token%bincode, i)) then + bc_pos = bc_pos + 1 + select case (i) + case (0, 1, 2, 3, 4, 5, 6, 7, 8) + write (char_string(bc_pos:bc_pos), fmt="(I1)") i + 1 + case (9) + write (char_string(bc_pos:bc_pos), fmt="(A1)") "A" + case (10) + write (char_string(bc_pos:bc_pos), fmt="(A1)") "B" + case (11) + write (char_string(bc_pos:bc_pos), fmt="(A1)") "C" + end select + bc_pos = bc_pos + 1 + if (bc_pos == dag_token%char_len) then + write (char_string(bc_pos:bc_pos), fmt="(A1)") "]" + return else - phs%r_defined = .false. + write (char_string(bc_pos:bc_pos), fmt="(A1)") "/" end if end if + end do + end select + end function char_dag_token + +@ %def char_dag_token +<>= + pure module function char_dag_string (dag_string) result (char_string) + type(dag_string_t), intent(in) :: dag_string + character (dag_string%char_len) :: char_string + end function char_dag_string +<>= + pure module function char_dag_string (dag_string) result (char_string) + type(dag_string_t), intent(in) :: dag_string + character (dag_string%char_len) :: char_string + integer :: pos + integer :: i + char_string = "" + pos = 0 + do i=1, size(dag_string%t) + char_string(pos+1:pos+dag_string%t(i)%char_len) = char (dag_string%t(i)) + pos = pos + dag_string%t(i)%char_len + end do + end function char_dag_string + +@ %def char_dag_string +@ Remove all tokens which are irrelevant for parsing. These are of type +[[NEW_LINE_TK]], [[BLANC_SPACE_TK]] and [[EMTPY_TK]]. +<>= + procedure :: clean => dag_string_clean +<>= + module subroutine dag_string_clean (dag_string) + class(dag_string_t), intent(inout) :: dag_string + end subroutine dag_string_clean +<>= + module subroutine dag_string_clean (dag_string) + class(dag_string_t), intent(inout) :: dag_string + type(dag_token_t), dimension(:), allocatable :: tmp_token + integer :: n_keep + integer :: i + n_keep = 0 + dag_string%char_len = 0 + allocate (tmp_token (size(dag_string%t))) + do i=1, size (dag_string%t) + select case (dag_string%t(i)%type) + case(NEW_LINE_TK, BLANC_SPACE_TK, EMPTY_TK) + case default + n_keep = n_keep + 1 + tmp_token(n_keep) = dag_string%t(i) + dag_string%char_len = dag_string%char_len + dag_string%t(i)%char_len end select - phs%r_defined = .true. + end do + deallocate (dag_string%t) + allocate (dag_string%t(n_keep)) + dag_string%t = tmp_token(:n_keep) + end subroutine dag_string_clean + +@ %def dag_string_clean +@ If we operate explicitly on the [[token]] array [[t]] of a [[dag_string]], +the variable [[char_len]] is not automatically modified. It can however be +determined afterwards using the following subroutine. +<>= + procedure :: update_char_len => dag_string_update_char_len +<>= + module subroutine dag_string_update_char_len (dag_string) + class(dag_string_t), intent(inout) :: dag_string + end subroutine dag_string_update_char_len +<>= + module subroutine dag_string_update_char_len (dag_string) + class(dag_string_t), intent(inout) :: dag_string + integer :: char_len + integer :: i + char_len = 0 + if (allocated (dag_string%t)) then + do i=1, size (dag_string%t) + char_len = char_len + dag_string%t(i)%char_len + end do end if - end subroutine phs_wood_evaluate_other_channels + dag_string%char_len = char_len + end subroutine dag_string_update_char_len -@ %def phs_wood_evaluate_selected_channel -@ %def phs_wood_evaluate_other_channels -@ Inverse evaluation. -<>= - procedure :: inverse => phs_wood_inverse -<>= - subroutine phs_wood_inverse (phs) - class(phs_wood_t), intent(inout) :: phs - if (phs%p_defined .and. phs%q_defined) then - call phs_forest_set_prt_in (phs%forest, phs%p) - call phs_forest_set_prt_out (phs%forest, phs%q) - call phs_forest_recover_channel (phs%forest, & - 1, & - phs%sqrts_hat, phs%r, phs%f, phs%volume) - call phs_forest_evaluate_other_channels (phs%forest, & - 1, phs%active_channel, & - phs%sqrts_hat, phs%r, phs%f, combine=.false.) - phs%r_defined = .true. +@ %def dag_string_update_char_len +@ Append a [[dag_string]] to a [[dag_chain]]. The argument [[char_string]] +is of type [[character]] because the subroutine is used for reading from +the file produced by O'Mega which is first read line by line to a character +variable. +<>= + procedure :: append => dag_chain_append_string +<>= + module subroutine dag_chain_append_string (dag_chain, char_string) + class(dag_chain_t), intent(inout) :: dag_chain + character(len=*), intent(in) :: char_string + end subroutine dag_chain_append_string +<>= + module subroutine dag_chain_append_string (dag_chain, char_string) + class(dag_chain_t), intent(inout) :: dag_chain + character(len=*), intent(in) :: char_string + if (.not. associated (dag_chain%first)) then + allocate (dag_chain%first) + dag_chain%last => dag_chain%first + else + allocate (dag_chain%last%next) + dag_chain%last => dag_chain%last%next end if - end subroutine phs_wood_inverse + dag_chain%last = char_string + dag_chain%char_len = dag_chain%char_len + dag_chain%last%char_len + dag_chain%t_size = dag_chain%t_size + size (dag_chain%last%t) + end subroutine dag_chain_append_string -@ %def phs_wood_inverse -@ -\subsection{Unit tests} -Test module, followed by the corresponding implementation module. -<<[[phs_wood_ut.f90]]>>= +@ %def dag_chain_append_string +@ Reduce the linked list of [[dag_string]] objects which are attached +to a given [[dag_chain]] object to a single [[dag_string]]. +<>= + procedure :: compress => dag_chain_compress +<>= + module subroutine dag_chain_compress (dag_chain) + class(dag_chain_t), intent(inout) :: dag_chain + end subroutine dag_chain_compress +<>= + module subroutine dag_chain_compress (dag_chain) + class(dag_chain_t), intent(inout) :: dag_chain + type(dag_string_t), pointer :: current + type(dag_string_t), pointer :: remove + integer :: filled_t + current => dag_chain%first + dag_chain%first => null () + allocate (dag_chain%first) + dag_chain%last => dag_chain%first + dag_chain%first%char_len = dag_chain%char_len + allocate (dag_chain%first%t (dag_chain%t_size)) + filled_t = 0 + do while (associated (current)) + dag_chain%first%t(filled_t+1:filled_t+size(current%t)) = current%t + filled_t = filled_t + size (current%t) + remove => current + current => current%next + deallocate (remove) + end do + end subroutine dag_chain_compress + +@ %def dag_chain_compress +@ Finalizer for [[dag_string_t]]. +<>= + procedure :: final => dag_string_final +<>= + module subroutine dag_string_final (dag_string) + class(dag_string_t), intent(inout) :: dag_string + end subroutine dag_string_final +<>= + module subroutine dag_string_final (dag_string) + class(dag_string_t), intent(inout) :: dag_string + if (allocated (dag_string%t)) deallocate (dag_string%t) + dag_string%next => null () + end subroutine dag_string_final + +@ %def dag_string_final +@ Finalizer for [[dag_chain_t]]. +<>= + procedure :: final => dag_chain_final +<>= + module subroutine dag_chain_final (dag_chain) + class(dag_chain_t), intent(inout) :: dag_chain + end subroutine dag_chain_final +<>= + module subroutine dag_chain_final (dag_chain) + class(dag_chain_t), intent(inout) :: dag_chain + type(dag_string_t), pointer :: current + current => dag_chain%first + do while (associated (current)) + dag_chain%first => dag_chain%first%next + call current%final () + deallocate (current) + current => dag_chain%first + end do + dag_chain%last => null () + end subroutine dag_chain_final + +@ %def dag_chain_final +<<[[cascades2_lexer_ut.f90]]>>= <> -module phs_wood_ut +module cascades2_lexer_ut use unit_tests - use phs_wood_uti + use cascades2_lexer_uti <> -<> - -<> +<> contains -<> +<> -end module phs_wood_ut -@ %def phs_wood_ut +end module cascades2_lexer_ut +@ %def cascades2_lexer_ut @ -<<[[phs_wood_uti.f90]]>>= +<<[[cascades2_lexer_uti.f90]]>>= <> -module phs_wood_uti +module cascades2_lexer_uti <> <> - use io_units - use os_interface - use lorentz - use flavors - use model_data - use process_constants - use mappings - use phs_base - use phs_forests - - use phs_wood + use numeric_utils - use phs_base_ut, only: init_test_process_data, init_test_decay_data + use cascades2_lexer <> -<> - -<> +<> contains -<> - -<> +<> -end module phs_wood_uti -@ %def phs_wood_ut +end module cascades2_lexer_uti +@ %def cascades2_lexer_uti @ API: driver for the unit tests below. -<>= - public :: phs_wood_test -<>= - subroutine phs_wood_test (u, results) - integer, intent(in) :: u - type(test_results_t), intent(inout) :: results - <> - end subroutine phs_wood_test - -@ %def phs_wood_test -<>= - public :: phs_wood_vis_test -<>= - subroutine phs_wood_vis_test (u, results) +<>= + public :: cascades2_lexer_test +<>= + subroutine cascades2_lexer_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results - <> - end subroutine phs_wood_vis_test - -@ %def phs_wood_vis_test -@ -\subsubsection{Phase-space configuration data} -Construct and display a test phase-space configuration object. Also -check the [[azimuthal_dependence]] flag. - -This auxiliary routine writes a phase-space configuration file to unit -[[u_phs]]. -<>= - public :: write_test_phs_file -<>= - subroutine write_test_phs_file (u_phs, procname) - integer, intent(in) :: u_phs - type(string_t), intent(in), optional :: procname - if (present (procname)) then - write (u_phs, "(A,A)") "process ", char (procname) - else - write (u_phs, "(A)") "process testproc" - end if - write (u_phs, "(A,A)") " md5sum_process = ", '""' - write (u_phs, "(A,A)") " md5sum_model_par = ", '""' - write (u_phs, "(A,A)") " md5sum_phs_config = ", '""' - write (u_phs, "(A)") " sqrts = 1000" - write (u_phs, "(A)") " m_threshold_s = 50" - write (u_phs, "(A)") " m_threshold_t = 100" - write (u_phs, "(A)") " off_shell = 2" - write (u_phs, "(A)") " t_channel = 6" - write (u_phs, "(A)") " keep_nonresonant = T" - write (u_phs, "(A)") " grove #1" - write (u_phs, "(A)") " tree 3" - end subroutine write_test_phs_file + <> + end subroutine cascades2_lexer_test -@ %def write_test_phs_file +@ %def cascades2_lexer_test @ -<>= - call test (phs_wood_1, "phs_wood_1", & - "phase-space configuration", & - u, results) -<>= - public :: phs_wood_1 -<>= - subroutine phs_wood_1 (u) +<>= + call test (cascades2_lexer_1, "cascades2_lexer_1", & + "make phase-space", u, results) +<>= + public :: cascades2_lexer_1 +<>= + subroutine cascades2_lexer_1 (u) integer, intent(in) :: u - type(model_data_t), target :: model - type(process_constants_t) :: process_data - class(phs_config_t), allocatable :: phs_data - type(mapping_defaults_t) :: mapping_defaults - real(default) :: sqrts - integer :: u_phs, iostat - character(32) :: buffer - - write (u, "(A)") "* Test output: phs_wood_1" - write (u, "(A)") "* Purpose: initialize and display & - &phase-space configuration data" - write (u, "(A)") - - call model%init_test () - - call syntax_phs_forest_init () + integer :: u_in = 8 + character(len=300) :: line + integer :: stat + logical :: fail + type(dag_string_t) :: dag_string - write (u, "(A)") "* Initialize a process" + write (u, "(A)") "* Test output: cascades2_lexer_1" + write (u, "(A)") "* Purpose: read lines of O'Mega's phase space output, translate" + write (u, "(A)") "* to dag_string, retranslate to character string and" + write (u, "(A)") "* compare" write (u, "(A)") - call init_test_process_data (var_str ("phs_wood_1"), process_data) - - write (u, "(A)") "* Create a scratch phase-space file" - write (u, "(A)") + open (unit=u_in, file="cascades2_lexer_1.fds", status='old', action='read') - u_phs = free_unit () - open (u_phs, status = "scratch", action = "readwrite") - call write_test_phs_file (u_phs, var_str ("phs_wood_1")) - rewind (u_phs) - do - read (u_phs, "(A)", iostat = iostat) buffer - if (iostat /= 0) exit - write (u, "(A)") trim (buffer) + stat = 0 + fail = .false. + read (unit=u_in, fmt="(A)", iostat=stat) line + do while (stat == 0 .and. .not. fail) + read (unit=u_in, fmt="(A)", iostat=stat) line + if (stat /= 0) exit + dag_string = line + fail = (char(dag_string) /= line) end do + if (fail) then + write (u, "(A)") "* Test result: Test failed!" + else + write (u, "(A)") "* Test result: Test passed" + end if - write (u, "(A)") - write (u, "(A)") "* Setup phase-space configuration object" - write (u, "(A)") - - mapping_defaults%step_mapping = .false. - - allocate (phs_wood_config_t :: phs_data) - call phs_data%init (process_data, model) - select type (phs_data) - type is (phs_wood_config_t) - call phs_data%set_input (u_phs) - call phs_data%set_mapping_defaults (mapping_defaults) - end select - - sqrts = 1000._default - call phs_data%configure (sqrts) - - call phs_data%write (u) - write (u, "(A)") - - select type (phs_data) - type is (phs_wood_config_t) - call phs_data%write_forest (u) - end select - - write (u, "(A)") - write (u, "(A)") "* Cleanup" - - close (u_phs) - call phs_data%final () - call model%final () - - write (u, "(A)") - write (u, "(A)") "* Test output end: phs_wood_1" - - end subroutine phs_wood_1 - -@ %def phs_wood_1 -@ -\subsubsection{Phase space evaluation} -Compute kinematics for given parameters, also invert the calculation. -<>= - call test (phs_wood_2, "phs_wood_2", & - "phase-space evaluation", & - u, results) -<>= - public :: phs_wood_2 -<>= - subroutine phs_wood_2 (u) - integer, intent(in) :: u - type(model_data_t), target :: model - type(flavor_t) :: flv - type(process_constants_t) :: process_data - real(default) :: sqrts, E - class(phs_config_t), allocatable, target :: phs_data - class(phs_t), pointer :: phs => null () - type(vector4_t), dimension(2) :: p, q - integer :: u_phs - - write (u, "(A)") "* Test output: phs_wood_2" - write (u, "(A)") "* Purpose: test simple single-channel phase space" - write (u, "(A)") - - call model%init_test () - call flv%init (25, model) - - write (u, "(A)") "* Initialize a process and a matching & - &phase-space configuration" - write (u, "(A)") - - call init_test_process_data (var_str ("phs_wood_2"), process_data) - u_phs = free_unit () - open (u_phs, status = "scratch", action = "readwrite") - call write_test_phs_file (u_phs, var_str ("phs_wood_2")) - rewind (u_phs) - - allocate (phs_wood_config_t :: phs_data) - call phs_data%init (process_data, model) - select type (phs_data) - type is (phs_wood_config_t) - call phs_data%set_input (u_phs) - end select - - sqrts = 1000._default - call phs_data%configure (sqrts) - - call phs_data%write (u) - - write (u, "(A)") - write (u, "(A)") "* Initialize the phase-space instance" - write (u, "(A)") + close (u_in) + write (u, *) + write (u, "(A)") "* Test output end: cascades2_lexer_1" + end subroutine cascades2_lexer_1 - call phs_data%allocate_instance (phs) - call phs%init (phs_data) +@ %def cascades2_lexer_1 +@%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{An alternative cascades module} +This module might replace the module [[cascades]], which generates +suitable phase space parametrizations and generates the phase space file. +The mappings, as well as the criteria to determine these, do not change. - call phs%write (u, verbose=.true.) +The advantage of this module is that it makes use of the [[O'Mega]] matrix +element generator which provides the relevant Feynman diagrams (the ones +which can be constructed only from 3-vertices). In principle, the +construction of these diagrams is also one of the tasks of the existing +[[cascades]] module, in which the diagrams would correspond to a set of +cascades. It starts by creating cascades which correspond to the +outgoing particles. These are combined to a new cascade using the +vertices of the model. In this way, since each cascade knows the +daughter cascades from which it is built, complete Feynman diagrams are +represented by sets of cascades, as soon as the existing cascades can be +recombined with the incoming particle(s). - write (u, "(A)") - write (u, "(A)") "* Set incoming momenta" - write (u, "(A)") +In this module, the Feynman diagrams are represented by the type +[[feyngraph_t]], which represents the Feynman diagrams as a tree of +nodes. The object which contains the necessary kinematical information +to determine mappings, and hence sensible phase space parametrizations +is of another type, called [[kingraph_t]], which is built from a +corresponding [[feyngraph]] object. - E = sqrts / 2 - p(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) - p(2) = vector4_moving (E,-sqrt (E**2 - flv%get_mass ()**2), 3) +There are two types of output which can be produced by [[O'Mega]] and +are potentially relevant here. The first type contains all tree +diagrams for the process under consideration, where each line of the +output corresponds to one Feynman diagram. This output is easy to read, +but can be very large, depending on the number of particles involved in +the process. Moreover, it repeats substructures of the diagrams which +are part of more than one diagram. One could in principle work with +this output and construct a [[feyngraph]] from each line, if allowed, +i.e. if there are only 3-vertices. - call phs%set_incoming_momenta (p) - call phs%compute_flux () - call phs%write (u) +The other output contains also all of these Feynman diagrams, but in +a factorized form. This means that the substructures which appear in +several Feynman diagrams, are written only once, if possible. This +leads to a much shorter input file, which speeds up the parsing +process. Furthermore it makes it possible to reconstruct the +[[feyngraphs]] in such a way that the calculations concerning +subdiagrams which reappear in other [[feyngraphs]] have to be +performed only once. This is already the case in the existing +[[cascades]] module but can be exploited more efficiently here +because the possible graphs are well known from the input file, whereas +the [[cascades]] module would create a large number of [[cascades]] +which do not lead to a complete Feynman diagram of the given process. +<<[[cascades2.f90]]>>= +<> - write (u, "(A)") - write (u, "(A)") "* Compute phase-space point & - &for x = 0.125, 0.5" - write (u, "(A)") +module cascades2 - call phs%evaluate_selected_channel (1, [0.125_default, 0.5_default]) - call phs%evaluate_other_channels (1) - call phs%write (u) - write (u, "(A)") - select type (phs) - type is (phs_wood_t) - call phs%write_forest (u) - end select + use, intrinsic :: iso_fortran_env, only : input_unit, output_unit, error_unit +<> + use kinds, only: TC, i8 +<> +<> + use diagnostics + use flavors + use model_data + use phs_forests, only: phs_parameters_t + use resonances, only: resonance_info_t + use resonances, only: resonance_history_t + use resonances, only: resonance_history_set_t + use cascades2_lexer - write (u, "(A)") - write (u, "(A)") "* Inverse kinematics" - write (u, "(A)") +<> - call phs%get_outgoing_momenta (q) - call phs%final () - deallocate (phs) +<> - call phs_data%allocate_instance (phs) - call phs%init (phs_data) +<> - call phs%set_incoming_momenta (p) - call phs%compute_flux () - call phs%set_outgoing_momenta (q) +<> - call phs%inverse () - call phs%write (u) - write (u, "(A)") - select type (phs) - type is (phs_wood_t) - call phs%write_forest (u) - end select +<> - call phs%final () - deallocate (phs) + interface +<> + end interface - close (u_phs) - call phs_data%final () - call model%final () +contains - write (u, "(A)") - write (u, "(A)") "* Test output end: phs_wood_2" +<> - end subroutine phs_wood_2 +end module cascades2 -@ %def phs_wood_2 +@ %def cascades2 @ -\subsubsection{Phase-space generation} -Generate phase space for a simple process. -<>= - call test (phs_wood_3, "phs_wood_3", & - "phase-space generation", & - u, results) -<>= - public :: phs_wood_3 -<>= - subroutine phs_wood_3 (u) - integer, intent(in) :: u - type(model_data_t), target :: model - type(process_constants_t) :: process_data - type(phs_parameters_t) :: phs_par - class(phs_config_t), allocatable :: phs_data - integer :: iostat - character(80) :: buffer - - write (u, "(A)") "* Test output: phs_wood_3" - write (u, "(A)") "* Purpose: generate a phase-space configuration" - write (u, "(A)") - - call model%init_test () - - call syntax_phs_forest_init () - - write (u, "(A)") "* Initialize a process and phase-space parameters" - write (u, "(A)") - - call init_test_process_data (var_str ("phs_wood_3"), process_data) - allocate (phs_wood_config_t :: phs_data) - call phs_data%init (process_data, model) - - phs_par%sqrts = 1000 - select type (phs_data) - type is (phs_wood_config_t) - call phs_data%set_parameters (phs_par) - phs_data%io_unit_keep_open = .true. - end select - - write (u, "(A)") - write (u, "(A)") "* Generate a scratch phase-space file" - write (u, "(A)") +<<[[cascades2_sub.f90]]>>= +<> - call phs_data%configure (phs_par%sqrts) +submodule (cascades2) cascades2_s - select type (phs_data) - type is (phs_wood_config_t) - rewind (phs_data%io_unit) - do - read (phs_data%io_unit, "(A)", iostat = iostat) buffer - if (iostat /= 0) exit - write (u, "(A)") trim (buffer) - end do - end select + use sorting + use io_units + use physics_defs, only: SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR + use hashes + use cascades, only: phase_space_vanishes, MAX_WARN_RESONANCE - write (u, "(A)") - write (u, "(A)") "* Cleanup" + implicit none - call phs_data%final () - call model%final () +contains - write (u, "(A)") - write (u, "(A)") "* Test output end: phs_wood_3" +<> - end subroutine phs_wood_3 +end submodule cascades2_s -@ %def phs_wood_3 +@ %def cascades2_s @ -\subsubsection{Nontrivial process} -Generate phase space for a $2\to 3$ process. -<>= - call test (phs_wood_4, "phs_wood_4", & - "nontrivial process", & - u, results) -<>= - public :: phs_wood_4 -<>= - subroutine phs_wood_4 (u) - integer, intent(in) :: u - type(model_data_t), target :: model - type(process_constants_t) :: process_data - type(phs_parameters_t) :: phs_par - class(phs_config_t), allocatable, target :: phs_data - integer :: iostat - character(80) :: buffer - class(phs_t), pointer :: phs => null () - real(default) :: E, pL - type(vector4_t), dimension(2) :: p - type(vector4_t), dimension(3) :: q - - write (u, "(A)") "* Test output: phs_wood_4" - write (u, "(A)") "* Purpose: generate a phase-space configuration" - write (u, "(A)") - - call model%init_test () - - call syntax_phs_forest_init () - - write (u, "(A)") "* Initialize a process and phase-space parameters" - write (u, "(A)") - - process_data%id = "phs_wood_4" - process_data%model_name = "Test" - process_data%n_in = 2 - process_data%n_out = 3 - process_data%n_flv = 1 - allocate (process_data%flv_state (process_data%n_in + process_data%n_out, & - process_data%n_flv)) - process_data%flv_state(:,1) = [25, 25, 25, 6, -6] - - allocate (phs_wood_config_t :: phs_data) - call phs_data%init (process_data, model) - - phs_par%sqrts = 1000 - select type (phs_data) - type is (phs_wood_config_t) - call phs_data%set_parameters (phs_par) - phs_data%io_unit_keep_open = .true. - end select - - write (u, "(A)") - write (u, "(A)") "* Generate a scratch phase-space file" - write (u, "(A)") - - call phs_data%configure (phs_par%sqrts) - - select type (phs_data) - type is (phs_wood_config_t) - rewind (phs_data%io_unit) - do - read (phs_data%io_unit, "(A)", iostat = iostat) buffer - if (iostat /= 0) exit - write (u, "(A)") trim (buffer) - end do - end select - - write (u, "(A)") - write (u, "(A)") "* Initialize the phase-space instance" - write (u, "(A)") - - call phs_data%allocate_instance (phs) - call phs%init (phs_data) - - write (u, "(A)") "* Set incoming momenta" - write (u, "(A)") - - select type (phs_data) - type is (phs_wood_config_t) - E = phs_data%sqrts / 2 - pL = sqrt (E**2 - phs_data%flv(1,1)%get_mass ()**2) - end select - p(1) = vector4_moving (E, pL, 3) - p(2) = vector4_moving (E, -pL, 3) - - call phs%set_incoming_momenta (p) - call phs%compute_flux () - - write (u, "(A)") "* Compute phase-space point & - &for x = 0.1, 0.2, 0.3, 0.4, 0.5" - write (u, "(A)") - - call phs%evaluate_selected_channel (1, & - [0.1_default, 0.2_default, 0.3_default, 0.4_default, 0.5_default]) - call phs%evaluate_other_channels (1) - call phs%write (u) - - write (u, "(A)") - write (u, "(A)") "* Inverse kinematics" - write (u, "(A)") - - call phs%get_outgoing_momenta (q) - call phs%final () - deallocate (phs) - - call phs_data%allocate_instance (phs) - call phs%init (phs_data) - - call phs%set_incoming_momenta (p) - call phs%compute_flux () - call phs%set_outgoing_momenta (q) - - call phs%inverse () - call phs%write (u) - - write (u, "(A)") - write (u, "(A)") "* Cleanup" - - call phs%final () - deallocate (phs) - - call phs_data%final () - call model%final () - - write (u, "(A)") - write (u, "(A)") "* Test output end: phs_wood_4" +\subsection{Particle properties} +We define a type holding the properties of the particles which are needed +for parsing and finding the phase space parametrizations and mappings. +The properties of all particles which appear in the parsed +Feynman diagrams for the given process will be stored in a central place, +and only pointers to these objects are used. +<>= + type :: part_prop_t + character(len=LABEL_LEN) :: particle_label + integer :: pdg = 0 + real(default) :: mass = 0. + real :: width = 0. + integer :: spin_type = 0 + logical :: is_vector = .false. + logical :: empty = .true. + type(part_prop_t), pointer :: anti => null () + type(string_t) :: tex_name + contains + <> + end type part_prop_t - end subroutine phs_wood_4 +@ %def part_prop_t +@ The [[particle_label]] in [[part_prop_t]] is simply the particle name +(e.g. 'W+'). The corresponding variable in the type [[f_node_t]] contains +some additional information related to the external momenta, see below. +The length of the [[character]] variable is fixed as: +<>= + integer, parameter :: LABEL_LEN=30 +@ %def LABEL_LEN +<>= + procedure :: final => part_prop_final +<>= + module subroutine part_prop_final (part) + class(part_prop_t), intent(inout) :: part + end subroutine part_prop_final +<>= + module subroutine part_prop_final (part) + class(part_prop_t), intent(inout) :: part + part%anti => null () + end subroutine part_prop_final -@ %def phs_wood_4 +@ %def part_prop_final @ -\subsubsection{Equivalences} -Generate phase space for a simple process, including channel equivalences. -<>= - call test (phs_wood_5, "phs_wood_5", & - "equivalences", & - u, results) -<>= - public :: phs_wood_5 -<>= - subroutine phs_wood_5 (u) - integer, intent(in) :: u - type(model_data_t), target :: model - type(process_constants_t) :: process_data - type(phs_parameters_t) :: phs_par - class(phs_config_t), allocatable :: phs_data - - write (u, "(A)") "* Test output: phs_wood_5" - write (u, "(A)") "* Purpose: generate a phase-space configuration" - write (u, "(A)") - - call model%init_test () - - call syntax_phs_forest_init () - - write (u, "(A)") "* Initialize a process and phase-space parameters" - write (u, "(A)") - - call init_test_process_data (var_str ("phs_wood_5"), process_data) - allocate (phs_wood_config_t :: phs_data) - call phs_data%init (process_data, model) - - phs_par%sqrts = 1000 - select type (phs_data) - type is (phs_wood_config_t) - call phs_data%set_parameters (phs_par) - call phs_data%enable_equivalences () - end select - - write (u, "(A)") - write (u, "(A)") "* Generate a scratch phase-space file" - write (u, "(A)") - - call phs_data%configure (phs_par%sqrts) - call phs_data%write (u) - write (u, "(A)") - - select type (phs_data) - type is (phs_wood_config_t) - call phs_data%write_forest (u) - end select - - write (u, "(A)") - write (u, "(A)") "* Cleanup" - - call phs_data%final () - call model%final () - - write (u, "(A)") - write (u, "(A)") "* Test output end: phs_wood_5" - - end subroutine phs_wood_5 - -@ %def phs_wood_5 +\subsection{The mapping modes} +The possible mappings are essentially the same as in [[cascades]], but we +introduce in addition the mapping constant [[NON_RESONANT]], which does +not refer to a new mapping; it corresponds to the nonresonant version of +a potentially resonant particle (or [[k_node]]). This becomes relevant +when we compare [[k_nodes]] to eliminate equivalences. +<>= + integer, parameter :: & + & NONRESONANT = -2, EXTERNAL_PRT = -1, & + & NO_MAPPING = 0, S_CHANNEL = 1, T_CHANNEL = 2, U_CHANNEL = 3, & + & RADIATION = 4, COLLINEAR = 5, INFRARED = 6, & + & STEP_MAPPING_E = 11, STEP_MAPPING_H = 12, & + & ON_SHELL = 99 +@ %def NONRESONANT EXTERNAL_PRT +@ %def NO_MAPPING S_CHANNEL T_CHANNEL U_CHANNEL +@ %def RADIATION COLLINEAR INFRARED +@ %def STEP_MAPPING_E STEP_MAPPING_H +@ %def ON_SHELL @ -\subsubsection{MD5 sum checks} -Generate phase space for a simple process. Repeat this with and without -parameter change. -<>= - call test (phs_wood_6, "phs_wood_6", & - "phase-space generation", & - u, results) -<>= - public :: phs_wood_6 -<>= - subroutine phs_wood_6 (u) - integer, intent(in) :: u - type(model_data_t), target :: model - type(process_constants_t) :: process_data - type(phs_parameters_t) :: phs_par - class(phs_config_t), allocatable :: phs_data - logical :: exist, found, match - integer :: u_phs - character(*), parameter :: filename = "phs_wood_6_p.phs" - - write (u, "(A)") "* Test output: phs_wood_6" - write (u, "(A)") "* Purpose: generate and check phase-space file" - write (u, "(A)") +\subsection{Grove properties} +The channels or [[kingraphs]] will be grouped in groves, i.e. sets of +channels, which share some characteristic numbers. These numbers are +stored in the following type: +<>= + type :: grove_prop_t + integer :: multiplicity = 0 + integer :: n_resonances = 0 + integer :: n_log_enhanced = 0 + integer :: n_off_shell = 0 + integer :: n_t_channel = 0 + integer :: res_hash = 0 + end type grove_prop_t - call model%init_test () +@ %def grove_prop_t +@ +\subsection{The tree type} +This type contains all the information which is needed to +reconstruct a [[feyngraph]] or [[kingraph]]. We store bincodes, pdg codes +and mappings for all nodes of a valid [[kingraph]]. If we label the +external particles as given in the process definition with integer +numbers representing their position in the process definition, the bincode +would be the number that one obtains by setting the bit at the position +that is given by this number. If we combine two particles/nodes to a third +one (using a three-vertex of the given model), the bincode is the number which +one obtains by setting all the bits which are set for the two particles. +The [[pdg]] and [[mapping]] are simply the pdg-code and mapping at the +position (i.e. propagator or external particle) which is specified by the +corresponding bincode. We use [[tree_t]] not only for completed [[kingraphs]], +but also for all [[k_nodes]], which are a subtree of a [[kingraph]]. +<>= + type :: tree_t + integer(TC), dimension(:), allocatable :: bc + integer, dimension(:), allocatable :: pdg + integer, dimension(:), allocatable :: mapping + integer :: n_entries = 0 + logical :: keep = .true. + logical :: empty = .true. + contains + <> + end type tree_t - call syntax_phs_forest_init () +@ %def tree_t +<>= + procedure :: final => tree_final +<>= + module subroutine tree_final (tree) + class(tree_t), intent(inout) :: tree + end subroutine tree_final +<>= + module subroutine tree_final (tree) + class(tree_t), intent(inout) :: tree + if (allocated (tree%bc)) deallocate (tree%bc) + if (allocated (tree%pdg)) deallocate (tree%pdg) + if (allocated (tree%mapping)) deallocate (tree%mapping) + end subroutine tree_final - write (u, "(A)") "* Initialize a process and phase-space parameters" - write (u, "(A)") +@ %def tree_final +<>= + interface assignment (=) + module procedure tree_assign + end interface assignment (=) - call init_test_process_data (var_str ("phs_wood_6"), process_data) - process_data%id = "phs_wood_6_p" - process_data%md5sum = "1234567890abcdef1234567890abcdef" - allocate (phs_wood_config_t :: phs_data) - call phs_data%init (process_data, model) +<>= + module subroutine tree_assign (tree1, tree2) + type(tree_t), intent(inout) :: tree1 + type(tree_t), intent(in) :: tree2 + end subroutine tree_assign +<>= + module subroutine tree_assign (tree1, tree2) + type(tree_t), intent(inout) :: tree1 + type(tree_t), intent(in) :: tree2 + if (allocated (tree2%bc)) then + allocate (tree1%bc(size(tree2%bc))) + tree1%bc = tree2%bc + end if + if (allocated (tree2%pdg)) then + allocate (tree1%pdg(size(tree2%pdg))) + tree1%pdg = tree2%pdg + end if + if (allocated (tree2%mapping)) then + allocate (tree1%mapping(size(tree2%mapping))) + tree1%mapping = tree2%mapping + end if + tree1%n_entries = tree2%n_entries + tree1%keep = tree2%keep + tree1%empty = tree2%empty + end subroutine tree_assign - phs_par%sqrts = 1000 - select type (phs_data) - type is (phs_wood_config_t) - call phs_data%set_parameters (phs_par) - end select +@ %def tree_assign +@ +\subsection{Add entries to the tree} +The following procedures fill the arrays in [[tree_t]] with entries +resulting from the bincode and mapping assignment. +<>= + procedure :: add_entry_from_numbers => tree_add_entry_from_numbers + procedure :: add_entry_from_node => tree_add_entry_from_node + generic :: add_entry => add_entry_from_numbers, add_entry_from_node +@ Here we add a single entry to each of the arrays. This will exclusively +be used for external particles. +<>= + module subroutine tree_add_entry_from_numbers (tree, bincode, pdg, mapping) + class(tree_t), intent(inout) :: tree + integer(TC), intent(in) :: bincode + integer, intent(in) :: pdg + integer, intent(in) :: mapping + end subroutine tree_add_entry_from_numbers +<>= + module subroutine tree_add_entry_from_numbers (tree, bincode, pdg, mapping) + class(tree_t), intent(inout) :: tree + integer(TC), intent(in) :: bincode + integer, intent(in) :: pdg + integer, intent(in) :: mapping + integer :: pos + if (tree%empty) then + allocate (tree%bc(1)) + allocate (tree%pdg(1)) + allocate (tree%mapping(1)) + pos = tree%n_entries + 1 + tree%bc(pos) = bincode + tree%pdg(pos) = pdg + tree%mapping(pos) = mapping + tree%n_entries = pos + tree%empty = .false. + end if + end subroutine tree_add_entry_from_numbers - write (u, "(A)") "* Remove previous phs file, if any" - write (u, "(A)") +@ %def tree_add_entry_from_numbers +@ Here we merge two existing subtrees and a single entry (bc, pdg and +mapping). +<>= + subroutine tree_merge (tree, tree1, tree2, bc, pdg, mapping) + class(tree_t), intent(inout) :: tree + type(tree_t), intent(in) :: tree1, tree2 + integer(TC), intent(in) :: bc + integer, intent(in) :: pdg, mapping + integer :: tree_size + integer :: i1, i2 + if (tree%empty) then + i1 = tree1%n_entries + i2 = tree1%n_entries + tree2%n_entries + !! Proof: tree_size > 0 (always) + tree_size = tree1%n_entries + tree2%n_entries + 1 + allocate (tree%bc (tree_size)) + allocate (tree%pdg (tree_size)) + allocate (tree%mapping (tree_size)) + if (.not. tree1%empty) then + tree%bc(:i1) = tree1%bc + tree%pdg(:i1) = tree1%pdg + tree%mapping(:i1) = tree1%mapping + end if + if (.not. tree2%empty) then + tree%bc(i1+1:i2) = tree2%bc + tree%pdg(i1+1:i2) = tree2%pdg + tree%mapping(i1+1:i2) = tree2%mapping + end if + tree%bc(tree_size) = bc + tree%pdg(tree_size) = pdg + tree%mapping(tree_size) = mapping + tree%n_entries = tree_size + tree%empty = .false. + end if + end subroutine tree_merge - inquire (file = filename, exist = exist) - if (exist) then - u_phs = free_unit () - open (u_phs, file = filename, action = "write") - close (u_phs, status = "delete") +@ %def tree_merge +@ Here we add entries to a tree for a given [[k_node]], which means that +we first have to determine whether the node is external or internal. +The arrays are sorted after the entries have been added (see below for +details). +<>= + module subroutine tree_add_entry_from_node (tree, node) + class(tree_t), intent(inout) :: tree + type(k_node_t), intent(in) :: node + end subroutine tree_add_entry_from_node +<>= + module subroutine tree_add_entry_from_node (tree, node) + class(tree_t), intent(inout) :: tree + type(k_node_t), intent(in) :: node + integer :: pdg + if (node%t_line) then + pdg = abs (node%particle%pdg) + else + pdg = node%particle%pdg + end if + if (associated (node%daughter1) .and. & + associated (node%daughter2)) then + call tree_merge (tree, node%daughter1%subtree, & + node%daughter2%subtree, node%bincode, & + node%particle%pdg, node%mapping) + else + call tree_add_entry_from_numbers (tree, node%bincode, & + node%particle%pdg, node%mapping) end if + call tree%sort () + end subroutine tree_add_entry_from_node - write (u, "(A)") "* Check phase-space file (should fail)" - write (u, "(A)") +@ %def tree_add_entry_from_node +@ For a well-defined order of the elements of the arrays in [[tree_t]], +the elements can be sorted. The bincodes (entries of [[bc]]) are +simply ordered by size, the [[pdg]] and [[mapping]] entries go to the +positions of the corresponding [[bc]] values. +<>= + procedure :: sort => tree_sort +<>= + module subroutine tree_sort (tree) + class(tree_t), intent(inout) :: tree + end subroutine tree_sort +<>= + module subroutine tree_sort (tree) + class(tree_t), intent(inout) :: tree + integer(TC), dimension(size(tree%bc)) :: bc_tmp + integer, dimension(size(tree%pdg)) :: pdg_tmp, mapping_tmp + integer, dimension(1) :: pos + integer :: i + bc_tmp = tree%bc + pdg_tmp = tree%pdg + mapping_tmp = tree%mapping + do i = size(tree%bc),1,-1 + pos = maxloc (bc_tmp) + tree%bc(i) = bc_tmp (pos(1)) + tree%pdg(i) = pdg_tmp (pos(1)) + tree%mapping(i) = mapping_tmp (pos(1)) + bc_tmp(pos(1)) = 0 + end do + end subroutine tree_sort - select type (phs_data) - type is (phs_wood_config_t) - call phs_data%read_phs_file (exist, found, match) - write (u, "(1x,A,L1)") "exist = ", exist - write (u, "(1x,A,L1)") "found = ", found - write (u, "(1x,A,L1)") "match = ", match - end select +@ %def tree_sort +@ +\subsection{Graph types} +We define an abstract type which will give rise to two different types: +The type [[feyngraph_t]] contains the pure information of the +corresponding Feynman diagram, but also a list of objects of the +[[kingraph]] type which contain the kinematically relevant data for the +mapping calculation as well as the mappings themselves. Every graph +should have an index which is unique. Graphs which are not needed any +more can be disabled by setting the [[keep]] variable to [[false]]. +<>= + type, abstract :: graph_t + integer :: index = 0 + integer :: n_nodes = 0 + logical :: keep = .true. + end type graph_t - write (u, "(A)") - write (u, "(A)") "* Generate a phase-space file" - write (u, "(A)") +@ %def graph_t +@ This is the type representing the Feynman diagrams which are read from +an input file created by O'Mega. It is a tree of nodes, which we call +[[f_nodes]], so that [[feyngraph_t]] contains a pointer to the root of +this tree, and each node can have two daughter nodes. The case of only +one associated daughter should never appear, because in the method of +phase space parametrization which is used here, we combine always two +particle momenta to a third one. The [[feyngraphs]] will be arranged in +a linked list. This is why we have a pointer to the next graph. The +[[kingraphs]] on the other hand are arranged in linked lists which are +attached to the corresponding [[feyngraph]]. In general, a [[feyngraph]] +can give rise to more than one [[kingraph]] because we make a copy +every time a particle can be resonant, so that in the copy we keep +the particle nonresonant. +<>= + type, extends (graph_t) :: feyngraph_t + type(string_t) :: omega_feyngraph_output + type(f_node_t), pointer :: root => null () + type(feyngraph_t), pointer :: next => null() + type(kingraph_t), pointer :: kin_first => null () + type(kingraph_t), pointer :: kin_last => null () + contains + <> + end type feyngraph_t - call phs_data%configure (phs_par%sqrts) +@ %def feyngraph_t +@ A container for a pointer of type [[feyngraph_t]]. This is used to +realize arrays of these pointers. +<>= + type :: feyngraph_ptr_t + type(feyngraph_t), pointer :: graph => null () + end type feyngraph_ptr_t - write (u, "(1x,A,A,A)") "MD5 sum (process) = '", & - phs_data%md5sum_process, "'" - write (u, "(1x,A,A,A)") "MD5 sum (model par) = '", & - phs_data%md5sum_model_par, "'" - write (u, "(1x,A,A,A)") "MD5 sum (phs config) = '", & - phs_data%md5sum_phs_config, "'" +@ %def feyngraph_ptr_t +@ +The length of a string describing a Feynman diagram which is produced by +O'Mega is fixed by the parameter +<>= + integer, parameter :: FEYNGRAPH_LEN=300 +@ %def feyngraph_len +<>= + procedure :: final => feyngraph_final +<>= + module subroutine feyngraph_final (graph) + class(feyngraph_t), intent(inout) :: graph + end subroutine feyngraph_final +<>= + module subroutine feyngraph_final (graph) + class(feyngraph_t), intent(inout) :: graph + type(kingraph_t), pointer :: current + graph%root => null () + graph%kin_last => null () + do while (associated (graph%kin_first)) + current => graph%kin_first + graph%kin_first => graph%kin_first%next + call current%final () + deallocate (current) + end do + end subroutine feyngraph_final - write (u, "(A)") - write (u, "(A)") "* Check MD5 sum" - write (u, "(A)") +@ %def feyngraph_final +This is the type of graph which is used to find the phase space channels, +or in other words, each kingraph could correspond to a channel, if it is +not eliminated for kinematical reasons or due to an equivalence. For the +linked list which is attached to the corresponding [[feyngraph]], we +need the [[next]] pointer, whereas [[grove_next]] points to the next +[[kingraph]] within a grove. The information which is relevant for the +specification of a channel is stored in [[tree]]. We use [[grove_prop]] +to sort the [[kingraph]] in a grove in which all [[kingraphs]] are +characterized by the numbers contained in [[grove_prop]]. Later these +groves are further subdevided using the resonance hash. A [[kingraph]] +which is constructed directly from the output of O'Mega, is not +[[inverse]]. In this case the first incoming particle is the root ofthe +tree. In a scattering process, we can also construct a [[kingraph]] +where the root of the tree is the second incoming particle. In this +case the value of [[inverse]] is [[.true.]]. +<>= + type, extends (graph_t) :: kingraph_t + type(k_node_t), pointer :: root => null () + type(kingraph_t), pointer :: next => null() + type(kingraph_t), pointer :: grove_next => null () + type(tree_t) :: tree + type(grove_prop_t) :: grove_prop + logical :: inverse = .false. + integer :: prc_component = 0 + contains + <> + end type kingraph_t - call phs_data%final () - deallocate (phs_data) - allocate (phs_wood_config_t :: phs_data) - call phs_data%init (process_data, model) - phs_par%sqrts = 1000 - select type (phs_data) - type is (phs_wood_config_t) - call phs_data%set_parameters (phs_par) - phs_data%sqrts = phs_par%sqrts - phs_data%par%sqrts = phs_par%sqrts - end select - call phs_data%compute_md5sum () +@ %def kingraph_t +@ Another container for a pointer to emulate arrays of pointers: +<>= + type :: kingraph_ptr_t + type(kingraph_t), pointer :: graph => null () + end type kingraph_ptr_t - write (u, "(1x,A,A,A)") "MD5 sum (process) = '", & - phs_data%md5sum_process, "'" - write (u, "(1x,A,A,A)") "MD5 sum (model par) = '", & - phs_data%md5sum_model_par, "'" - write (u, "(1x,A,A,A)") "MD5 sum (phs config) = '", & - phs_data%md5sum_phs_config, "'" +@ %def kingraph_ptr_t +@ +<>= + procedure :: final => kingraph_final +<>= + module subroutine kingraph_final (graph) + class(kingraph_t), intent(inout) :: graph + end subroutine kingraph_final +<>= + module subroutine kingraph_final (graph) + class(kingraph_t), intent(inout) :: graph + graph%root => null () + graph%next => null () + graph%grove_next => null () + call graph%tree%final () + end subroutine kingraph_final - select type (phs_data) - type is (phs_wood_config_t) - call phs_data%read_phs_file (exist, found, match) - write (u, "(1x,A,L1)") "exist = ", exist - write (u, "(1x,A,L1)") "found = ", found - write (u, "(1x,A,L1)") "match = ", match - end select +@ %def kingraph_final +@ +\subsection{The node types} +We define an abstract type containing variables which are needed for +[[f_node_t]] as well as [[k_node_t]]. We say that a node is on the +t-line if it lies between the two nodes which correspond to the two +incoming particles. [[incoming]] and [[tline]] are used only for +scattering processes and remain [[.false.]] in decay processes. The +variable [[n_subtree_nodes]] holds the number of nodes (including the +node itself) of the subtree of which the node is the root. +<>= + type, abstract :: node_t + type(part_prop_t), pointer :: particle => null () + logical :: incoming = .false. + logical :: t_line = .false. + integer :: index = 0 + logical :: keep = .true. + integer :: n_subtree_nodes = 1 + end type node_t - write (u, "(A)") - write (u, "(A)") "* Modify sqrts and check MD5 sum" - write (u, "(A)") +@ %def node_t +@ We use two different list types for the different kinds of nodes. We +therefore start with an abstract type: +<>= + type, abstract :: list_t + integer :: n_entries = 0 + end type list_t - call phs_data%final () - deallocate (phs_data) - allocate (phs_wood_config_t :: phs_data) - call phs_data%init (process_data, model) - phs_par%sqrts = 500 - select type (phs_data) - type is (phs_wood_config_t) - call phs_data%set_parameters (phs_par) - phs_data%sqrts = phs_par%sqrts - phs_data%par%sqrts = phs_par%sqrts - end select - call phs_data%compute_md5sum () +@ %def list_t +@ Since the contents of the lists are different, we introduce two +different entry types. Since the trees of nodes use pointers, the nodes +should only be allocated by a type-bound procedure of the corresponding +list type, such that we can keep track of all nodes, eventually reuse +and in the end deallocate nodes correctly, without forgetting any nodes. +Here is the type for the [[k_nodes]]. The list is a linked list. We want +to reuse (recycle) the [[k_nodes]] which are neither [[incoming]] nore +[[t_line]]. +<>= + type :: k_node_entry_t + type(k_node_t), pointer :: node => null () + type(k_node_entry_t), pointer :: next => null () + logical :: recycle = .false. + contains + <> + end type k_node_entry_t - write (u, "(1x,A,A,A)") "MD5 sum (process) = '", & - phs_data%md5sum_process, "'" - write (u, "(1x,A,A,A)") "MD5 sum (model par) = '", & - phs_data%md5sum_model_par, "'" - write (u, "(1x,A,A,A)") "MD5 sum (phs config) = '", & - phs_data%md5sum_phs_config, "'" +@ %def k_node_entry_t +<>= + procedure :: final => k_node_entry_final +<>= + module subroutine k_node_entry_final (entry) + class(k_node_entry_t), intent(inout) :: entry + end subroutine k_node_entry_final +<>= + module subroutine k_node_entry_final (entry) + class(k_node_entry_t), intent(inout) :: entry + if (associated (entry%node)) then + call entry%node%final + deallocate (entry%node) + end if + entry%next => null () + end subroutine k_node_entry_final - select type (phs_data) - type is (phs_wood_config_t) - call phs_data%read_phs_file (exist, found, match) - write (u, "(1x,A,L1)") "exist = ", exist - write (u, "(1x,A,L1)") "found = ", found - write (u, "(1x,A,L1)") "match = ", match - end select +@ %def k_node_entry_final +<>= + procedure :: write => k_node_entry_write +<>= + module subroutine k_node_entry_write (k_node_entry, u) + class(k_node_entry_t), intent(in) :: k_node_entry + integer, intent(in) :: u + end subroutine k_node_entry_write +<>= + module subroutine k_node_entry_write (k_node_entry, u) + class(k_node_entry_t), intent(in) :: k_node_entry + integer, intent(in) :: u + end subroutine k_node_entry_write - write (u, "(A)") - write (u, "(A)") "* Modify process and check MD5 sum" - write (u, "(A)") +@ %def k_node_entry_write +@ Here is the list type for [[k_nodes]]. A [[k_node_list]] can be +declared to be an observer. In this case it does not create any nodes by +itself, but the entries set their pointers to existing nodes. In this +way we can use the list structure and the type bound procedures for +existing nodes. +<>= + type, extends (list_t) :: k_node_list_t + type(k_node_entry_t), pointer :: first => null () + type(k_node_entry_t), pointer :: last => null () + integer :: n_recycle + logical :: observer = .false. + contains + <> + end type k_node_list_t - call phs_data%final () - deallocate (phs_data) - process_data%md5sum = "77777777777777777777777777777777" - allocate (phs_wood_config_t :: phs_data) - call phs_data%init (process_data, model) - phs_par%sqrts = 1000 - select type (phs_data) - type is (phs_wood_config_t) - call phs_data%set_parameters (phs_par) - phs_data%sqrts = phs_par%sqrts - phs_data%par%sqrts = phs_par%sqrts - end select - call phs_data%compute_md5sum () +@ %def k_node_list_t +<>= + procedure :: final => k_node_list_final +<>= + module subroutine k_node_list_final (list) + class(k_node_list_t), intent(inout) :: list + end subroutine k_node_list_final +<>= + module subroutine k_node_list_final (list) + class(k_node_list_t), intent(inout) :: list + type(k_node_entry_t), pointer :: current + do while (associated (list%first)) + current => list%first + list%first => list%first%next + if (list%observer) current%node => null () + call current%final () + deallocate (current) + end do + end subroutine k_node_list_final - write (u, "(1x,A,A,A)") "MD5 sum (process) = '", & - phs_data%md5sum_process, "'" - write (u, "(1x,A,A,A)") "MD5 sum (model par) = '", & - phs_data%md5sum_model_par, "'" - write (u, "(1x,A,A,A)") "MD5 sum (phs config) = '", & - phs_data%md5sum_phs_config, "'" +@ %def k_node_list_final +@ The [[f_node_t]] type contains the [[particle_label]] variable which is +extracted from the input file. It consists not only of the particle +name, but also of some numbers in brackets. These numbers indicate which +external particles are part of the subtree of this node. The [[f_node]] +contains also a list of [[k_nodes]]. Therefore, if the nodes are not +[[incoming]] or [[t_line]], the mapping calculations for these +[[k_nodes]] which can appear in several [[kingraphs]] have to be +performed only once. +<>= + type, extends (node_t) :: f_node_t + type(f_node_t), pointer :: daughter1 => null () + type(f_node_t), pointer :: daughter2 => null () + character(len=LABEL_LEN) :: particle_label + type(k_node_list_t) :: k_node_list + contains + <> + end type f_node_t - select type (phs_data) - type is (phs_wood_config_t) - call phs_data%read_phs_file (exist, found, match) - write (u, "(1x,A,L1)") "exist = ", exist - write (u, "(1x,A,L1)") "found = ", found - write (u, "(1x,A,L1)") "match = ", match - end select +@ %def f_node_t +@ The finalizer nullifies the daughter pointers, since they are +deallocated, like the [[f_node]] itself, with the finalizer of the +[[f_node_list]]. +<>= + procedure :: final => f_node_final +<>= + recursive module subroutine f_node_final (node) + class(f_node_t), intent(inout) :: node + end subroutine f_node_final +<>= + recursive module subroutine f_node_final (node) + class(f_node_t), intent(inout) :: node + call node%k_node_list%final () + node%daughter1 => null () + node%daughter2 => null () + end subroutine f_node_final - write (u, "(A)") - write (u, "(A)") "* Modify phs parameter and check MD5 sum" - write (u, "(A)") +@ %def f_node_final +@ Finaliser for [[f_node_entry]]. +<>= + procedure :: final => f_node_entry_final +<>= + module subroutine f_node_entry_final (entry) + class(f_node_entry_t), intent(inout) :: entry + end subroutine f_node_entry_final +<>= + module subroutine f_node_entry_final (entry) + class(f_node_entry_t), intent(inout) :: entry + if (associated (entry%node)) then + call entry%node%final () + deallocate (entry%node) + end if + entry%next => null () + end subroutine f_node_entry_final - call phs_data%final () - deallocate (phs_data) - allocate (phs_wood_config_t :: phs_data) - process_data%md5sum = "1234567890abcdef1234567890abcdef" - call phs_data%init (process_data, model) - phs_par%sqrts = 1000 - phs_par%off_shell = 17 - select type (phs_data) - type is (phs_wood_config_t) - call phs_data%set_parameters (phs_par) - phs_data%sqrts = phs_par%sqrts - phs_data%par%sqrts = phs_par%sqrts - end select - call phs_data%compute_md5sum () +@ %def f_node_entry_final +@ Set index if not yet done, i.e. if it is zero. +<>= + procedure :: set_index => f_node_set_index +<>= + module subroutine f_node_set_index (f_node) + class(f_node_t), intent(inout) :: f_node + end subroutine f_node_set_index +<>= + module subroutine f_node_set_index (f_node) + class(f_node_t), intent(inout) :: f_node + integer, save :: counter = 0 + if (f_node%index == 0) then + counter = counter + 1 + f_node%index = counter + end if + end subroutine f_node_set_index - write (u, "(1x,A,A,A)") "MD5 sum (process) = '", & - phs_data%md5sum_process, "'" - write (u, "(1x,A,A,A)") "MD5 sum (model par) = '", & - phs_data%md5sum_model_par, "'" - write (u, "(1x,A,A,A)") "MD5 sum (phs config) = '", & - phs_data%md5sum_phs_config, "'" +@ %def f_node_set_index +@ +Type for the nodes of the tree (lines of the Feynman diagrams). We +also need a type containing a pointer to a node, which is needed for +creating arrays of pointers. This will be used for scattering +processes where we can take either the first or the second particle to +be the root of the tree. Since we need both cases for the calculations +and O'Mega only gives us one of these, we have to perform a +transformation of the graph in which some nodes (on the line which we +hereafter call t-line) need to know their mother and sister nodes, +which become their daughters within this transformation. +<>= + type :: f_node_ptr_t + type(f_node_t), pointer :: node => null () + contains + <> + end type f_node_ptr_t - select type (phs_data) - type is (phs_wood_config_t) - call phs_data%read_phs_file (exist, found, match) - write (u, "(1x,A,L1)") "exist = ", exist - write (u, "(1x,A,L1)") "found = ", found - write (u, "(1x,A,L1)") "match = ", match - end select +@ %def f_node_ptr_t +<>= + procedure :: final => f_node_ptr_final +<>= + module subroutine f_node_ptr_final (f_node_ptr) + class(f_node_ptr_t), intent(inout) :: f_node_ptr + end subroutine f_node_ptr_final +<>= + module subroutine f_node_ptr_final (f_node_ptr) + class(f_node_ptr_t), intent(inout) :: f_node_ptr + f_node_ptr%node => null () + end subroutine f_node_ptr_final - write (u, "(A)") - write (u, "(A)") "* Modify model parameter and check MD5 sum" - write (u, "(A)") +@ %def f_node_ptr_final +<>= + interface assignment (=) + module procedure f_node_ptr_assign + end interface assignment (=) +<>= + module subroutine f_node_ptr_assign (ptr1, ptr2) + type(f_node_ptr_t), intent(out) :: ptr1 + type(f_node_ptr_t), intent(in) :: ptr2 + end subroutine f_node_ptr_assign +<>= + module subroutine f_node_ptr_assign (ptr1, ptr2) + type(f_node_ptr_t), intent(out) :: ptr1 + type(f_node_ptr_t), intent(in) :: ptr2 + ptr1%node => ptr2%node + end subroutine f_node_ptr_assign - call phs_data%final () - deallocate (phs_data) - allocate (phs_wood_config_t :: phs_data) - call model%set_par (var_str ("ms"), 100._default) - call phs_data%init (process_data, model) - phs_par%sqrts = 1000 - phs_par%off_shell = 1 - select type (phs_data) - type is (phs_wood_config_t) - call phs_data%set_parameters (phs_par) - phs_data%sqrts = phs_par%sqrts - phs_data%par%sqrts = phs_par%sqrts - end select - call phs_data%compute_md5sum () +@ %def f_node_ptr_assign +@ +<>= + type :: k_node_ptr_t + type(k_node_t), pointer :: node => null () + end type k_node_ptr_t - write (u, "(1x,A,A,A)") "MD5 sum (process) = '", & - phs_data%md5sum_process, "'" - write (u, "(1x,A,A,A)") "MD5 sum (model par) = '", & - phs_data%md5sum_model_par, "'" - write (u, "(1x,A,A,A)") "MD5 sum (phs config) = '", & - phs_data%md5sum_phs_config, "'" +@ %def k_node_ptr_t +@ +<>= + type, extends (node_t) :: k_node_t + type(k_node_t), pointer :: daughter1 => null () + type(k_node_t), pointer :: daughter2 => null () + type(k_node_t), pointer :: inverse_daughter1 => null () + type(k_node_t), pointer :: inverse_daughter2 => null () + type(f_node_t), pointer :: f_node => null () + type(tree_t) :: subtree + real (default) :: ext_mass_sum = 0. + real (default) :: effective_mass = 0. + logical :: resonant = .false. + logical :: on_shell = .false. + logical :: log_enhanced = .false. + integer :: mapping = NO_MAPPING + integer(TC) :: bincode = 0 + logical :: mapping_assigned = .false. + logical :: is_nonresonant_copy = .false. + logical :: subtree_checked = .false. + integer :: n_off_shell = 0 + integer :: n_log_enhanced = 0 + integer :: n_resonances = 0 + integer :: multiplicity = 0 + integer :: n_t_channel = 0 + integer :: f_node_index = 0 + contains + <> + end type k_node_t - select type (phs_data) - type is (phs_wood_config_t) - call phs_data%read_phs_file (exist, found, match) - write (u, "(1x,A,L1)") "exist = ", exist - write (u, "(1x,A,L1)") "found = ", found - write (u, "(1x,A,L1)") "match = ", match - end select +@ %def k_node_t +@ +Subroutine for [[k_node]] assignment. +<>= + interface assignment (=) + module procedure k_node_assign + end interface assignment (=) +<>= + module subroutine k_node_assign (k_node1, k_node2) + type(k_node_t), intent(inout) :: k_node1 + type(k_node_t), intent(in) :: k_node2 + end subroutine k_node_assign +<>= + module subroutine k_node_assign (k_node1, k_node2) + type(k_node_t), intent(inout) :: k_node1 + type(k_node_t), intent(in) :: k_node2 + k_node1%f_node => k_node2%f_node + k_node1%particle => k_node2%particle + k_node1%incoming = k_node2%incoming + k_node1%t_line = k_node2%t_line + k_node1%keep = k_node2%keep + k_node1%n_subtree_nodes = k_node2%n_subtree_nodes + k_node1%ext_mass_sum = k_node2%ext_mass_sum + k_node1%effective_mass = k_node2%effective_mass + k_node1%resonant = k_node2%resonant + k_node1%on_shell = k_node2%on_shell + k_node1%log_enhanced = k_node2%log_enhanced + k_node1%mapping = k_node2%mapping + k_node1%bincode = k_node2%bincode + k_node1%mapping_assigned = k_node2%mapping_assigned + k_node1%is_nonresonant_copy = k_node2%is_nonresonant_copy + k_node1%n_off_shell = k_node2%n_off_shell + k_node1%n_log_enhanced = k_node2%n_log_enhanced + k_node1%n_resonances = k_node2%n_resonances + k_node1%multiplicity = k_node2%multiplicity + k_node1%n_t_channel = k_node2%n_t_channel + k_node1%f_node_index = k_node2%f_node_index + end subroutine k_node_assign - write (u, "(A)") - write (u, "(A)") "* Cleanup" +@ %def k_node_assign +@ The finalizer of [[k_node_t]] nullifies all pointers to nodes, since the +deallocation of these nodes takes place in the finalizer of the list by which +they were created. +<>= + procedure :: final => k_node_final +<>= + recursive module subroutine k_node_final (k_node) + class(k_node_t), intent(inout) :: k_node + end subroutine k_node_final +<>= + recursive module subroutine k_node_final (k_node) + class(k_node_t), intent(inout) :: k_node + k_node%daughter1 => null () + k_node%daughter2 => null () + k_node%inverse_daughter1 => null () + k_node%inverse_daughter2 => null () + k_node%f_node => null () + end subroutine k_node_final - call phs_data%final () - call model%final () +@ %def k_node_final +@ Set an index to a [[k_node]], if not yet done, i.e. if it is zero. The +indices are simply positive integer numbers starting from 1. +<>= + procedure :: set_index => k_node_set_index +<>= + module subroutine k_node_set_index (k_node) + class(k_node_t), intent(inout) :: k_node + end subroutine k_node_set_index +<>= + module subroutine k_node_set_index (k_node) + class(k_node_t), intent(inout) :: k_node + integer, save :: counter = 0 + if (k_node%index == 0) then + counter = counter + 1 + k_node%index = counter + end if + end subroutine k_node_set_index - write (u, "(A)") - write (u, "(A)") "* Test output end: phs_wood_6" +@ %def k_node_set_index +@ The process type (decay or scattering) is given by an integer which is +equal to the number of incoming particles. +<>= + public :: DECAY, SCATTERING +<>= + integer, parameter :: DECAY=1, SCATTERING=2 - end subroutine phs_wood_6 +@ %def decay scattering +@ The entries of the [[f_node_list]] contain the substring of the input +file from which the node's subtree will be constructed (or a modified +string containing placeholders for substrings). We use the +length of this string for fast comparison to find the nodes in the +[[f_node_list]] which we want to reuse. +<>= + type :: f_node_entry_t + character(len=FEYNGRAPH_LEN) :: subtree_string + integer :: string_len = 0 + type(f_node_t), pointer :: node => null () + type(f_node_entry_t), pointer :: next => null () + integer :: subtree_size = 0 + contains + <> + end type f_node_entry_t -@ %def phs_wood_6 -@ -<>= - call test (phs_wood_vis_1, "phs_wood_vis_1", & - "visualizing phase space channels", & - u, results) -<>= - public :: phs_wood_vis_1 -<>= - subroutine phs_wood_vis_1 (u) +@ %def f_node_entry_t +@ A write method for [[f_node_entry]]. +<>= + procedure :: write => f_node_entry_write +<>= + module subroutine f_node_entry_write (f_node_entry, u) + class(f_node_entry_t), intent(in) :: f_node_entry + integer, intent(in) :: u + end subroutine f_node_entry_write +<>= + module subroutine f_node_entry_write (f_node_entry, u) + class(f_node_entry_t), intent(in) :: f_node_entry integer, intent(in) :: u - type(os_data_t) :: os_data - type(model_data_t), target :: model - type(process_constants_t) :: process_data - class(phs_config_t), allocatable :: phs_data - type(mapping_defaults_t) :: mapping_defaults - type(string_t) :: vis_file, pdf_file, ps_file - real(default) :: sqrts - logical :: exist, exist_pdf, exist_ps - integer :: u_phs, iostat, u_vis - character(95) :: buffer - - write (u, "(A)") "* Test output: phs_wood_vis_1" - write (u, "(A)") "* Purpose: visualizing the & - &phase-space configuration" - write (u, "(A)") - - call os_data%init () - call model%init_test () - - call syntax_phs_forest_init () + write (unit=u, fmt='(A)') trim(f_node_entry%subtree_string) + end subroutine f_node_entry_write - write (u, "(A)") "* Initialize a process" - write (u, "(A)") +@ %def f_node_entry_write +<>= + interface assignment (=) + module procedure f_node_entry_assign + end interface assignment (=) +<>= + module subroutine f_node_entry_assign (entry1, entry2) + type(f_node_entry_t), intent(out) :: entry1 + type(f_node_entry_t), intent(in) :: entry2 + end subroutine f_node_entry_assign +<>= + module subroutine f_node_entry_assign (entry1, entry2) + type(f_node_entry_t), intent(out) :: entry1 + type(f_node_entry_t), intent(in) :: entry2 + entry1%node => entry2%node + entry1%subtree_string = entry2%subtree_string + entry1%string_len = entry2%string_len + entry1%subtree_size = entry2%subtree_size + end subroutine f_node_entry_assign - call init_test_process_data (var_str ("phs_wood_vis_1"), process_data) +@ %def f_node_entry_assign +@ This is the list type for [[f_nodes]]. The variable [[max_tree_size]] +is the number of nodes which appear in a complete graph. +<>= + type, extends (list_t) :: f_node_list_t + type(f_node_entry_t), pointer :: first => null () + type(f_node_entry_t), pointer :: last => null () + type(k_node_list_t), pointer :: k_node_list => null () + integer :: max_tree_size = 0 + contains + <> + end type f_node_list_t - write (u, "(A)") "* Create a scratch phase-space file" - write (u, "(A)") +@ %def f_node_list_t +@ Add an entry to the [[f_node_list]]. If the node might be reused, we check first +using the [[subtree_string]] if there is already a node in the list which +is the root of exactly the same subtree. Otherwise we add an entry to the +list and allocate the node. In both cases we return a pointer to the node +which allows to access the node. +<>= + procedure :: add_entry => f_node_list_add_entry +<>= + module subroutine f_node_list_add_entry (list, subtree_string, & + ptr_to_node, recycle, subtree_size) + class(f_node_list_t), intent(inout) :: list + character(len=*), intent(in) :: subtree_string + type(f_node_t), pointer, intent(out) :: ptr_to_node + logical, intent(in) :: recycle + integer, intent(in), optional :: subtree_size + end subroutine f_node_list_add_entry +<>= + module subroutine f_node_list_add_entry (list, subtree_string, & + ptr_to_node, recycle, subtree_size) + class(f_node_list_t), intent(inout) :: list + character(len=*), intent(in) :: subtree_string + type(f_node_t), pointer, intent(out) :: ptr_to_node + logical, intent(in) :: recycle + integer, intent(in), optional :: subtree_size + type(f_node_entry_t), pointer :: current + type(f_node_entry_t), pointer :: second + integer :: subtree_len + ptr_to_node => null () + if (recycle) then + subtree_len = len_trim (subtree_string) + current => list%first + do while (associated (current)) + if (present (subtree_size)) then + if (current%subtree_size /= subtree_size) exit + end if + if (current%string_len == subtree_len) then + if (trim (current%subtree_string) == trim (subtree_string)) then + ptr_to_node => current%node + exit + end if + end if + current => current%next + end do + end if + if (.not. associated (ptr_to_node)) then + if (list%n_entries == 0) then + allocate (list%first) + list%last => list%first + else + second => list%first + list%first => null () + allocate (list%first) + list%first%next => second + end if + list%n_entries = list%n_entries + 1 + list%first%subtree_string = trim(subtree_string) + list%first%string_len = subtree_len + if (present (subtree_size)) list%first%subtree_size = subtree_size + allocate (list%first%node) + call list%first%node%set_index () + ptr_to_node => list%first%node + end if + end subroutine f_node_list_add_entry - u_phs = free_unit () - open (u_phs, status = "scratch", action = "readwrite") - call write_test_phs_file (u_phs, var_str ("phs_wood_vis_1")) - rewind (u_phs) - do - read (u_phs, "(A)", iostat = iostat) buffer - if (iostat /= 0) exit - write (u, "(A)") trim (buffer) +@ %def f_node_list_add_entry +@ A write method for debugging. +<>= + procedure :: write => f_node_list_write +<>= + module subroutine f_node_list_write (f_node_list, u) + class(f_node_list_t), intent(in) :: f_node_list + integer, intent(in) :: u + end subroutine f_node_list_write +<>= + module subroutine f_node_list_write (f_node_list, u) + class(f_node_list_t), intent(in) :: f_node_list + integer, intent(in) :: u + type(f_node_entry_t), pointer :: current + integer :: pos = 0 + current => f_node_list%first + do while (associated (current)) + pos = pos + 1 + write (unit=u, fmt='(A,I10)') 'entry #: ', pos + call current%write (u) + write (unit=u, fmt=*) + current => current%next end do + end subroutine f_node_list_write - write (u, "(A)") - write (u, "(A)") "* Setup phase-space configuration object" - write (u, "(A)") - - mapping_defaults%step_mapping = .false. - - allocate (phs_wood_config_t :: phs_data) - call phs_data%init (process_data, model) - select type (phs_data) - type is (phs_wood_config_t) - call phs_data%set_input (u_phs) - call phs_data%set_mapping_defaults (mapping_defaults) - phs_data%os_data = os_data - phs_data%io_unit = 0 - phs_data%io_unit_keep_open = .true. - phs_data%vis_channels = .true. - end select - - sqrts = 1000._default - call phs_data%configure (sqrts) - - call phs_data%write (u) - write (u, "(A)") - - select type (phs_data) - type is (phs_wood_config_t) - call phs_data%write_forest (u) - end select +@ %def f_node_list_write +<>= + interface assignment (=) + module procedure k_node_entry_assign + end interface assignment (=) +<>= + module subroutine k_node_entry_assign (entry1, entry2) + type(k_node_entry_t), intent(out) :: entry1 + type(k_node_entry_t), intent(in) :: entry2 + end subroutine k_node_entry_assign +<>= + module subroutine k_node_entry_assign (entry1, entry2) + type(k_node_entry_t), intent(out) :: entry1 + type(k_node_entry_t), intent(in) :: entry2 + entry1%node => entry2%node + entry1%recycle = entry2%recycle + end subroutine k_node_entry_assign - vis_file = "phs_wood_vis_1.phs-vis.tex" - ps_file = "phs_wood_vis_1.phs-vis.ps" - pdf_file = "phs_wood_vis_1.phs-vis.pdf" - inquire (file = char (vis_file), exist = exist) - if (exist) then - u_vis = free_unit () - open (u_vis, file = char (vis_file), action = "read", status = "old") - iostat = 0 - do while (iostat == 0) - read (u_vis, "(A)", iostat = iostat) buffer - if (iostat == 0) write (u, "(A)") trim (buffer) - end do - close (u_vis) +@ %def k_node_entry_assign +@ Add an entry to the [[k_node_list]]. We have to specify if the +node can be reused. The check for existing reusable nodes happens with +[[k_node_list_get_nodes]] (see below). +<>= + procedure :: add_entry => k_node_list_add_entry +<>= + recursive module subroutine k_node_list_add_entry & + (list, ptr_to_node, recycle) + class(k_node_list_t), intent(inout) :: list + type(k_node_t), pointer, intent(out) :: ptr_to_node + logical, intent(in) :: recycle + end subroutine k_node_list_add_entry +<>= + recursive module subroutine k_node_list_add_entry & + (list, ptr_to_node, recycle) + class(k_node_list_t), intent(inout) :: list + type(k_node_t), pointer, intent(out) :: ptr_to_node + logical, intent(in) :: recycle + if (list%n_entries == 0) then + allocate (list%first) + list%last => list%first else - write (u, "(A)") "[Visualize LaTeX file is missing]" + allocate (list%last%next) + list%last => list%last%next end if - inquire (file = char (ps_file), exist = exist_ps) - if (exist_ps) then - write (u, "(A)") "[Visualize Postscript file exists and is nonempty]" + list%n_entries = list%n_entries + 1 + list%last%recycle = recycle + allocate (list%last%node) + call list%last%node%set_index () + ptr_to_node => list%last%node + end subroutine k_node_list_add_entry + +@ %def k_node_list_add_entry +@ We need a similar subroutine for adding only a pointer to a list. This +is needed for a [[k_node_list]] which is only an observer, i.e. it does +not create any nodes by itself. +<>= + procedure :: add_pointer => k_node_list_add_pointer +<>= + module subroutine k_node_list_add_pointer (list, ptr_to_node, recycle) + class(k_node_list_t), intent(inout) :: list + type(k_node_t), pointer, intent(in) :: ptr_to_node + logical, optional, intent(in) :: recycle + end subroutine k_node_list_add_pointer +<>= + module subroutine k_node_list_add_pointer (list, ptr_to_node, recycle) + class(k_node_list_t), intent(inout) :: list + type(k_node_t), pointer, intent(in) :: ptr_to_node + logical, optional, intent(in) :: recycle + logical :: rec + if (present (recycle)) then + rec = recycle else - write (u, "(A)") "[Visualize Postscript file is missing/non-regular]" + rec = .false. end if - inquire (file = char (pdf_file), exist = exist_pdf) - if (exist_pdf) then - write (u, "(A)") "[Visualize PDF file exists and is nonempty]" + if (list%n_entries == 0) then + allocate (list%first) + list%last => list%first else - write (u, "(A)") "[Visualize PDF file is missing/non-regular]" + allocate (list%last%next) + list%last => list%last%next end if + list%n_entries = list%n_entries + 1 + list%last%recycle = rec + list%last%node => ptr_to_node + end subroutine k_node_list_add_pointer - write (u, "(A)") - write (u, "(A)") "* Cleanup" +@ %def k_node_list_add_pointer +@ The [[k_node_list]] can also be used to collect [[k_nodes]] which belong to +different [[f_nodes]] in order to compare these. This is done only for nodes +which have the same number of subtree nodes. We compare all nodes of the +list with each other (as long as the node is not deactivated, i.e. if +the [[keep]] variable is set to [[.true.]]) using the subroutine +[[subtree_select]]. If it turns out that two nodes are equivalent, we +keep only one of them. The term equivalent in this module refers to trees +or subtrees which differ in the pdg codes at positions where +the trivial mapping is used ([[NO_MAPPING]] or [[NON_RESONANT]]) so that +the mass of the particle does not matter. Depending on the available +couplings, two equivalent subtrees could eventually lead to the same phase +space channels, which is why only one of them is kept. +<>= + procedure :: check_subtree_equivalences => & + k_node_list_check_subtree_equivalences +<>= + module subroutine k_node_list_check_subtree_equivalences (list, model) + class(k_node_list_t), intent(inout) :: list + type(model_data_t), intent(in) :: model + end subroutine k_node_list_check_subtree_equivalences +<>= + module subroutine k_node_list_check_subtree_equivalences (list, model) + class(k_node_list_t), intent(inout) :: list + type(model_data_t), intent(in) :: model + type(k_node_ptr_t), dimension (:), allocatable :: set + type(k_node_entry_t), pointer :: current + integer :: pos + integer :: i,j + if (list%n_entries == 0) return + allocate (set (list%n_entries)) + current => list%first + pos = 0 + do while (associated (current)) + pos = pos + 1 + set(pos)%node => current%node + current => current%next + end do + do i=1, list%n_entries + if (set(i)%node%keep) then + do j=i+1, list%n_entries + if (set(j)%node%keep) then + if (set(i)%node%bincode == set(j)%node%bincode) then + call subtree_select (set(i)%node%subtree,set(j)%node%subtree, model) + if (.not. set(i)%node%subtree%keep) then + set(i)%node%keep = .false. + exit + else if (.not. set(j)%node%subtree%keep) then + set(j)%node%keep = .false. + end if + end if + end if + end do + end if + end do + deallocate (set) + end subroutine k_node_list_check_subtree_equivalences - close (u_phs) - call phs_data%final () - call model%final () +@ %def k_node_list_check_subtree_equivalences +@ This subroutine is used to obtain all [[k_nodes]] of a [[k_node_list]] +which can be recycled and are not disabled for some reason. We pass an +allocatable array of the type [[k_node_ptr_t]] which will be allocated +if there are any such nodes in the list and the pointers will be +associated with these nodes. +<>= + procedure :: get_nodes => k_node_list_get_nodes +<>= + module subroutine k_node_list_get_nodes (list, nodes) + class(k_node_list_t), intent(inout) :: list + type(k_node_ptr_t), dimension(:), allocatable, intent(out) :: nodes + end subroutine k_node_list_get_nodes +<>= + module subroutine k_node_list_get_nodes (list, nodes) + class(k_node_list_t), intent(inout) :: list + type(k_node_ptr_t), dimension(:), allocatable, intent(out) :: nodes + integer :: n_nodes + integer :: pos + type(k_node_entry_t), pointer :: current, garbage + n_nodes = 0 + current => list%first + do while (associated (current)) + if (current%recycle .and. current%node%keep) n_nodes = n_nodes + 1 + current => current%next + end do + if (n_nodes /= 0) then + pos = 1 + allocate (nodes (n_nodes)) + do while (associated (list%first) .and. .not. list%first%node%keep) + garbage => list%first + list%first => list%first%next + call garbage%final () + deallocate (garbage) + end do + current => list%first + do while (associated (current)) + do while (associated (current%next)) + if (.not. current%next%node%keep) then + garbage => current%next + current%next => current%next%next + call garbage%final + deallocate (garbage) + else + exit + end if + end do + if (current%recycle .and. current%node%keep) then + nodes(pos)%node => current%node + pos = pos + 1 + end if + current => current%next + end do + end if + end subroutine k_node_list_get_nodes - write (u, "(A)") - write (u, "(A)") "* Test output end: phs_wood_vis_1" +@ %def k_node_list_get_nodes +Gfortran 7/8/9 bug, has to remain in the main module: +<>= + procedure :: final => f_node_list_final +<>= + subroutine f_node_list_final (list) + class(f_node_list_t) :: list + type(f_node_entry_t), pointer :: current + list%k_node_list => null () + do while (associated (list%first)) + current => list%first + list%first => list%first%next + call current%final () + deallocate (current) + end do + end subroutine f_node_list_final - end subroutine phs_wood_vis_1 +@ %def f_node_list_final +@ +\subsection{The grove list} +First a type is introduced in order to speed up the comparison of kingraphs +with the purpose to quickly find the graphs that might be equivalent. +This is done solely on the basis of a number (which is given +by the value of [[depth]] in [[compare_tree_t]]) of bincodes, which are +the highest ones that do not belong to external particles. +The highest such value determines the index of the element in the [[entry]] +array of the [[compare_tree]]. The next lower such value determines +the index of the element in the [[entry]] array of this [[entry]], and so +on and so forth. This results in a tree structure where the number of +levels is given by [[depth]] and should not be too large for reasons of +memory. +This is the entry type. +<>= + type :: compare_tree_entry_t + type(compare_tree_entry_t), dimension(:), pointer :: entry => null () + type(kingraph_ptr_t), dimension(:), allocatable :: graph_entry + contains + <> + end type compare_tree_entry_t -@ %def phs_wood_vis_1 -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{The FKS phase space} -<<[[phs_fks.f90]]>>= -<> +@ %def compare_tree_entry_t +@ This is the tree type. +<>= + type :: compare_tree_t + integer :: depth = 3 + type(compare_tree_entry_t), dimension(:), pointer :: entry => null () + contains + <> + end type compare_tree_t -module phs_fks +@ %def compare_tree_t +@ Finalizers for both types. The one for the entry type has to be recursive. +<>= + procedure :: final => compare_tree_final +<>= + module subroutine compare_tree_final (ctree) + class(compare_tree_t), intent(inout) :: ctree + end subroutine compare_tree_final +<>= + module subroutine compare_tree_final (ctree) + class(compare_tree_t), intent(inout) :: ctree + integer :: i + if (associated (ctree%entry)) then + do i=1, size (ctree%entry) + call ctree%entry(i)%final () + deallocate (ctree%entry) + end do + end if + end subroutine compare_tree_final -<> -<> -<> - use constants - use diagnostics - use io_units, only: given_output_unit, free_unit - use format_utils, only: write_separator - use lorentz - use phs_points, only: phs_point_t - use phs_points, only: assignment(=), size, sum - use physics_defs - use flavors - use pdg_arrays, only: is_colored - use models, only: model_t - use sf_mappings - use sf_base - use phs_base - use resonances, only: resonance_contributors_t, resonance_history_t - use phs_forests, only: phs_forest_final - use phs_wood - use cascades - use cascades2 - use process_constants - use process_libraries - use ttv_formfactors, only: generate_on_shell_decay_threshold, m1s_to_mpole - use format_defs, only: FMT_17 +@ %def compare_tree_final +<>= + procedure :: final => compare_tree_entry_final +<>= + recursive module subroutine compare_tree_entry_final (ct_entry) + class(compare_tree_entry_t), intent(inout) :: ct_entry + end subroutine compare_tree_entry_final +<>= + recursive module subroutine compare_tree_entry_final (ct_entry) + class(compare_tree_entry_t), intent(inout) :: ct_entry + integer :: i + if (associated (ct_entry%entry)) then + do i=1, size (ct_entry%entry) + call ct_entry%entry(i)%final () + end do + deallocate (ct_entry%entry) + else + deallocate (ct_entry%graph_entry) + end if + end subroutine compare_tree_entry_final -<> +@ %def compare_tree_entry_final +@ Check the presence of a graph which is considered as equivalent and +select between the two. If there is no such graph, the current one +is added to the list. First the entry has to be found: +<>= + procedure :: check_kingraph => compare_tree_check_kingraph +<>= + module subroutine compare_tree_check_kingraph & + (ctree, kingraph, model, preliminary) + class(compare_tree_t), intent(inout) :: ctree + type(kingraph_t), intent(inout), pointer :: kingraph + type(model_data_t), intent(in) :: model + logical, intent(in) :: preliminary + end subroutine compare_tree_check_kingraph +<>= + module subroutine compare_tree_check_kingraph & + (ctree, kingraph, model, preliminary) + class(compare_tree_t), intent(inout) :: ctree + type(kingraph_t), intent(inout), pointer :: kingraph + type(model_data_t), intent(in) :: model + logical, intent(in) :: preliminary + integer :: i + integer :: pos + integer(TC) :: sz + integer(TC), dimension(:), allocatable :: identifier + if (.not. associated (ctree%entry)) then + sz = 0_TC + do i = size(kingraph%tree%bc), 1, -1 + sz = ior (sz, kingraph%tree%bc(i)) + end do + if (sz > 0) then + allocate (ctree%entry (sz)) + else + call msg_bug ("Compare tree could not be created") + end if + end if + allocate (identifier (ctree%depth)) + pos = 0 + do i = size(kingraph%tree%bc), 1, -1 + if (popcnt (kingraph%tree%bc(i)) /= 1) then + pos = pos + 1 + identifier(pos) = kingraph%tree%bc(i) + if (pos == ctree%depth) exit + end if + end do + if (size (identifier) > 1) then + call ctree%entry(identifier(1))%check_kingraph (kingraph, model, & + preliminary, identifier(1), identifier(2:)) + else if (size (identifier) == 1) then + call ctree%entry(identifier(1))%check_kingraph & + (kingraph, model, preliminary) + end if + deallocate (identifier) + end subroutine compare_tree_check_kingraph -<> +@ %def compare_tree_check_kingraph +@ Then the graphs of the entry are checked. +<>= + procedure :: check_kingraph => compare_tree_entry_check_kingraph +<>= + recursive module subroutine compare_tree_entry_check_kingraph (ct_entry, & + kingraph, model, preliminary, subtree_size, identifier) + class(compare_tree_entry_t), intent(inout) :: ct_entry + type(kingraph_t), pointer, intent(inout) :: kingraph + type(model_data_t), intent(in) :: model + logical, intent(in) :: preliminary + integer, intent(in), optional :: subtree_size + integer, dimension (:), intent(in), optional :: identifier + end subroutine compare_tree_entry_check_kingraph +<>= + recursive module subroutine compare_tree_entry_check_kingraph (ct_entry, & + kingraph, model, preliminary, subtree_size, identifier) + class(compare_tree_entry_t), intent(inout) :: ct_entry + type(kingraph_t), pointer, intent(inout) :: kingraph + type(model_data_t), intent(in) :: model + logical, intent(in) :: preliminary + integer, intent(in), optional :: subtree_size + integer, dimension (:), intent(in), optional :: identifier + if (present (identifier)) then + if (.not. associated (ct_entry%entry)) & + allocate (ct_entry%entry(subtree_size)) + if (size (identifier) > 1) then + call ct_entry%entry(identifier(1))%check_kingraph (kingraph, & + model, preliminary, identifier(1), identifier(2:)) + else if (size (identifier) == 1) then + call ct_entry%entry(identifier(1))%check_kingraph (kingraph, & + model, preliminary) + end if + else + if (allocated (ct_entry%graph_entry)) then + call perform_check + else + allocate (ct_entry%graph_entry(1)) + ct_entry%graph_entry(1)%graph => kingraph + end if + end if -<> + contains -<> + subroutine perform_check + integer :: i + logical :: rebuild + rebuild = .true. + do i=1, size(ct_entry%graph_entry) + if (ct_entry%graph_entry(i)%graph%keep) then + if (preliminary .or. & + ct_entry%graph_entry(i)%graph%prc_component /= & + kingraph%prc_component) then + call kingraph_select (ct_entry%graph_entry(i)%graph, & + kingraph, model, preliminary) + if (.not. kingraph%keep) then + return + else if (rebuild .and. .not. & + ct_entry%graph_entry(i)%graph%keep) then + ct_entry%graph_entry(i)%graph => kingraph + rebuild = .false. + end if + end if + end if + end do + if (rebuild) call rebuild_graph_entry + end subroutine perform_check -<> + subroutine rebuild_graph_entry + type(kingraph_ptr_t), dimension(:), allocatable :: tmp_ptr + integer :: i + integer :: pos + allocate (tmp_ptr(size(ct_entry%graph_entry)+1)) + pos = 0 + do i=1, size(ct_entry%graph_entry) + pos = pos + 1 + tmp_ptr(pos)%graph => ct_entry%graph_entry(i)%graph + end do + pos = pos + 1 + tmp_ptr(pos)%graph => kingraph + deallocate (ct_entry%graph_entry) + allocate (ct_entry%graph_entry (pos)) + do i=1, pos + ct_entry%graph_entry(i)%graph => tmp_ptr(i)%graph + end do + deallocate (tmp_ptr) + end subroutine rebuild_graph_entry + end subroutine compare_tree_entry_check_kingraph -contains +@ %def compare_tree_entry_check_kingraph +@ The grove to which a completed [[kingraph]] will be added is determined by the +entries of [[grove_prop]]. We use another list type (linked list) to +arrange the groves. Each [[grove]] contains again a linked list of +[[kingraphs]]. +<>= + type :: grove_t + type(grove_prop_t) :: grove_prop + type(grove_t), pointer :: next => null () + type(kingraph_t), pointer :: first => null () + type(kingraph_t), pointer :: last => null () + type(compare_tree_t) :: compare_tree + contains + <> + end type grove_t -<> +@ %def grove_t +@ Container for a pointer of type [[grove_t]]: +<>= + type :: grove_ptr_t + type(grove_t), pointer :: grove => null () + end type grove_ptr_t -end module phs_fks +@ %def grove_ptr_t +<>= + procedure :: final => grove_final +<>= + module subroutine grove_final (grove) + class(grove_t), intent(inout) :: grove + end subroutine grove_final +<>= + module subroutine grove_final (grove) + class(grove_t), intent(inout) :: grove + grove%first => null () + grove%last => null () + grove%next => null () + end subroutine grove_final -@ %def phs_fks -@ -@ A container for the $x_\oplus$- and $x_\ominus$-values for initial-state -phase spaces. -<>= - public :: isr_kinematics_t -<>= - type :: isr_kinematics_t - integer :: n_in - real(default), dimension(2) :: x = one - real(default), dimension(2) :: z = zero - real(default) :: sqrts_born = zero - real(default), dimension(:), allocatable :: beam_energy - real(default) :: fac_scale = zero - real(default), dimension(2) :: jacobian = one - integer :: isr_mode = SQRTS_FIXED - contains - <> - end type isr_kinematics_t +@ %def grove_final +@ This is the list type: +<>= + type :: grove_list_t + type(grove_t), pointer :: first => null () + contains + <> + end type grove_list_t -@ %def type isr_kinematics_t -@ -<>= - procedure :: write => isr_kinematics_write -<>= - subroutine isr_kinematics_write (isr, unit) - class(isr_kinematics_t), intent(in) :: isr - integer, intent(in), optional :: unit - integer :: u, i - u = given_output_unit (unit); if (u < 0) return - write (u,"(A)") "ISR kinematics: " - write (u,"(A," // FMT_17 // ",1X)") "x(+): ", isr%x(1) - write (u,"(A," // FMT_17 // ",1X)") "x(-): ", isr%x(2) - write (u,"(A," // FMT_17 // ",1X)") "z(+): ", isr%z(1) - write (u,"(A," // FMT_17 // ",1X)") "z(-): ", isr%z(2) - write (u,"(A," // FMT_17 // ",1X)") "sqrts (Born): ", isr%sqrts_born - if (allocated (isr%beam_energy)) then - do i = 1, size (isr%beam_energy) - write (u,"(A," // FMT_17 // ",1X)") "Beam energy: ", & - isr%beam_energy(i) - end do - end if - write (u,"(A," // FMT_17 // ",1X)") "Fac. scale: ", isr%fac_scale - do i = 1, 2 - write (u,"(A," // FMT_17 // ",1X)") "Jacobian: ", isr%jacobian(i) +@ %def grove_list_t +Gfortran 7/8/9 bug, has to remain in the main module: +<>= + procedure :: final => grove_list_final +<>= + subroutine grove_list_final (list) + class(grove_list_t), intent(inout) :: list + class(grove_t), pointer :: current + do while (associated (list%first)) + current => list%first + list%first => list%first%next + call current%final () + deallocate (current) end do - write (u,"(A,I0,1X)") "ISR mode: ", isr%isr_mode - end subroutine isr_kinematics_write - -@ %def isr_kinematics_write -@ -<>= - public :: phs_point_set_t -<>= - type :: phs_point_set_t - type(phs_point_t), dimension(:), allocatable :: phs_point - logical :: initialized = .false. - contains - <> - end type phs_point_set_t + end subroutine grove_list_final -@ %def phs_point_set_t +@ %def grove_list_final @ -<>= - procedure :: init => phs_point_set_init -<>= - subroutine phs_point_set_init (phs_point_set, n_particles, n_phs) - class(phs_point_set_t), intent(out) :: phs_point_set - integer, intent(in) :: n_particles, n_phs - integer :: i_phs - allocate (phs_point_set%phs_point (n_phs)) - do i_phs = 1, n_phs - phs_point_set%phs_point(i_phs) = n_particles - end do - phs_point_set%initialized = .true. - end subroutine phs_point_set_init +\subsection{The feyngraph set} +The fundament of the module is the public type [[feyngraph_set_t]]. It +is not only a linked list of all [[feyngraphs]] but contains an array +of all particle properties ([[particle]]), an [[f_node_list]] and a +pointer of the type [[grove_list_t]], since several [[feyngraph_sets]] +can share a common [[grove_list]]. In addition it keeps the data which +unambiguously specifies the process, as well as the model which +provides information which allows us to choose between equivalent +subtrees or complete [[kingraphs]]. +<>= + public :: feyngraph_set_t +<>= + type :: feyngraph_set_t + type(model_data_t), pointer :: model => null () + type(flavor_t), dimension(:,:), allocatable :: flv + integer :: n_in = 0 + integer :: n_out = 0 + integer :: process_type = DECAY + type(phs_parameters_t) :: phs_par + logical :: fatal_beam_decay = .true. + type(part_prop_t), dimension (:), pointer :: particle => null () + type(f_node_list_t) :: f_node_list + type(feyngraph_t), pointer :: first => null () + type(feyngraph_t), pointer :: last => null () + integer :: n_graphs = 0 + type(grove_list_t), pointer :: grove_list => null () + logical :: use_dag = .true. + type(dag_t), pointer :: dag => null () + type(feyngraph_set_t), dimension (:), pointer :: fset => null () + contains + <> + end type feyngraph_set_t -@ %def phs_point_set_init -@ -<>= - procedure :: write => phs_point_set_write -<>= - subroutine phs_point_set_write (phs_point_set, i_phs, contributors, unit, show_mass, & - testflag, check_conservation, ultra, n_in) - class(phs_point_set_t), intent(in) :: phs_point_set - integer, intent(in), optional :: i_phs - integer, intent(in), dimension(:), optional :: contributors - integer, intent(in), optional :: unit - logical, intent(in), optional :: show_mass - logical, intent(in), optional :: testflag, ultra - logical, intent(in), optional :: check_conservation - integer, intent(in), optional :: n_in - integer :: i, u - type(vector4_t) :: p_sum - u = given_output_unit (unit); if (u < 0) return - if (present (i_phs)) then - call phs_point_set%phs_point(i_phs)%write & - (unit = u, show_mass = show_mass, testflag = testflag, & - check_conservation = check_conservation, ultra = ultra, n_in = n_in) +@ %def feyngraph_set_t +@ This final procedure contains calls to all other necessary final +procedures. Gfortran 7/8/9 bug, has to remain in the main module: +<>= + procedure :: final => feyngraph_set_final +<>= + recursive subroutine feyngraph_set_final (set) + class(feyngraph_set_t), intent(inout) :: set + class(feyngraph_t), pointer :: current + integer :: i + if (associated (set%fset)) then + do i=1, size (set%fset) + call set%fset(i)%final () + end do + deallocate (set%fset) else - do i = 1, size(phs_point_set%phs_point) - call phs_point_set%phs_point(i)%write & - (unit = u, show_mass = show_mass, testflag = testflag, & - check_conservation = check_conservation, ultra = ultra, n_in = n_in) + set%particle => null () + set%grove_list => null () + end if + set%model => null () + if (allocated (set%flv)) deallocate (set%flv) + set%last => null () + do while (associated (set%first)) + current => set%first + set%first => set%first%next + call current%final () + deallocate (current) + end do + if (associated (set%particle)) then + do i = 1, size (set%particle) + call set%particle(i)%final () end do + deallocate (set%particle) end if - if (present (contributors)) then - if (debug_on) call msg_debug (D_SUBTRACTION, "Invariant masses for real emission: ") - associate (pp => phs_point_set%phs_point(i_phs)) - p_sum = sum (pp, [contributors, size (pp)]) - end associate - if (debug_active (D_SUBTRACTION)) & - call vector4_write (p_sum, unit = unit, show_mass = show_mass, & - testflag = testflag, ultra = ultra) + if (associated (set%grove_list)) then + if (debug_on) call msg_debug (D_PHASESPACE, "grove_list: final") + call set%grove_list%final () + deallocate (set%grove_list) end if - end subroutine phs_point_set_write - -@ %def phs_point_set_write -@ -<>= - procedure :: get_n_momenta => phs_point_set_get_n_momenta -<>= - elemental function phs_point_set_get_n_momenta (phs_point_set, i_res) result (n) - integer :: n - class(phs_point_set_t), intent(in) :: phs_point_set - integer, intent(in) :: i_res - n = size (phs_point_set%phs_point(i_res)) - end function phs_point_set_get_n_momenta - -@ %def phs_point_set_get_n_momenta -@ -<>= - procedure :: get_momenta => phs_point_set_get_momenta -<>= - pure function phs_point_set_get_momenta (phs_point_set, i_phs, n_in) result (p) - type(vector4_t), dimension(:), allocatable :: p - class(phs_point_set_t), intent(in) :: phs_point_set - integer, intent(in) :: i_phs - integer, intent(in), optional :: n_in - integer :: i - if (present (n_in)) then - p = phs_point_set%phs_point(i_phs)%select ([(i, i=1, n_in)]) - else - p = phs_point_set%phs_point(i_phs) + if (debug_on) call msg_debug (D_PHASESPACE, "f_node_list: final") + call set%f_node_list%final () + if (associated (set%dag)) then + if (debug_on) call msg_debug (D_PHASESPACE, "dag: final") + if (associated (set%dag)) then + call set%dag%final () + deallocate (set%dag) + end if end if - end function phs_point_set_get_momenta + end subroutine feyngraph_set_final -@ %def phs_point_set_get_momenta +@ %def feyngraph_set_final @ -<>= - procedure :: get_momentum => phs_point_set_get_momentum -<>= - pure function phs_point_set_get_momentum (phs_point_set, i_phs, i_mom) result (p) - type(vector4_t) :: p - class(phs_point_set_t), intent(in) :: phs_point_set - integer, intent(in) :: i_phs, i_mom - p = phs_point_set%phs_point(i_phs)%select (i_mom) - end function phs_point_set_get_momentum +\subsection{Construct the feyngraph set} +We construct the [[feyngraph_set]] from an input file. Therefore we pass +a unit to [[feyngraph_set_build]]. The parsing subroutines are chosen +depending on the value of [[use_dag]]. In the DAG output, which is the one +that is produced by default, we have to work on a string of one line, +where the lenght of this string becomes larger the more particles are +involved in the process. The other output (which is now only used in a +unit test) contains one Feynman diagram per line and each line starts with an open +parenthesis so that we read the file line per line and create a +[[feyngraph]] for every line. Only after this, nodes are created. In both +decay and scattering processes the diagrams are represented like in a decay +process, i.e. in a scattering process one of the incoming particles appears +as an outgoing particle. +<>= + procedure :: build => feyngraph_set_build +<>= + module subroutine feyngraph_set_build (feyngraph_set, u_in) + class(feyngraph_set_t), intent(inout) :: feyngraph_set + integer, intent(in) :: u_in + end subroutine feyngraph_set_build +<>= + module subroutine feyngraph_set_build (feyngraph_set, u_in) + class(feyngraph_set_t), intent(inout) :: feyngraph_set + integer, intent(in) :: u_in + integer :: stat = 0 + character(len=FEYNGRAPH_LEN) :: omega_feyngraph_output + type(feyngraph_t), pointer :: current_graph + type(feyngraph_t), pointer :: compare_graph + logical :: present + if (feyngraph_set%use_dag) then + allocate (feyngraph_set%dag) + if (.not. associated (feyngraph_set%first)) then + call feyngraph_set%dag%read_string (u_in, feyngraph_set%flv(:,1)) + call feyngraph_set%dag%construct (feyngraph_set) + call feyngraph_set%dag%make_feyngraphs (feyngraph_set) + end if + else + if (.not. associated (feyngraph_set%first)) then + read (unit=u_in, fmt='(A)', iostat=stat, advance='yes') & + omega_feyngraph_output + if (omega_feyngraph_output(1:1) == '(') then + allocate (feyngraph_set%first) + feyngraph_set%first%omega_feyngraph_output = & + trim(omega_feyngraph_output) + feyngraph_set%last => feyngraph_set%first + feyngraph_set%n_graphs = feyngraph_set%n_graphs + 1 + else + call msg_fatal ("Invalid input file") + end if + read (unit=u_in, fmt='(A)', iostat=stat, advance='yes') & + omega_feyngraph_output + do while (stat == 0) + if (omega_feyngraph_output(1:1) == '(') then + compare_graph => feyngraph_set%first + present = .false. + do while (associated (compare_graph)) + if (len_trim(compare_graph%omega_feyngraph_output) & + == len_trim(omega_feyngraph_output)) then + if (compare_graph%omega_feyngraph_output == & + omega_feyngraph_output) then + present = .true. + exit + end if + end if + compare_graph => compare_graph%next + end do + if (.not. present) then + allocate (feyngraph_set%last%next) + feyngraph_set%last => feyngraph_set%last%next + feyngraph_set%last%omega_feyngraph_output = & + trim(omega_feyngraph_output) + feyngraph_set%n_graphs = feyngraph_set%n_graphs + 1 + end if + read (unit=u_in, fmt='(A)', iostat=stat, advance='yes') & + omega_feyngraph_output + else + exit + end if + end do + current_graph => feyngraph_set%first + do while (associated (current_graph)) + call feyngraph_construct (feyngraph_set, current_graph) + current_graph => current_graph%next + end do + feyngraph_set%f_node_list%max_tree_size = feyngraph_set%first%n_nodes + end if + end if + end subroutine feyngraph_set_build -@ %def phs_point_set_get_momentum -@ -<>= - procedure :: get_energy => phs_point_set_get_energy -<>= - pure function phs_point_set_get_energy (phs_point_set, i_phs, i_mom) result (E) - real(default) :: E - class(phs_point_set_t), intent(in) :: phs_point_set - integer, intent(in) :: i_phs, i_mom - E = energy (phs_point_set%phs_point(i_phs)%select (i_mom)) - end function phs_point_set_get_energy +@ %def feyngraph_set_build +@ Read the string from the file. The output which is produced by O'Mega +contains the DAG in a factorised form as a long string, distributed over +several lines (in addition, in the case of a scattering process, it +contains a similar string for the same process, but with the other +incoming particle as the root of the tree structure). In general, such a +file can contain many of these strings, belonging to different process +components. Therefore we first have to find the correct position of the +string for the process in question. Therefore we look for a line +containing a pair of colons, in which case the line contains a process +string. Then we check if the process string describes the correct +process, which is done by checking for all the incoming and outgoing +particle names. If the process is correct, the dag output should start +in the following line. As long as we do not find the correct process +string, we continue searching. If we reach the end of the file, we +rewind the unit once, and repeat searching. If the process is still not +found, there must be some sort of error. +<>= + procedure :: read_string => dag_read_string +<>= + module subroutine dag_read_string (dag, u_in, flv) + class(dag_t), intent(inout) :: dag + integer, intent(in) :: u_in + type(flavor_t), dimension(:), intent(in) :: flv + end subroutine dag_read_string +<>= + module subroutine dag_read_string (dag, u_in, flv) + class(dag_t), intent(inout) :: dag + integer, intent(in) :: u_in + type(flavor_t), dimension(:), intent(in) :: flv + character(len=BUFFER_LEN) :: process_string + logical :: process_found + logical :: rewound + !!! Find process string in file + process_found = .false. + rewound = .false. + do while (.not. process_found) + process_string = "" + read (unit=u_in, fmt='(A)') process_string + if (len_trim(process_string) /= 0) then + if (index (process_string, "::") > 0) then + process_found = process_string_match (trim (process_string), flv) + end if + else if (.not. rewound) then + rewind (u_in) + rewound = .true. + else + call msg_bug ("Process string not found in O'Mega input file.") + end if + end do + call fds_file_get_line (u_in, dag%string) + call dag%string%clean () + if (.not. allocated (dag%string%t) .or. dag%string%char_len == 0) & + call msg_bug ("Process string not found in O'Mega input file.") + end subroutine dag_read_string -@ %def phs_point_set_get_energy -@ -<>= - procedure :: get_sqrts => phs_point_set_get_sqrts -<>= - function phs_point_set_get_sqrts (phs_point_set, i_phs) result (sqrts) - real(default) :: sqrts - class(phs_point_set_t), intent(in) :: phs_point_set - integer, intent(in) :: i_phs - sqrts = sqrt (phs_point_set%phs_point(i_phs)%get_msq ([1,2])) - end function phs_point_set_get_sqrts +@ %def dag_read_string +@ The output of factorized Feynman diagrams which is created by O'Mega +for a given process could in principle be written to a single line in +the file. This can however lead to different problems with different +compilers as soon as such lines become too long. This is the reason why +the line is cut into smaller pieces. This means that a new line starts +after each vertical bar. For this long string the type [[dag_string_t]] +has been introduced. In order to read the file quickly into such a +[[dag_string]] we use another type, [[dag_chain_t]] which is a linked +list of such [[dag_strings]]. This has the advantage that we do not +have to recreate a new [[dag_string]] for every line which has been +read from file. Only in the end of this operation we compress the +list of strings to a single string, removing useless [[dag_tokens]], +such as blanc space tokens. This subroutine reads all lines starting +from the position in the file the unit is connected to, until no +backslash character is found at the end of a line (the backslash +means that the next line also belongs to the current string). +<>= + integer, parameter :: BUFFER_LEN = 1000 + integer, parameter :: STACK_SIZE = 100 +@ %def BUFFER_LEN STACK_SIZE +<>= + subroutine fds_file_get_line (u, string) + integer, intent(in) :: u + type(dag_string_t), intent(out) :: string + type(dag_chain_t) :: chain + integer :: string_size, current_len + character(len=BUFFER_LEN) :: buffer + integer :: fragment_len + integer :: stat + current_len = 0 + stat = 0 + string_size = 0 + do while (stat == 0) + read (unit=u, fmt='(A)', iostat=stat) buffer + if (stat /= 0) exit + fragment_len = len_trim (buffer) + if (fragment_len == 0) then + exit + else if (buffer (fragment_len:fragment_len) == BACKSLASH_CHAR) then + fragment_len = fragment_len - 1 + end if + call chain%append (buffer(:fragment_len)) + if (buffer(fragment_len+1:fragment_len+1) /= BACKSLASH_CHAR) exit + end do + if (associated (chain%first)) then + call chain%compress () + string = chain%first + call chain%final () + end if + end subroutine fds_file_get_line -@ %def phs_point_set_get_sqrts -@ -<>= - generic :: set_momenta => set_momenta_p, set_momenta_phs_point - procedure :: set_momenta_p => phs_point_set_set_momenta_p -<>= - subroutine phs_point_set_set_momenta_p (phs_point_set, i_phs, p) - class(phs_point_set_t), intent(inout) :: phs_point_set - integer, intent(in) :: i_phs - type(vector4_t), intent(in), dimension(:) :: p - phs_point_set%phs_point(i_phs) = p - end subroutine phs_point_set_set_momenta_p +@ %def fds_file_get_line +@ We check, if the process string which has been read from file +corresponds to the process for which we want to extract the Feynman +diagrams. +<>= + function process_string_match (string, flv) result (match) + character(len=*), intent(in) :: string + type(flavor_t), dimension(:), intent(in) :: flv + logical :: match + integer :: pos + integer :: occurence + integer :: i + pos = 1 + match = .false. + do i=1, size (flv) + occurence = index (string(pos:), char(flv(i)%get_name())) + if (occurence > 0) then + pos = pos + occurence + match = .true. + else + match = .false. + exit + end if + end do + end function process_string_match -@ %def phs_point_set_set_momenta_p +@ %def process_string_match @ -<>= - procedure :: set_momenta_phs_point => phs_point_set_set_momenta_phs_point -<>= - subroutine phs_point_set_set_momenta_phs_point (phs_point_set, i_phs, p) - class(phs_point_set_t), intent(inout) :: phs_point_set - integer, intent(in) :: i_phs - type(phs_point_t), intent(in) :: p - phs_point_set%phs_point(i_phs) = p - end subroutine phs_point_set_set_momenta_phs_point +\subsection{Particle properties} +This subroutine initializes a model instance with the Standard Model +data. It is only relevant for a unit test. +We do not have to care about the model initialization in this module +because the [[model]] is passed to [[feyngraph_set_generate]] when +it is called. +<>= + public :: init_sm_full_test +<>= + module subroutine init_sm_full_test (model) + class(model_data_t), intent(out) :: model + end subroutine init_sm_full_test +<>= + module subroutine init_sm_full_test (model) + class(model_data_t), intent(out) :: model + type(field_data_t), pointer :: field + integer, parameter :: n_real = 17 + integer, parameter :: n_field = 21 + integer, parameter :: n_vtx = 56 + integer :: i + call model%init (var_str ("SM_vertex_test"), & + n_real, 0, n_field, n_vtx) + call model%init_par (1, var_str ("mZ"), 91.1882_default) + call model%init_par (2, var_str ("mW"), 80.419_default) + call model%init_par (3, var_str ("mH"), 125._default) + call model%init_par (4, var_str ("me"), 0.000510997_default) + call model%init_par (5, var_str ("mmu"), 0.105658389_default) + call model%init_par (6, var_str ("mtau"), 1.77705_default) + call model%init_par (7, var_str ("ms"), 0.095_default) + call model%init_par (8, var_str ("mc"), 1.2_default) + call model%init_par (9, var_str ("mb"), 4.2_default) + call model%init_par (10, var_str ("mtop"), 173.1_default) + call model%init_par (11, var_str ("wtop"), 1.523_default) + call model%init_par (12, var_str ("wZ"), 2.443_default) + call model%init_par (13, var_str ("wW"), 2.049_default) + call model%init_par (14, var_str ("wH"), 0.004143_default) + call model%init_par (15, var_str ("ee"), 0.3079561542961_default) + call model%init_par (16, var_str ("cw"), 8.819013863636E-01_default) + call model%init_par (17, var_str ("sw"), 4.714339240339E-01_default) + i = 0 + i = i + 1 + field => model%get_field_ptr_by_index (i) + call field%init (var_str ("D_QUARK"), 1) + call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2) + call field%set (name = [var_str ("d")], anti = [var_str ("dbar")]) + i = i + 1 + field => model%get_field_ptr_by_index (i) + call field%init (var_str ("U_QUARK"), 2) + call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2) + call field%set (name = [var_str ("u")], anti = [var_str ("ubar")]) + i = i + 1 + field => model%get_field_ptr_by_index (i) + call field%init (var_str ("S_QUARK"), 3) + call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2) + call field%set (mass_data=model%get_par_real_ptr (7)) + call field%set (name = [var_str ("s")], anti = [var_str ("sbar")]) + i = i + 1 + field => model%get_field_ptr_by_index (i) + call field%init (var_str ("C_QUARK"), 4) + call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2) + call field%set (mass_data=model%get_par_real_ptr (8)) + call field%set (name = [var_str ("c")], anti = [var_str ("cbar")]) + i = i + 1 + field => model%get_field_ptr_by_index (i) + call field%init (var_str ("B_QUARK"), 5) + call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2) + call field%set (mass_data=model%get_par_real_ptr (9)) + call field%set (name = [var_str ("b")], anti = [var_str ("bbar")]) + i = i + 1 + field => model%get_field_ptr_by_index (i) + call field%init (var_str ("T_QUARK"), 6) + call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2) + call field%set (mass_data=model%get_par_real_ptr (10)) + call field%set (width_data=model%get_par_real_ptr (11)) + call field%set (name = [var_str ("t")], anti = [var_str ("tbar")]) + i = i + 1 + field => model%get_field_ptr_by_index (i) + call field%init (var_str ("E_LEPTON"), 11) + call field%set (spin_type=2) + call field%set (mass_data=model%get_par_real_ptr (4)) + call field%set (name = [var_str ("e-")], anti = [var_str ("e+")]) + i = i + 1 + field => model%get_field_ptr_by_index (i) + call field%init (var_str ("E_NEUTRINO"), 12) + call field%set (spin_type=2, is_left_handed=.true.) + call field%set (name = [var_str ("nue")], anti = [var_str ("nuebar")]) + i = i + 1 + field => model%get_field_ptr_by_index (i) + call field%init (var_str ("MU_LEPTON"), 13) + call field%set (spin_type=2) + call field%set (mass_data=model%get_par_real_ptr (5)) + call field%set (name = [var_str ("mu-")], anti = [var_str ("mu+")]) + i = i + 1 + field => model%get_field_ptr_by_index (i) + call field%init (var_str ("MU_NEUTRINO"), 14) + call field%set (spin_type=2, is_left_handed=.true.) + call field%set (name = [var_str ("numu")], anti = [var_str ("numubar")]) + i = i + 1 + field => model%get_field_ptr_by_index (i) + call field%init (var_str ("TAU_LEPTON"), 15) + call field%set (spin_type=2) + call field%set (mass_data=model%get_par_real_ptr (6)) + call field%set (name = [var_str ("tau-")], anti = [var_str ("tau+")]) + i = i + 1 + field => model%get_field_ptr_by_index (i) + call field%init (var_str ("TAU_NEUTRINO"), 16) + call field%set (spin_type=2, is_left_handed=.true.) + call field%set (name = [var_str ("nutau")], anti = [var_str ("nutaubar")]) + i = i + 1 + field => model%get_field_ptr_by_index (i) + call field%init (var_str ("GLUON"), 21) + call field%set (spin_type=3, color_type=8) + call field%set (name = [var_str ("gl")]) + i = i + 1 + field => model%get_field_ptr_by_index (i) + call field%init (var_str ("PHOTON"), 22) + call field%set (spin_type=3) + call field%set (name = [var_str ("A")]) + i = i + 1 + field => model%get_field_ptr_by_index (i) + call field%init (var_str ("Z_BOSON"), 23) + call field%set (spin_type=3) + call field%set (mass_data=model%get_par_real_ptr (1)) + call field%set (width_data=model%get_par_real_ptr (12)) + call field%set (name = [var_str ("Z")]) + i = i + 1 + field => model%get_field_ptr_by_index (i) + call field%init (var_str ("W_BOSON"), 24) + call field%set (spin_type=3) + call field%set (mass_data=model%get_par_real_ptr (2)) + call field%set (width_data=model%get_par_real_ptr (13)) + call field%set (name = [var_str ("W+")], anti = [var_str ("W-")]) + i = i + 1 + field => model%get_field_ptr_by_index (i) + call field%init (var_str ("HIGGS"), 25) + call field%set (spin_type=1) + call field%set (mass_data=model%get_par_real_ptr (3)) + call field%set (width_data=model%get_par_real_ptr (14)) + call field%set (name = [var_str ("H")]) + i = i + 1 + field => model%get_field_ptr_by_index (i) + call field%init (var_str ("PROTON"), 2212) + call field%set (spin_type=2) + call field%set (name = [var_str ("p")], anti = [var_str ("pbar")]) +! call field%set (mass_data=model%get_par_real_ptr (12)) + i = i + 1 + field => model%get_field_ptr_by_index (i) + call field%init (var_str ("HADRON_REMNANT_SINGLET"), 91) + call field%set (color_type=1) + call field%set (name = [var_str ("hr1")]) + i = i + 1 + field => model%get_field_ptr_by_index (i) + call field%init (var_str ("HADRON_REMNANT_TRIPLET"), 92) + call field%set (color_type=3) + call field%set (name = [var_str ("hr3")], anti = [var_str ("hr3bar")]) + i = i + 1 + field => model%get_field_ptr_by_index (i) + call field%init (var_str ("HADRON_REMNANT_OCTET"), 93) + call field%set (color_type=8) + call field%set (name = [var_str ("hr8")]) + call model%freeze_fields () + i = 0 + i = i + 1 +!!! QED + call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("A")]) + i = i + 1 + call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("A")]) + i = i + 1 + call model%set_vertex (i, [var_str ("sbar"), var_str ("s"), var_str ("A")]) + i = i + 1 + call model%set_vertex (i, [var_str ("cbar"), var_str ("c"), var_str ("A")]) + i = i + 1 + call model%set_vertex (i, [var_str ("bbar"), var_str ("b"), var_str ("A")]) + i = i + 1 + call model%set_vertex (i, [var_str ("tbar"), var_str ("t"), var_str ("A")]) + i = i + 1 +!!! + call model%set_vertex (i, [var_str ("e+"), var_str ("e-"), var_str ("A")]) + i = i + 1 + call model%set_vertex (i, [var_str ("mu+"), var_str ("mu-"), var_str ("A")]) + i = i + 1 + call model%set_vertex (i, [var_str ("tau+"), var_str ("tau-"), var_str ("A")]) + i = i + 1 +!!! QCD + call model%set_vertex (i, [var_str ("gl"), var_str ("gl"), var_str ("gl")]) + i = i + 1 + call model%set_vertex (i, [var_str ("gl"), var_str ("gl"), & + var_str ("gl"), var_str ("gl")]) + i = i + 1 +!!! + call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("gl")]) + i = i + 1 + call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("gl")]) + i = i + 1 + call model%set_vertex (i, [var_str ("sbar"), var_str ("s"), var_str ("gl")]) + i = i + 1 + call model%set_vertex (i, [var_str ("cbar"), var_str ("c"), var_str ("gl")]) + i = i + 1 + call model%set_vertex (i, [var_str ("bbar"), var_str ("b"), var_str ("gl")]) + i = i + 1 + call model%set_vertex (i, [var_str ("tbar"), var_str ("t"), var_str ("gl")]) + i = i + 1 +!!! Neutral currents + call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("Z")]) + i = i + 1 + call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("Z")]) + i = i + 1 + call model%set_vertex (i, [var_str ("sbar"), var_str ("s"), var_str ("Z")]) + i = i + 1 + call model%set_vertex (i, [var_str ("cbar"), var_str ("c"), var_str ("Z")]) + i = i + 1 + call model%set_vertex (i, [var_str ("bbar"), var_str ("b"), var_str ("Z")]) + i = i + 1 + call model%set_vertex (i, [var_str ("tbar"), var_str ("t"), var_str ("Z")]) + i = i + 1 +!!! + call model%set_vertex (i, [var_str ("e+"), var_str ("e-"), var_str ("Z")]) + i = i + 1 + call model%set_vertex (i, [var_str ("mu+"), var_str ("muu-"), var_str ("Z")]) + i = i + 1 + call model%set_vertex (i, [var_str ("tau+"), var_str ("tau-"), var_str ("Z")]) + i = i + 1 + call model%set_vertex (i, [var_str ("nuebar"), var_str ("nue"), var_str ("Z")]) + i = i + 1 + call model%set_vertex (i, [var_str ("numubar"), var_str ("numu"), var_str ("Z")]) + i = i + 1 + call model%set_vertex (i, [var_str ("nutaubar"), var_str ("nutau"), & + var_str ("Z")]) + i = i + 1 +!!! Charged currents + call model%set_vertex (i, [var_str ("ubar"), var_str ("d"), var_str ("W+")]) + i = i + 1 + call model%set_vertex (i, [var_str ("cbar"), var_str ("s"), var_str ("W+")]) + i = i + 1 + call model%set_vertex (i, [var_str ("tbar"), var_str ("b"), var_str ("W+")]) + i = i + 1 + call model%set_vertex (i, [var_str ("dbar"), var_str ("u"), var_str ("W-")]) + i = i + 1 + call model%set_vertex (i, [var_str ("sbar"), var_str ("c"), var_str ("W-")]) + i = i + 1 + call model%set_vertex (i, [var_str ("bbar"), var_str ("t"), var_str ("W-")]) + i = i + 1 +!!! + call model%set_vertex (i, [var_str ("nuebar"), var_str ("e-"), var_str ("W+")]) + i = i + 1 + call model%set_vertex (i, [var_str ("numubar"), var_str ("mu-"), var_str ("W+")]) + i = i + 1 + call model%set_vertex (i, [var_str ("nutaubar"), var_str ("tau-"), var_str ("W+")]) + i = i + 1 + call model%set_vertex (i, [var_str ("e+"), var_str ("nue"), var_str ("W-")]) + i = i + 1 + call model%set_vertex (i, [var_str ("mu+"), var_str ("numu"), var_str ("W-")]) + i = i + 1 + call model%set_vertex (i, [var_str ("tau+"), var_str ("nutau"), var_str ("W-")]) + i = i + 1 +!!! Yukawa +!!! keeping only 3rd generation for the moment + ! call model%set_vertex (i, [var_str ("sbar"), var_str ("s"), var_str ("H")]) + ! i = i + 1 + ! call model%set_vertex (i, [var_str ("cbar"), var_str ("c"), var_str ("H")]) + ! i = i + 1 + call model%set_vertex (i, [var_str ("bbar"), var_str ("b"), var_str ("H")]) + i = i + 1 + call model%set_vertex (i, [var_str ("tbar"), var_str ("t"), var_str ("H")]) + i = i + 1 + ! call model%set_vertex (i, [var_str ("mubar"), var_str ("mu"), var_str ("H")]) + ! i = i + 1 + call model%set_vertex (i, [var_str ("taubar"), var_str ("tau"), var_str ("H")]) + i = i + 1 +!!! Vector-boson self-interactions + call model%set_vertex (i, [var_str ("W+"), var_str ("W-"), var_str ("A")]) + i = i + 1 + call model%set_vertex (i, [var_str ("W+"), var_str ("W-"), var_str ("Z")]) + i = i + 1 +!!! + call model%set_vertex (i, [var_str ("W+"), var_str ("W-"), var_str ("Z"), var_str ("Z")]) + i = i + 1 + call model%set_vertex (i, [var_str ("W+"), var_str ("W+"), var_str ("W-"), var_str ("W-")]) + i = i + 1 + call model%set_vertex (i, [var_str ("W+"), var_str ("W-"), var_str ("Z"), var_str ("A")]) + i = i + 1 + call model%set_vertex (i, [var_str ("W+"), var_str ("W-"), var_str ("A"), var_str ("A")]) + i = i + 1 +!!! Higgs - vector boson + ! call model%set_vertex (i, [var_str ("H"), var_str ("Z"), var_str ("A")]) + ! i = i + 1 + ! call model%set_vertex (i, [var_str ("H"), var_str ("A"), var_str ("A")]) + ! i = i + 1 + ! call model%set_vertex (i, [var_str ("H"), var_str ("gl"), var_str ("gl")]) + ! i = i + 1 +!!! + call model%set_vertex (i, [var_str ("H"), var_str ("W+"), var_str ("W-")]) + i = i + 1 + call model%set_vertex (i, [var_str ("H"), var_str ("Z"), var_str ("Z")]) + i = i + 1 + call model%set_vertex (i, [var_str ("H"), var_str ("H"), var_str ("W+"), var_str ("W-")]) + i = i + 1 + call model%set_vertex (i, [var_str ("H"), var_str ("H"), var_str ("Z"), var_str ("Z")]) + i = i + 1 +!!! Higgs self-interactions + call model%set_vertex (i, [var_str ("H"), var_str ("H"), var_str ("H")]) + i = i + 1 + call model%set_vertex (i, [var_str ("H"), var_str ("H"), var_str ("H"), var_str ("H")]) + i = i + 1 + call model%freeze_vertices () + end subroutine init_sm_full_test -@ %def phs_point_set_set_momenta_phs_point -@ -<>= - procedure :: get_n_particles => phs_point_set_get_n_particles -<>= - function phs_point_set_get_n_particles (phs_point_set, i) result (n_particles) - integer :: n_particles - class(phs_point_set_t), intent(in) :: phs_point_set - integer, intent(in), optional :: i - integer :: j - j = 1; if (present (i)) j = i - n_particles = size (phs_point_set%phs_point(j)) - end function phs_point_set_get_n_particles +@ %def init_sm_full_test +@ Initialize a [[part_prop]] object by passing a [[particle_label]], +which is simply the particle name. [[part_prop]] should be part of the +[[particle]] array of [[feyngraph_set]]. We use the [[model]] of +[[feyngraph_set]] to obtain the relevant data of the particle which is +needed to find [[phase_space]] parametrizations. When a [[part_prop]] +is initialized, we add and initialize also the corresponding anti- +particle [[part_prop]] if it is not yet in the array. +<>= + procedure :: init => part_prop_init +<>= + recursive module subroutine part_prop_init & + (part_prop, feyngraph_set, particle_label) + class(part_prop_t), intent(out), target :: part_prop + type(feyngraph_set_t), intent(inout) :: feyngraph_set + character(len=*), intent(in) :: particle_label + end subroutine part_prop_init +<>= + recursive module subroutine part_prop_init & + (part_prop, feyngraph_set, particle_label) + class(part_prop_t), intent(out), target :: part_prop + type(feyngraph_set_t), intent(inout) :: feyngraph_set + character(len=*), intent(in) :: particle_label + type(flavor_t) :: flv, anti + type(string_t) :: name + integer :: i + name = particle_label + call flv%init (name, feyngraph_set%model) + part_prop%particle_label = particle_label + part_prop%pdg = flv%get_pdg () + part_prop%mass = flv%get_mass () + part_prop%width = flv%get_width() + part_prop%spin_type = flv%get_spin_type () + part_prop%is_vector = flv%get_spin_type () == VECTOR + part_prop%empty = .false. + part_prop%tex_name = flv%get_tex_name () + anti = flv%anti () + if (flv%get_pdg() == anti%get_pdg()) then + select type (part_prop) + type is (part_prop_t) + part_prop%anti => part_prop + end select + else + do i=1, size (feyngraph_set%particle) + if (feyngraph_set%particle(i)%pdg == (- part_prop%pdg)) then + part_prop%anti => feyngraph_set%particle(i) + exit + else if (feyngraph_set%particle(i)%empty) then + part_prop%anti => feyngraph_set%particle(i) + call feyngraph_set%particle(i)%init & + (feyngraph_set, char(anti%get_name())) + exit + end if + end do + end if + end subroutine part_prop_init -@ %def phs_point_set_get_n_particles -@ -<>= - procedure :: get_n_phs => phs_point_set_get_n_phs -<>= - function phs_point_set_get_n_phs (phs_point_set) result (n_phs) - integer :: n_phs - class(phs_point_set_t), intent(in) :: phs_point_set - n_phs = size (phs_point_set%phs_point) - end function phs_point_set_get_n_phs +@ %def part_prop_init +@ This subroutine assigns to a node the particle properties. Since these +properties do not change and are simply read from the model file, we +use pointers to the elements of the [[particle]] array of the +[[feyngraph_set]]. If there is no corresponding array element, we +have to initialize the first empty element of the array. +<>= + integer, parameter :: PRT_ARRAY_SIZE = 200 +<>= + procedure :: assign_particle_properties => f_node_assign_particle_properties +<>= + module subroutine f_node_assign_particle_properties (node, feyngraph_set) + class(f_node_t), intent(inout ) :: node + type(feyngraph_set_t), intent(inout) :: feyngraph_set + end subroutine f_node_assign_particle_properties +<>= + module subroutine f_node_assign_particle_properties (node, feyngraph_set) + class(f_node_t), intent(inout ) :: node + type(feyngraph_set_t), intent(inout) :: feyngraph_set + character(len=LABEL_LEN) :: particle_label + integer :: i + particle_label = node%particle_label(1:index (node%particle_label, '[')-1) + if (.not. associated (feyngraph_set%particle)) then + allocate (feyngraph_set%particle (PRT_ARRAY_SIZE)) + end if + do i = 1, size (feyngraph_set%particle) + if (particle_label == feyngraph_set%particle(i)%particle_label) then + node%particle => feyngraph_set%particle(i) + exit + else if (feyngraph_set%particle(i)%empty) then + call feyngraph_set%particle(i)%init (feyngraph_set, particle_label) + node%particle => feyngraph_set%particle(i) + exit + end if + end do + !!! Since the O'Mega output uses the anti-particles instead of the + !!! particles specified in the process definition, we revert this + !!! here. An exception is the first particle in the parsable DAG output + node%particle => node%particle%anti + end subroutine f_node_assign_particle_properties -@ %def phs_point_set_get_n_phs -@ -<>= - procedure :: get_invariant_mass => phs_point_set_get_invariant_mass -<>= - function phs_point_set_get_invariant_mass (phs_point_set, i_phs, i_part) result (m2) - real(default) :: m2 - class(phs_point_set_t), intent(in) :: phs_point_set - integer, intent(in) :: i_phs - integer, intent(in), dimension(:) :: i_part - m2 = phs_point_set%phs_point(i_phs)%get_msq (i_part) - end function phs_point_set_get_invariant_mass +@ %def f_node_assign_particle_properties +@ From the output of a Feynman diagram (in the non-factorized output) +we need to find out how many daughter nodes would be required to +reconstruct it correctly, to make sure that we keep +only those [[feyngraphs]] which are constructed solely on the basis of +the 3-vertices which are provided by the model. The number of daughter +particles can easily be determined from the syntax of O'Mega's output: +The particle which appears before the colon ':' is the mother particle. +The particles or subtrees (i.e. whole parentheses) follow after the +colon and are separated by commas. +<>= + function get_n_daughters (subtree_string, pos_first_colon) & + result (n_daughters) + character(len=*), intent(in) :: subtree_string + integer, intent(in) :: pos_first_colon + integer :: n_daughters + integer :: n_open_par + integer :: i + n_open_par = 1 + n_daughters = 0 + if (len_trim(subtree_string) > 0) then + if (pos_first_colon > 0) then + do i=pos_first_colon, len_trim(subtree_string) + if (subtree_string(i:i) == ',') then + if (n_open_par == 1) n_daughters = n_daughters + 1 + else if (subtree_string(i:i) == '(') then + n_open_par = n_open_par + 1 + else if (subtree_string(i:i) == ')') then + n_open_par = n_open_par - 1 + end if + end do + if (n_open_par == 0) then + n_daughters = n_daughters + 1 + end if + end if + end if + end function get_n_daughters -@ %def phs_point_set_get_invariant_mass +@ %def get_n_daughters @ -<>= - procedure :: write_phs_point => phs_point_set_write_phs_point -<>= - subroutine phs_point_set_write_phs_point (phs_point_set, i_phs, unit, show_mass, & - testflag, check_conservation, ultra, n_in) - class(phs_point_set_t), intent(in) :: phs_point_set - integer, intent(in) :: i_phs - integer, intent(in), optional :: unit - logical, intent(in), optional :: show_mass - logical, intent(in), optional :: testflag, ultra - logical, intent(in), optional :: check_conservation - integer, intent(in), optional :: n_in - call phs_point_set%phs_point(i_phs)%write (unit, show_mass, testflag, & - check_conservation, ultra, n_in) - end subroutine phs_point_set_write_phs_point +\subsection{Reconstruction of trees} +The reconstruction of a tree or subtree with the non-factorized input can +be done recursively, i.e. we first find the root of the tree in the +string and create an [[f_node]]. Then we look for daughters, which in the +string appear either as single particles or subtrees (which are of the +same form as the tree which we want to reconstruct. Therefore the +subroutine can simply be called again and again until there are no more +daughter nodes to create. When we meet a vertex which requires more than +two daughter particles, we stop the recursion and disable the node using +its [[keep]] variable. Whenever a daughter node is not kept, we do not +keep the mother node as well. +<>= + recursive subroutine node_construct_subtree_rec (feyngraph_set, & + feyngraph, subtree_string, mother_node) + type(feyngraph_set_t), intent(inout) :: feyngraph_set + type(feyngraph_t), intent(inout) :: feyngraph + character(len=*), intent(in) :: subtree_string + type(f_node_t), pointer, intent(inout) :: mother_node + integer :: n_daughters + integer :: pos_first_colon + integer :: current_daughter + integer :: pos_subtree_begin, pos_subtree_end + integer :: i + integer :: n_open_par + if (.not. associated (mother_node)) then + call feyngraph_set%f_node_list%add_entry (subtree_string, mother_node, .true.) + current_daughter = 1 + n_open_par = 1 + pos_first_colon = index (subtree_string, ':') + n_daughters = get_n_daughters (subtree_string, pos_first_colon) + if (pos_first_colon == 0) then + mother_node%particle_label = subtree_string + else + mother_node%particle_label = subtree_string(2:pos_first_colon-1) + end if + if (.not. associated (mother_node%particle)) then + call mother_node%assign_particle_properties (feyngraph_set) + end if + if (n_daughters /= 2 .and. n_daughters /= 0) then + mother_node%keep = .false. + feyngraph%keep = .false. + return + end if + pos_subtree_begin = pos_first_colon + 1 + do i = pos_first_colon + 1, len(trim(subtree_string)) + if (current_daughter == 2) then + pos_subtree_end = len(trim(subtree_string)) - 1 + call node_construct_subtree_rec (feyngraph_set, feyngraph, & + subtree_string(pos_subtree_begin:pos_subtree_end), & + mother_node%daughter2) + exit + else if (subtree_string(i:i) == ',') then + if (n_open_par == 1) then + pos_subtree_end = i - 1 + call node_construct_subtree_rec (feyngraph_set, feyngraph, & + subtree_string(pos_subtree_begin:pos_subtree_end), & + mother_node%daughter1) + current_daughter = 2 + pos_subtree_begin = i + 1 + end if + else if (subtree_string(i:i) == '(') then + n_open_par = n_open_par + 1 + else if (subtree_string(i:i) == ')') then + n_open_par = n_open_par - 1 + end if + end do + end if + if (associated (mother_node%daughter1)) then + if (.not. mother_node%daughter1%keep) then + mother_node%keep = .false. + end if + end if + if (associated (mother_node%daughter2)) then + if (.not. mother_node%daughter2%keep) then + mother_node%keep = .false. + end if + end if + if (associated (mother_node%daughter1) .and. & + associated (mother_node%daughter2)) then + mother_node%n_subtree_nodes = & + mother_node%daughter1%n_subtree_nodes & + + mother_node%daughter2%n_subtree_nodes + 1 + end if + if (.not. mother_node%keep) then + feyngraph%keep = .false. + end if + end subroutine node_construct_subtree_rec -@ %def phs_point_set_write_phs_point -@ -<>= - procedure :: final => phs_point_set_final -<>= - subroutine phs_point_set_final (phs_point_set) - class(phs_point_set_t), intent(inout) :: phs_point_set +@ %def node_construct_subtree_rec +@ When the non-factorized version of the O'Mega output is used, the +[[feyngraph]] is reconstructed from the contents of its [[string_t]] +variable [[omega_feyngraph_output]]. This can be used for the recursive +reconstruction of the tree of [[k_nodes]] with +[[node_construct_subtree_rec]]. +<>= + subroutine feyngraph_construct (feyngraph_set, feyngraph) + type(feyngraph_set_t), intent(inout) :: feyngraph_set + type(feyngraph_t), pointer, intent(inout) :: feyngraph + call node_construct_subtree_rec (feyngraph_set, feyngraph, & + char(feyngraph%omega_feyngraph_output), feyngraph%root) + feyngraph%n_nodes = feyngraph%root%n_subtree_nodes + end subroutine feyngraph_construct + +@ %def feyngraph_construct +@ We introduce another node type, which is called [[dag_node_t]] and +is used to reproduce the dag structure which is represented by the input. +The [[dag_nodes]] can have several combinations of daughters 1 and 2. +The [[dag]] type contains an array of [[dag_nodes]] and is only used +for the reconstruction of [[feyngraphs]] which are factorized as well, but +in the other direction as the original output. This means in particular +that the outgoing particles in the output file (which there can appear +many times) exist only once as [[f_nodes]]. To represent combinations of +daughters and alternatives (options), we further use the types +[[dag_options_t]] and [[dag_combination_t]]. The [[dag_nodes]], +[[dag_options]] and [[dag_combinations]] correspond to a substring of +the string which has been read from file (and transformed into an object +of type [[dag_string_t]], which is simply another compact representation +of this string), or a modified version of this substring. The aim is to +create only one object for a given substring, even if it appears several +times in the original string and then create trees of [[f_nodes]], which +build up the [[feyngraph]], such that as many [[f_nodes]] as possible can be reused. +An outgoing particle (always interpreting the input as a decay) is +called a [[leaf]] in the context of a [[dag]]. +<>= + type :: dag_node_t + integer :: string_len + type(dag_string_t) :: string + logical :: leaf = .false. + type(f_node_ptr_t), dimension (:), allocatable :: f_node + integer :: subtree_size = 0 + contains + <> + end type dag_node_t + +@ %def dag_node_t +<>= + procedure :: final => dag_node_final +<>= + module subroutine dag_node_final (dag_node) + class(dag_node_t), intent(inout) :: dag_node + end subroutine dag_node_final +<>= + module subroutine dag_node_final (dag_node) + class(dag_node_t), intent(inout) :: dag_node integer :: i - deallocate (phs_point_set%phs_point) - phs_point_set%initialized = .false. - end subroutine phs_point_set_final + call dag_node%string%final () + if (allocated (dag_node%f_node)) then + do i=1, size (dag_node%f_node) + if (associated (dag_node%f_node(i)%node)) then + call dag_node%f_node(i)%node%final () + deallocate (dag_node%f_node(i)%node) + end if + end do + deallocate (dag_node%f_node) + end if + end subroutine dag_node_final -@ %def phs_point_set_final -@ -<>= - public :: real_jacobian_t -<>= - type :: real_jacobian_t - real(default), dimension(4) :: jac = 1._default - end type real_jacobian_t +@ %def dag_node_final +@ Whenever there are more than one possible subtrees (represented by +a [[dag_node]]) or combinations of subtrees to daughters (represented +by [[dag_combination_t]]), we use the type [[dag_options_t]]. In the +syntax of the factorized output, options are listed within curly +braces, separated by horizontal bars. +<>= + type :: dag_options_t + integer :: string_len + type(dag_string_t) :: string + type(f_node_ptr_t), dimension (:), allocatable :: f_node_ptr1 + type(f_node_ptr_t), dimension (:), allocatable :: f_node_ptr2 + contains + <> + end type dag_options_t -@ %def real_jacobian_t -@ -<>= - public :: real_kinematics_t -<>= - type :: real_kinematics_t - logical :: supply_xi_max = .true. - real(default) :: xi_tilde - real(default) :: phi - real(default), dimension(:), allocatable :: xi_max, y - real(default) :: xi_mismatch, y_mismatch - type(real_jacobian_t), dimension(:), allocatable :: jac - real(default) :: jac_mismatch - type(phs_point_set_t) :: p_born_cms - type(phs_point_set_t) :: p_born_lab - type(phs_point_set_t) :: p_real_cms - type(phs_point_set_t) :: p_real_lab - type(phs_point_set_t) :: p_born_onshell - type(phs_point_set_t), dimension(2) :: p_real_onshell - integer, dimension(:), allocatable :: alr_to_i_phs - real(default), dimension(3) :: x_rad - real(default), dimension(:), allocatable :: jac_rand - real(default), dimension(:), allocatable :: y_soft - real(default) :: cms_energy2 - type(vector4_t), dimension(:), allocatable :: xi_ref_momenta - contains - <> - end type real_kinematics_t +@ %def dag_node_options_t +<>= + procedure :: final => dag_options_final +<>= + module subroutine dag_options_final (dag_options) + class(dag_options_t), intent(inout) :: dag_options + end subroutine dag_options_final +<>= + module subroutine dag_options_final (dag_options) + class(dag_options_t), intent(inout) :: dag_options + integer :: i + call dag_options%string%final () + if (allocated (dag_options%f_node_ptr1)) then + do i=1, size (dag_options%f_node_ptr1) + dag_options%f_node_ptr1(i)%node => null () + end do + deallocate (dag_options%f_node_ptr1) + end if + if (allocated (dag_options%f_node_ptr2)) then + do i=1, size (dag_options%f_node_ptr2) + dag_options%f_node_ptr2(i)%node => null () + end do + deallocate (dag_options%f_node_ptr2) + end if + end subroutine dag_options_final -@ %def real_kinematics_t -@ -<>= - procedure :: init => real_kinematics_init -<>= - subroutine real_kinematics_init (r, n_tot, n_phs, n_alr, n_contr) - class(real_kinematics_t), intent(inout) :: r - integer, intent(in) :: n_tot, n_phs, n_alr, n_contr - allocate (r%xi_max (n_phs)) - allocate (r%y (n_phs)) - allocate (r%y_soft (n_phs)) - call r%p_born_cms%init (n_tot - 1, 1) - call r%p_born_lab%init (n_tot - 1, 1) - call r%p_real_cms%init (n_tot, n_phs) - call r%p_real_lab%init (n_tot, n_phs) - allocate (r%jac (n_phs), r%jac_rand (n_phs)) - allocate (r%alr_to_i_phs (n_alr)) - allocate (r%xi_ref_momenta (n_contr)) - r%alr_to_i_phs = 0 - r%xi_tilde = zero; r%xi_mismatch = zero - r%xi_max = zero - r%y = zero; r%y_mismatch = zero - r%y_soft = zero - r%phi = zero - r%cms_energy2 = zero - r%xi_ref_momenta = vector4_null - r%jac_mismatch = one - r%jac_rand = one - end subroutine real_kinematics_init +@ %def dag_options_final +@ A pair of two daughters (which can be [[dag_nodes]] or [[dag_options]]) +is represented by the type [[dag_combination_t]]. In the original string, +a [[dag_combination]] appears between parentheses, which contain a comma, +but not a colon. If we find a colon between these parentheses, it is a +a [[dag_node]] instead. +<>= + type :: dag_combination_t + integer :: string_len + type(dag_string_t) :: string + integer, dimension (2) :: combination + type(f_node_ptr_t), dimension (:), allocatable :: f_node_ptr1 + type(f_node_ptr_t), dimension (:), allocatable :: f_node_ptr2 + contains + <> + end type dag_combination_t -@ %def real_kinematics_init -@ -<>= - procedure :: init_onshell => real_kinematics_init_onshell -<>= - subroutine real_kinematics_init_onshell (r, n_tot, n_phs) - class(real_kinematics_t), intent(inout) :: r - integer, intent(in) :: n_tot, n_phs - call r%p_born_onshell%init (n_tot - 1, 1) - call r%p_real_onshell(1)%init (n_tot, n_phs) - call r%p_real_onshell(2)%init (n_tot, n_phs) - end subroutine real_kinematics_init_onshell +@ %def dag_combination_t +<>= + procedure :: final => dag_combination_final +<>= + module subroutine dag_combination_final (dag_combination) + class(dag_combination_t), intent(inout) :: dag_combination + end subroutine dag_combination_final +<>= + module subroutine dag_combination_final (dag_combination) + class(dag_combination_t), intent(inout) :: dag_combination + integer :: i + call dag_combination%string%final () + if (allocated (dag_combination%f_node_ptr1)) then + do i=1, size (dag_combination%f_node_ptr1) + dag_combination%f_node_ptr1(i)%node => null () + end do + deallocate (dag_combination%f_node_ptr1) + end if + if (allocated (dag_combination%f_node_ptr2)) then + do i=1, size (dag_combination%f_node_ptr2) + dag_combination%f_node_ptr2(i)%node => null () + end do + deallocate (dag_combination%f_node_ptr2) + end if + end subroutine dag_combination_final -@ %def real_kinematics_init_onshell -@ -<>= - procedure :: write => real_kinematics_write -<>= - subroutine real_kinematics_write (r, unit) - class(real_kinematics_t), intent(in) :: r - integer, intent(in), optional :: unit - integer :: u, i - u = given_output_unit (unit); if (u < 0) return - write (u,"(A)") "Real kinematics: " - write (u,"(A," // FMT_17 // ",1X)") "xi_tilde: ", r%xi_tilde - write (u,"(A," // FMT_17 // ",1X)") "phi: ", r%phi - do i = 1, size (r%xi_max) - write (u,"(A,I1,1X)") "i_phs: ", i - write (u,"(A," // FMT_17 // ",1X)") "xi_max: ", r%xi_max(i) - write (u,"(A," // FMT_17 // ",1X)") "y: ", r%y(i) - write (u,"(A," // FMT_17 // ",1X)") "jac_rand: ", r%jac_rand(i) - write (u,"(A," // FMT_17 // ",1X)") "y_soft: ", r%y_soft(i) +@ %def dag_combination_final +@ Here is the type representing the DAG, i.e. it holds arrays of the +[[dag_nodes]], [[dag_options]] and [[dag_combinations]]. The root node +of the [[dag]] is the last filled element of the [[node]] array. +<>= + type :: dag_t + type(dag_string_t) :: string + type(dag_node_t), dimension (:), allocatable :: node + type(dag_options_t), dimension (:), allocatable :: options + type(dag_combination_t), dimension (:), allocatable :: combination + integer :: n_nodes = 0 + integer :: n_options = 0 + integer :: n_combinations = 0 + contains + <> + end type dag_t + +@ %def dag_t +<>= + procedure :: final => dag_final +<>= + module subroutine dag_final (dag) + class(dag_t), intent(inout) :: dag + end subroutine dag_final +<>= + module subroutine dag_final (dag) + class(dag_t), intent(inout) :: dag + integer :: i + call dag%string%final () + if (allocated (dag%node)) then + do i=1, size (dag%node) + call dag%node(i)%final () + end do + deallocate (dag%node) + end if + if (allocated (dag%options)) then + do i=1, size (dag%options) + call dag%options(i)%final () + end do + deallocate (dag%options) + end if + if (allocated (dag%combination)) then + do i=1, size (dag%combination) + call dag%combination(i)%final () + end do + deallocate (dag%combination) + end if + end subroutine dag_final + +@ %def dag_final +@ We construct the DAG from the given [[dag_string]] which is modified +several times so that in the end the remaining string corresponds to a +simple [[dag_node]], the root of the factorized tree. This means that +we first identify the leaves, i.e. outgoing particles. Then we identify +[[dag_nodes]], [[dag_combinations]] and [[options]] until the number of +these objects does not change any more. Identifying means that we add +a corresponding object to the array (if not yet present), which can be +identified with the corresponding substring, and replace the substring +in the original [[dag_string]] by a [[dag_token]] of the corresponding +type (in the char output of this token, this corresponds to a place +holder like e.g. '' which in this particular case corresponds to +an option and can be found at the position 23 in the array). The +character output of the substrings turns out to be very useful for +debugging. +<>= + procedure :: construct => dag_construct +<>= + module subroutine dag_construct (dag, feyngraph_set) + class(dag_t), intent(inout) :: dag + type(feyngraph_set_t), intent(inout) :: feyngraph_set + end subroutine dag_construct +<>= + module subroutine dag_construct (dag, feyngraph_set) + class(dag_t), intent(inout) :: dag + type(feyngraph_set_t), intent(inout) :: feyngraph_set + integer :: n_nodes + integer :: n_options + integer :: n_combinations + logical :: continue_loop + integer :: subtree_size + integer :: i,j + subtree_size = 1 + call dag%get_nodes_and_combinations (leaves = .true.) + do i=1, dag%n_nodes + call dag%node(i)%make_f_nodes (feyngraph_set, dag) end do - write (u, "(A)") "Born Momenta: " - write (u, "(A)") "CMS: " - call r%p_born_cms%write (unit = u) - write (u, "(A)") "Lab: " - call r%p_born_lab%write (unit = u) - write (u, "(A)") "Real Momenta: " - write (u, "(A)") "CMS: " - call r%p_real_cms%write (unit = u) - write (u, "(A)") "Lab: " - call r%p_real_lab%write (unit = u) - end subroutine real_kinematics_write + continue_loop = .true. + subtree_size = subtree_size + 2 + do while (continue_loop) + n_nodes = dag%n_nodes + n_options = dag%n_options + n_combinations = dag%n_combinations + call dag%get_nodes_and_combinations (leaves = .false.) + if (n_nodes /= dag%n_nodes) then + dag%node(n_nodes+1:dag%n_nodes)%subtree_size = subtree_size + do i = n_nodes+1, dag%n_nodes + call dag%node(i)%make_f_nodes (feyngraph_set, dag) + end do + subtree_size = subtree_size + 2 + end if + if (n_combinations /= dag%n_combinations) then + !$OMP PARALLEL DO + do i = n_combinations+1, dag%n_combinations + call dag%combination(i)%make_f_nodes (feyngraph_set, dag) + end do + !$OMP END PARALLEL DO + end if + call dag%get_options () + if (n_options /= dag%n_options) then + !$OMP PARALLEL DO + do i = n_options+1, dag%n_options + call dag%options(i)%make_f_nodes (feyngraph_set, dag) + end do + !$OMP END PARALLEL DO + end if + if (n_nodes == dag%n_nodes .and. n_options == dag%n_options & + .and. n_combinations == dag%n_combinations) then + continue_loop = .false. + end if + end do +!!! add root node to dag + call dag%add_node (dag%string%t, leaf = .false.) + dag%node(dag%n_nodes)%subtree_size = subtree_size + call dag%node(dag%n_nodes)%make_f_nodes (feyngraph_set, dag) + if (debug2_active (D_PHASESPACE)) then + call dag%write (output_unit) + end if +!!! set indices for all f_nodes + do i=1, dag%n_nodes + if (allocated (dag%node(i)%f_node)) then + do j=1, size (dag%node(i)%f_node) + if (associated (dag%node(i)%f_node(j)%node)) & + call dag%node(i)%f_node(j)%node%set_index () + end do + end if + end do + end subroutine dag_construct -@ %def real_kinematics_write -@ The boost to the center-of-mass system only has a reasonable meaning -above the threshold. Below the threshold, we do not apply boost at all, so -that the top quarks stay in the rest frame. However, with top quarks exactly -at rest, problems arise in the matrix elements (e.g. in the computation -of angles). Therefore, we apply a boost which is not exactly 1, but has a -tiny value differing from that. -<>= - public :: get_boost_for_threshold_projection -<>= - function get_boost_for_threshold_projection (p, sqrts, mtop) result (L) - type(lorentz_transformation_t) :: L - type(vector4_t), intent(in), dimension(:) :: p - real(default), intent(in) :: sqrts, mtop - type(vector4_t) :: p_tmp - type(vector3_t) :: dir - real(default) :: scale_factor, arg - p_tmp = p(THR_POS_WP) + p(THR_POS_B) - arg = sqrts**2 - four * mtop**2 - if (arg > zero) then - scale_factor = sqrt (arg) / two +@ %def dag_construct +@ Identify [[dag_nodes]] and [[dag_combinations]]. Leaves are simply +nodes (i.e. of type [[NODE_TK]]) where only one bit in the bincode is +set. The [[dag_nodes]] and [[dag_combinations]] have in common that they +are surrounded by parentheses. There is however a way to distinguish +between them because the corresponding substring contains a colon (or +[[dag_token]] with type [[COLON_TK]]) if it is a [[dag_node]]. Otherwise +it is a [[dag_combination]]. The string of the [[dag_node]] or +[[dag_combination]] should not contain curly braces, because these +correspond to [[dag_options]] and should be identified before. +<>= + procedure :: get_nodes_and_combinations => dag_get_nodes_and_combinations +<>= + module subroutine dag_get_nodes_and_combinations (dag, leaves) + class(dag_t), intent(inout) :: dag + logical, intent(in) :: leaves + end subroutine dag_get_nodes_and_combinations +<>= + module subroutine dag_get_nodes_and_combinations (dag, leaves) + class(dag_t), intent(inout) :: dag + logical, intent(in) :: leaves + type(dag_string_t) :: new_string + integer :: i, j, k + integer :: i_node + integer :: new_size + integer :: first_colon + logical :: combination + !!! Create nodes also for external particles, except for the incoming one + !!! which appears as the root of the tree. These can easily be identified + !!! by their bincodes, since they should contain only one bit which is set. + if (leaves) then + first_colon = & + minloc (dag%string%t%type, 1, dag%string%t%type == COLON_TK) + do i = first_colon + 1, size (dag%string%t) + if (dag%string%t(i)%type == NODE_TK) then + if (popcnt(dag%string%t(i)%bincode) == 1) then + call dag%add_node (dag%string%t(i:i), .true., i_node) + call dag%string%t(i)%init_dag_object_token (DAG_NODE_TK, i_node) + end if + end if + end do + call dag%string%update_char_len () else - scale_factor = tiny_07*1000 + !!! Create a node or combination for every closed pair of parentheses + !!! which do not contain any other parentheses or curly braces. + !!! A node (not outgoing) contains a colon. This is not the case + !!! for combinations, which we use as the criteria to distinguish + !!! between both. + allocate (new_string%t (size (dag%string%t))) + i = 1 + new_size = 0 + do while (i <= size(dag%string%t)) + if (dag%string%t(i)%type == OPEN_PAR_TK) then + combination = .true. + do j = i+1, size (dag%string%t) + select case (dag%string%t(j)%type) + case (CLOSED_PAR_TK) + new_size = new_size + 1 + if (combination) then + call dag%add_combination (dag%string%t(i:j), i_node) + call new_string%t(new_size)%init_dag_object_token & + (DAG_COMBINATION_TK, i_node) + else + call dag%add_node (dag%string%t(i:j), leaves, i_node) + call new_string%t(new_size)%init_dag_object_token & + (DAG_NODE_TK, i_node) + end if + i = j + 1 + exit + case (OPEN_PAR_TK, OPEN_CURLY_TK, CLOSED_CURLY_TK) + new_size = new_size + 1 + new_string%t(new_size) = dag%string%t(i) + i = i + 1 + exit + case (COLON_TK) + combination = .false. + end select + end do + else + new_size = new_size + 1 + new_string%t(new_size) = dag%string%t(i) + i = i + 1 + end if + end do + dag%string = new_string%t(:new_size) + call dag%string%update_char_len () end if - dir = scale_factor * create_unit_vector (p_tmp) - p_tmp = [sqrts / two, dir%p] - L = boost (p_tmp, mtop) - end function get_boost_for_threshold_projection - -@ %def get_boost_for_threshold_projection -@ This routine recomputes the value of $\phi$ used to generate the real phase space. -<>= - function get_generation_phi (p_born, p_real, emitter, i_gluon) result (phi) - real(default) :: phi - type(vector4_t), intent(in), dimension(:) :: p_born, p_real - integer, intent(in) :: emitter, i_gluon - type(vector4_t) :: p1, p2, pp - type(lorentz_transformation_t) :: rot_to_gluon, rot_to_z - type(vector3_t) :: dir, z - real(default) :: cpsi - pp = p_real(emitter) + p_real(i_gluon) - cpsi = (space_part_norm (pp)**2 - space_part_norm (p_real(emitter))**2 & - + space_part_norm (p_real(i_gluon))**2) / & - (two * space_part_norm (pp) * space_part_norm (p_real(i_gluon))) - dir = create_orthogonal (space_part (p_born(emitter))) - rot_to_gluon = rotation (cpsi, sqrt (one - cpsi**2), dir) - pp = rot_to_gluon * p_born(emitter) - z%p = [0, 0, 1] - rot_to_z = rotation_to_2nd & - (space_part (p_born(emitter)) / space_part_norm (p_born(emitter)), z) - p1 = rot_to_z * pp / space_part_norm (pp) - p2 = rot_to_z * p_real(i_gluon) - phi = azimuthal_distance (p1, p2) - if (phi < zero) phi = twopi - abs(phi) - end function get_generation_phi + end subroutine dag_get_nodes_and_combinations -@ %def get_generation_phi -@ -<>= - procedure :: apply_threshold_projection_real => real_kinematics_apply_threshold_projection_real -<>= - subroutine real_kinematics_apply_threshold_projection_real (r, i_phs, mtop, L_to_cms, invert) - class(real_kinematics_t), intent(inout) :: r - integer, intent(in) :: i_phs - real(default), intent(in) :: mtop - type(lorentz_transformation_t), intent(in), dimension(:) :: L_to_cms - logical, intent(in) :: invert - integer :: leg, other_leg - type(vector4_t), dimension(:), allocatable :: p_real - type(vector4_t), dimension(:), allocatable :: p_real_onshell - type(vector4_t), dimension(4) :: k_tmp - type(vector4_t), dimension(4) :: k_decay_onshell_real - type(vector4_t), dimension(3) :: k_decay_onshell_born - do leg = 1, 2 - other_leg = 3 - leg - p_real = r%p_real_cms%phs_point(i_phs) - allocate (p_real_onshell (size (p_real))) - p_real_onshell(1:2) = p_real(1:2) - k_tmp(1) = p_real(7) - k_tmp(2) = p_real(ass_quark(leg)) - k_tmp(3) = p_real(ass_boson(leg)) - k_tmp(4) = [mtop, zero, zero, zero] - call generate_on_shell_decay_threshold (k_tmp(1:3), & - k_tmp(4), k_decay_onshell_real (2:4)) - k_decay_onshell_real (1) = k_tmp(4) - k_tmp(1) = p_real(ass_quark(other_leg)) - k_tmp(2) = p_real(ass_boson(other_leg)) - k_decay_onshell_born = create_two_particle_decay (mtop**2, k_tmp(1), k_tmp(2)) - p_real_onshell(THR_POS_GLUON) = L_to_cms(leg) * k_decay_onshell_real (2) - p_real_onshell(ass_quark(leg)) = L_to_cms(leg) * k_decay_onshell_real(3) - p_real_onshell(ass_boson(leg)) = L_to_cms(leg) * k_decay_onshell_real(4) - p_real_onshell(ass_quark(other_leg)) = L_to_cms(leg) * k_decay_onshell_born (2) - p_real_onshell(ass_boson(other_leg)) = L_to_cms(leg) * k_decay_onshell_born (3) - if (invert) then - call vector4_invert_direction (p_real_onshell (ass_quark(other_leg))) - call vector4_invert_direction (p_real_onshell (ass_boson(other_leg))) +@ %def dag_get_nodes_and_combinations +@ Identify [[dag_options]], i.e. lists of rival nodes or combinations +of nodes. These are identified by the surrounding curly braces. They +should not contain any parentheses any more, because these correspond +either to nodes or to combinations and should be identified before. +<>= + procedure :: get_options => dag_get_options +<>= + module subroutine dag_get_options (dag) + class(dag_t), intent(inout) :: dag + end subroutine dag_get_options +<>= + module subroutine dag_get_options (dag) + class(dag_t), intent(inout) :: dag + type(dag_string_t) :: new_string + integer :: i, j, k + integer :: new_size + integer :: i_options + character(len=10) :: index_char + integer :: index_start, index_end + !!! Create a node or combination for every closed pair of parentheses + !!! which do not contain any other parentheses or curly braces. + !!! A node (not outgoing) contains a colon. This is not the case + !!! for combinations, which we use as the criteria to distinguish + !!! between both. + allocate (new_string%t (size (dag%string%t))) + i = 1 + new_size = 0 + do while (i <= size(dag%string%t)) + if (dag%string%t(i)%type == OPEN_CURLY_TK) then + do j = i+1, size (dag%string%t) + select case (dag%string%t(j)%type) + case (CLOSED_CURLY_TK) + new_size = new_size + 1 + call dag%add_options (dag%string%t(i:j), i_options) + call new_string%t(new_size)%init_dag_object_token (DAG_OPTIONS_TK, i_options) + i = j + 1 + exit + case (OPEN_PAR_TK, CLOSED_PAR_TK, OPEN_CURLY_TK) + new_size = new_size + 1 + new_string%t(new_size) = dag%string%t(i) + i = i + 1 + exit + end select + end do + else + new_size = new_size + 1 + new_string%t(new_size) = dag%string%t(i) + i = i + 1 end if - r%p_real_onshell(leg)%phs_point(i_phs) = p_real_onshell - deallocate (p_real_onshell) end do - end subroutine real_kinematics_apply_threshold_projection_real + dag%string = new_string%t(:new_size) + call dag%string%update_char_len () + end subroutine dag_get_options -@ %def real_kinematics_apply_threshold_projection_real -@ -<>= - public :: threshold_projection_born -<>= - subroutine threshold_projection_born (mtop, L_to_cms, p_in, p_onshell) - real(default), intent(in) :: mtop - type(lorentz_transformation_t), intent(in) :: L_to_cms - type(vector4_t), intent(in), dimension(:) :: p_in - type(vector4_t), intent(out), dimension(:) :: p_onshell - type(vector4_t), dimension(3) :: k_decay_onshell - type(vector4_t) :: p_tmp_1, p_tmp_2 - type(lorentz_transformation_t) :: L_to_cms_inv - p_onshell(1:2) = p_in(1:2) - L_to_cms_inv = inverse (L_to_cms) - p_tmp_1 = L_to_cms_inv * p_in(THR_POS_B) - p_tmp_2 = L_to_cms_inv * p_in(THR_POS_WP) - k_decay_onshell = create_two_particle_decay (mtop**2, & - p_tmp_1, p_tmp_2) - p_onshell([THR_POS_B, THR_POS_WP]) = k_decay_onshell([2, 3]) - p_tmp_1 = L_to_cms * p_in(THR_POS_BBAR) - p_tmp_2 = L_to_cms * p_in(THR_POS_WM) - k_decay_onshell = create_two_particle_decay (mtop**2, & - p_tmp_1, p_tmp_2) - p_onshell([THR_POS_BBAR, THR_POS_WM]) = k_decay_onshell([2, 3]) - p_onshell([THR_POS_WP, THR_POS_B]) = L_to_cms * p_onshell([THR_POS_WP, THR_POS_B]) - p_onshell([THR_POS_WM, THR_POS_BBAR]) = L_to_cms_inv * p_onshell([THR_POS_WM, THR_POS_BBAR]) - end subroutine threshold_projection_born +@ %def dag_get_options +@ Add a [[dag_node]] to the list. The optional argument returns the index +of the node. The node might already exist. In this case we only return +the index. +<>= + procedure :: add_node => dag_add_node +<>= + integer, parameter :: DAG_STACK_SIZE = 1000 +<>= + module subroutine dag_add_node (dag, string, leaf, i_node) + class(dag_t), intent(inout) :: dag + type(dag_token_t), dimension (:), intent(in) :: string + logical, intent(in) :: leaf + integer, intent(out), optional :: i_node + end subroutine dag_add_node +<>= + module subroutine dag_add_node (dag, string, leaf, i_node) + class(dag_t), intent(inout) :: dag + type(dag_token_t), dimension (:), intent(in) :: string + logical, intent(in) :: leaf + integer, intent(out), optional :: i_node + type(dag_node_t), dimension (:), allocatable :: tmp_node + integer :: string_len + integer :: i + string_len = sum (string%char_len) + if (.not. allocated (dag%node)) then + allocate (dag%node (DAG_STACK_SIZE)) + else if (dag%n_nodes == size (dag%node)) then + allocate (tmp_node (dag%n_nodes)) + tmp_node = dag%node + deallocate (dag%node) + allocate (dag%node (dag%n_nodes+DAG_STACK_SIZE)) + dag%node(:dag%n_nodes) = tmp_node + deallocate (tmp_node) + end if + do i = 1, dag%n_nodes + if (dag%node(i)%string_len == string_len) then + if (size (dag%node(i)%string%t) == size (string)) then + if (all(dag%node(i)%string%t == string)) then + if (present (i_node)) i_node = i + return + end if + end if + end if + end do + dag%n_nodes = dag%n_nodes + 1 + dag%node(dag%n_nodes)%string = string + dag%node(dag%n_nodes)%string_len = string_len + if (present (i_node)) i_node = dag%n_nodes + dag%node(dag%n_nodes)%leaf = leaf + end subroutine dag_add_node -@ %def threshold_projection_born -@ This routine computes the bounds of the Dalitz region for massive emitters. -The corresponding derivation can be found in [[1202.0465]], App. A. -It is also used for the POWHEG matching so the routine is public. -The input parameter [[m2]] corresponds to the squared mass of the emitter. -<>= - public :: compute_dalitz_bounds -<>= - pure subroutine compute_dalitz_bounds (q0, m2, mrec2, z1, z2, k0_rec_max) - real(default), intent(in) :: q0, m2, mrec2 - real(default), intent(out) :: z1, z2, k0_rec_max - k0_rec_max = (q0**2 - m2 + mrec2) / (two * q0) - z1 = (k0_rec_max + sqrt(k0_rec_max**2 - mrec2)) / q0 - z2 = (k0_rec_max - sqrt(k0_rec_max**2 - mrec2)) / q0 - end subroutine compute_dalitz_bounds +@ %def dag_add_node +@ A similar subroutine for options. +<>= + procedure :: add_options => dag_add_options +<>= + module subroutine dag_add_options (dag, string, i_options) + class(dag_t), intent(inout) :: dag + type(dag_token_t), dimension (:), intent(in) :: string + integer, intent(out), optional :: i_options + end subroutine dag_add_options +<>= + module subroutine dag_add_options (dag, string, i_options) + class(dag_t), intent(inout) :: dag + type(dag_token_t), dimension (:), intent(in) :: string + integer, intent(out), optional :: i_options + type(dag_options_t), dimension (:), allocatable :: tmp_options + integer :: string_len + integer :: i + string_len = sum (string%char_len) + if (.not. allocated (dag%options)) then + allocate (dag%options (DAG_STACK_SIZE)) + else if (dag%n_options == size (dag%options)) then + allocate (tmp_options (dag%n_options)) + tmp_options = dag%options + deallocate (dag%options) + allocate (dag%options (dag%n_options+DAG_STACK_SIZE)) + dag%options(:dag%n_options) = tmp_options + deallocate (tmp_options) + end if + do i = 1, dag%n_options + if (dag%options(i)%string_len == string_len) then + if (size (dag%options(i)%string%t) == size (string)) then + if (all(dag%options(i)%string%t == string)) then + if (present (i_options)) i_options = i + return + end if + end if + end if + end do + dag%n_options = dag%n_options + 1 + dag%options(dag%n_options)%string = string + dag%options(dag%n_options)%string_len = string_len + if (present (i_options)) i_options = dag%n_options + end subroutine dag_add_options -@ %def compute_dalitz_bounds -@ Compute the [[kt2]] of a given emitter -<>= - procedure :: kt2 => real_kinematics_kt2 -<>= - function real_kinematics_kt2 & - (real_kinematics, i_phs, emitter, kt2_type, xi, y) result (kt2) - real(default) :: kt2 - class(real_kinematics_t), intent(in) :: real_kinematics - integer, intent(in) :: emitter, i_phs, kt2_type - real(default), intent(in), optional :: xi, y - real(default) :: xii, yy - real(default) :: q, E_em, z, z1, z2, m2, mrec2, k0_rec_max - type(vector4_t) :: p_emitter - if (present (y)) then - yy = y - else - yy = real_kinematics%y (i_phs) - end if - if (present (xi)) then - xii = xi +@ %def dag_add_options +@ A similar subroutine for combinations. +<>= + procedure :: add_combination => dag_add_combination +<>= + module subroutine dag_add_combination (dag, string, i_combination) + class(dag_t), intent(inout) :: dag + type(dag_token_t), dimension (:), intent(in) :: string + integer, intent(out), optional :: i_combination + end subroutine dag_add_combination +<>= + module subroutine dag_add_combination (dag, string, i_combination) + class(dag_t), intent(inout) :: dag + type(dag_token_t), dimension (:), intent(in) :: string + integer, intent(out), optional :: i_combination + type(dag_combination_t), dimension (:), allocatable :: tmp_combination + integer :: string_len + integer :: i + string_len = sum (string%char_len) + if (.not. allocated (dag%combination)) then + allocate (dag%combination (DAG_STACK_SIZE)) + else if (dag%n_combinations == size (dag%combination)) then + allocate (tmp_combination (dag%n_combinations)) + tmp_combination = dag%combination + deallocate (dag%combination) + allocate (dag%combination (dag%n_combinations+DAG_STACK_SIZE)) + dag%combination(:dag%n_combinations) = tmp_combination + deallocate (tmp_combination) + end if + do i = 1, dag%n_combinations + if (dag%combination(i)%string_len == string_len) then + if (size (dag%combination(i)%string%t) == size (string)) then + if (all(dag%combination(i)%string%t == string)) then + i_combination = i + return + end if + end if + end if + end do + dag%n_combinations = dag%n_combinations + 1 + dag%combination(dag%n_combinations)%string = string + dag%combination(dag%n_combinations)%string_len = string_len + if (present (i_combination)) i_combination = dag%n_combinations + end subroutine dag_add_combination + +@ %def dag_add_combination +@ For a given [[dag_node]] we want to create all [[f_nodes]]. If the node +is not a leaf, it contains in its string placeholders for options or +combinations. For these objects there are similar subroutines which are +needed here to obtain the sets of daughter nodes. If the [[dag_node]] is +a leaf, it corresponds to an external particle and the token contains the +particle name. +<>= + procedure :: make_f_nodes => dag_node_make_f_nodes +<>= + module subroutine dag_node_make_f_nodes (dag_node, feyngraph_set, dag) + class(dag_node_t), intent(inout) :: dag_node + type(feyngraph_set_t), intent(inout) :: feyngraph_set + type(dag_t), intent(inout) :: dag + end subroutine dag_node_make_f_nodes +<>= + module subroutine dag_node_make_f_nodes (dag_node, feyngraph_set, dag) + class(dag_node_t), intent(inout) :: dag_node + type(feyngraph_set_t), intent(inout) :: feyngraph_set + type(dag_t), intent(inout) :: dag + character(len=LABEL_LEN) :: particle_label + integer :: i, j + integer, dimension (2) :: obj + integer, dimension (2) :: i_obj + integer :: n_obj + integer :: pos + integer :: new_size, size1, size2 + integer, dimension(:), allocatable :: match + if (allocated (dag_node%f_node)) return + pos = minloc (dag_node%string%t%type, 1,dag_node%string%t%type == NODE_TK) + particle_label = char (dag_node%string%t(pos)) + if (dag_node%leaf) then +!!! construct subtree with procedure similar to the one for the old output + allocate (dag_node%f_node(1)) + allocate (dag_node%f_node(1)%node) + dag_node%f_node(1)%node%particle_label = particle_label + call dag_node%f_node(1)%node%assign_particle_properties (feyngraph_set) + if (.not. dag_node%f_node(1)%node%keep) then + deallocate (dag_node%f_node) + return + end if else - xii = real_kinematics%xi_tilde * real_kinematics%xi_max (i_phs) + n_obj = 0 + do i = 1, size (dag_node%string%t) + select case (dag_node%string%t(i)%type) + case (DAG_NODE_TK, DAG_OPTIONS_TK, DAG_COMBINATION_TK) + n_obj = n_obj + 1 + if (n_obj > 2) return + obj(n_obj) = dag_node%string%t(i)%type + i_obj(n_obj) = dag_node%string%t(i)%index + end select + end do + if (n_obj == 1) then + if (obj(1) == DAG_OPTIONS_TK) then + if (allocated (dag%options(i_obj(1))%f_node_ptr1)) then + size1 = size(dag%options(i_obj(1))%f_node_ptr1) + allocate (dag_node%f_node(size1)) + do i=1, size1 + allocate (dag_node%f_node(i)%node) + dag_node%f_node(i)%node%particle_label = particle_label + call dag_node%f_node(i)%node%assign_particle_properties (feyngraph_set) + dag_node%f_node(i)%node%daughter1 => dag%options(i_obj(1))%f_node_ptr1(i)%node + dag_node%f_node(i)%node%daughter2 => dag%options(i_obj(1))%f_node_ptr2(i)%node + dag_node%f_node(i)%node%n_subtree_nodes = & + dag%options(i_obj(1))%f_node_ptr1(i)%node%n_subtree_nodes & + + dag%options(i_obj(1))%f_node_ptr2(i)%node%n_subtree_nodes + 1 + end do + end if + else if (obj(1) == DAG_COMBINATION_TK) then + if (allocated (dag%combination(i_obj(1))%f_node_ptr1)) then + size1 = size(dag%combination(i_obj(1))%f_node_ptr1) + allocate (dag_node%f_node(size1)) + do i=1, size1 + allocate (dag_node%f_node(i)%node) + dag_node%f_node(i)%node%particle_label = particle_label + call dag_node%f_node(i)%node%assign_particle_properties (feyngraph_set) + dag_node%f_node(i)%node%daughter1 => dag%combination(i_obj(1))%f_node_ptr1(i)%node + dag_node%f_node(i)%node%daughter2 => dag%combination(i_obj(1))%f_node_ptr2(i)%node + dag_node%f_node(i)%node%n_subtree_nodes = & + dag%combination(i_obj(1))%f_node_ptr1(i)%node%n_subtree_nodes & + + dag%combination(i_obj(1))%f_node_ptr2(i)%node%n_subtree_nodes + 1 + end do + end if + end if +!!! simply set daughter pointers, daughters are already combined correctly + else if (n_obj == 2) then + size1 = 0 + size2 = 0 + if (obj(1) == DAG_NODE_TK) then + if (allocated (dag%node(i_obj(1))%f_node)) then + do i=1, size (dag%node(i_obj(1))%f_node) + if (dag%node(i_obj(1))%f_node(i)%node%keep) size1 = size1 + 1 + end do + end if + else if (obj(1) == DAG_OPTIONS_TK) then + if (allocated (dag%options(i_obj(1))%f_node_ptr1)) then + do i=1, size (dag%options(i_obj(1))%f_node_ptr1) + if (dag%options(i_obj(1))%f_node_ptr1(i)%node%keep) size1 = size1 + 1 + end do + end if + end if + if (obj(2) == DAG_NODE_TK) then + if (allocated (dag%node(i_obj(2))%f_node)) then + do i=1, size (dag%node(i_obj(2))%f_node) + if (dag%node(i_obj(2))%f_node(i)%node%keep) size2 = size2 + 1 + end do + end if + else if (obj(2) == DAG_OPTIONS_TK) then + if (allocated (dag%options(i_obj(2))%f_node_ptr1)) then + do i=1, size (dag%options(i_obj(2))%f_node_ptr1) + if (dag%options(i_obj(2))%f_node_ptr1(i)%node%keep) size2 = size2 + 1 + end do + end if + end if +!!! make all combinations of daughters + select case (obj(1)) + case (DAG_NODE_TK) + select case (obj(2)) + case (DAG_NODE_TK) + call combine_all_daughters(dag%node(i_obj(1))%f_node, & + dag%node(i_obj(2))%f_node) + case (DAG_OPTIONS_TK) + call combine_all_daughters(dag%node(i_obj(1))%f_node, & + dag%options(i_obj(2))%f_node_ptr1) + end select + case (DAG_OPTIONS_TK) + select case (obj(2)) + case (DAG_NODE_TK) + call combine_all_daughters(dag%options(i_obj(1))%f_node_ptr1, & + dag%node(i_obj(2))%f_node) + case (DAG_OPTIONS_TK) + call combine_all_daughters(dag%options(i_obj(1))%f_node_ptr1, & + dag%options(i_obj(2))%f_node_ptr1) + end select + end select + end if end if - select case (kt2_type) - case (UBF_FSR_SIMPLE) - kt2 = real_kinematics%cms_energy2 / two * xii**2 * (1 - yy) - case (UBF_FSR_MASSIVE) - q = sqrt (real_kinematics%cms_energy2) - p_emitter = real_kinematics%p_born_cms%phs_point(1)%select (emitter) - mrec2 = (q - p_emitter%p(0))**2 - sum (p_emitter%p(1:3)**2) - m2 = p_emitter**2 - E_em = energy (p_emitter) - call compute_dalitz_bounds (q, m2, mrec2, z1, z2, k0_rec_max) - z = z2 - (z2 - z1) * (one + yy) / two - kt2 = xii**2 * q**3 * (one - z) / & - (two * E_em - z * xii * q) - case (UBF_FSR_MASSLESS_RECOIL) - kt2 = real_kinematics%cms_energy2 / two * xii**2 * (1 - yy**2) / two - case default - kt2 = zero - call msg_bug ("kt2_type must be set to a known value") - end select - end function real_kinematics_kt2 -@ %def real_kinematics_kt2 -@ These are the possible values for [[upper_bound_func_type]] and will be -used to decide which UBF object is allocated and which $K_T$ scale for the -matching is computed. -<>= - integer, parameter, public :: UBF_FSR_SIMPLE = 1 - integer, parameter, public :: UBF_FSR_MASSIVE = 2 - integer, parameter, public :: UBF_FSR_MASSLESS_RECOIL = 3 -@ %def UBF_FSR_SIMPLE UBF_FSR_MASSIVE UBF_FSR_MASSLESS_RECOIL -@ -<>= - procedure :: final => real_kinematics_final -<>= - subroutine real_kinematics_final (real_kin) - class(real_kinematics_t), intent(inout) :: real_kin - if (allocated (real_kin%xi_max)) deallocate (real_kin%xi_max) - if (allocated (real_kin%y)) deallocate (real_kin%y) - if (allocated (real_kin%alr_to_i_phs)) deallocate (real_kin%alr_to_i_phs) - if (allocated (real_kin%jac_rand)) deallocate (real_kin%jac_rand) - if (allocated (real_kin%y_soft)) deallocate (real_kin%y_soft) - if (allocated (real_kin%xi_ref_momenta)) deallocate (real_kin%xi_ref_momenta) - call real_kin%p_born_cms%final (); call real_kin%p_born_lab%final () - call real_kin%p_real_cms%final (); call real_kin%p_real_lab%final () - end subroutine real_kinematics_final + contains -@ %def real_kinematics_final -@ -<>= - integer, parameter, public :: I_XI = 1 - integer, parameter, public :: I_Y = 2 - integer, parameter, public :: I_PHI = 3 + subroutine combine_all_daughters (daughter1_ptr, daughter2_ptr) + type(f_node_ptr_t), dimension (:), intent(in) :: daughter1_ptr + type(f_node_ptr_t), dimension (:), intent(in) :: daughter2_ptr + integer :: i, j + integer :: pos + new_size = size1*size2 + allocate (dag_node%f_node(new_size)) + pos = 0 + do i = 1, size (daughter1_ptr) + if (daughter1_ptr(i)%node%keep) then + do j = 1, size (daughter2_ptr) + if (daughter2_ptr(j)%node%keep) then + pos = pos + 1 + allocate (dag_node%f_node(pos)%node) + dag_node%f_node(pos)%node%particle_label = particle_label + call dag_node%f_node(pos)%node%assign_particle_properties (feyngraph_set) + dag_node%f_node(pos)%node%daughter1 => daughter1_ptr(i)%node + dag_node%f_node(pos)%node%daughter2 => daughter2_ptr(j)%node + dag_node%f_node(pos)%node%n_subtree_nodes = daughter1_ptr(i)%node%n_subtree_nodes & + + daughter2_ptr(j)%node%n_subtree_nodes + 1 + call feyngraph_set%model%match_vertex (daughter1_ptr(i)%node%particle%pdg, & + daughter2_ptr(j)%node%particle%pdg, match) + if (allocated (match)) then + if (any (abs(match) == abs(dag_node%f_node(pos)%node%particle%pdg))) then + dag_node%f_node(pos)%node%keep = .true. + else + dag_node%f_node(pos)%node%keep = .false. + end if + deallocate (match) + else + dag_node%f_node(pos)%node%keep = .false. + end if + end if + end do + end if + end do + end subroutine combine_all_daughters + end subroutine dag_node_make_f_nodes - integer, parameter, public :: PHS_MODE_UNDEFINED = 0 - integer, parameter, public :: PHS_MODE_ADDITIONAL_PARTICLE = 1 - integer, parameter, public :: PHS_MODE_COLLINEAR_REMNANT = 2 +@ %def dag_node_make_f_nodes +@ In [[dag_options_make_f_nodes_single]] +we obtain all [[f_nodes]] for [[dag_nodes]] which correspond to a +set of rival subtrees or nodes, which is the first possibility for +which [[dag_options]] can appear. +In [[dag_options_make_f_nodes_pair]] +the options are rival pairs ([[daughter1]], [[daughter2]]). +Therefore we have to pass two allocatable arrays of type [[f_node_ptr_t]] +to the subroutine. +<>= + procedure :: make_f_nodes => dag_options_make_f_nodes +<>= + module subroutine dag_options_make_f_nodes (dag_options, & + feyngraph_set, dag) + class(dag_options_t), intent(inout) :: dag_options + type(feyngraph_set_t), intent(inout) :: feyngraph_set + type(dag_t), intent(inout) :: dag + end subroutine dag_options_make_f_nodes +<>= + module subroutine dag_options_make_f_nodes (dag_options, & + feyngraph_set, dag) + class(dag_options_t), intent(inout) :: dag_options + type(feyngraph_set_t), intent(inout) :: feyngraph_set + type(dag_t), intent(inout) :: dag + integer, dimension (:), allocatable :: obj, i_obj + integer :: n_obj + integer :: i + integer :: pos +!!! read options + if (allocated (dag_options%f_node_ptr1)) return + n_obj = count ((dag_options%string%t%type == DAG_NODE_TK) .or. & + (dag_options%string%t%type == DAG_OPTIONS_TK) .or. & + (dag_options%string%t%type == DAG_COMBINATION_TK), 1) + allocate (obj(n_obj)); allocate (i_obj(n_obj)) + pos = 0 + do i = 1, size (dag_options%string%t) + select case (dag_options%string%t(i)%type) + case (DAG_NODE_TK, DAG_OPTIONS_TK, DAG_COMBINATION_TK) + pos = pos + 1 + obj(pos) = dag_options%string%t(i)%type + i_obj(pos) = dag_options%string%t(i)%index + end select + end do + if (any (dag_options%string%t%type == DAG_NODE_TK)) then + call dag_options_make_f_nodes_single + else if (any (dag_options%string%t%type == DAG_COMBINATION_TK)) then + call dag_options_make_f_nodes_pair + end if + deallocate (obj, i_obj) -@ %def parameters -@ -<>= - public :: phs_fks_config_t -<>= - type, extends (phs_wood_config_t) :: phs_fks_config_t - integer :: mode = PHS_MODE_UNDEFINED - character(32) :: md5sum_born_config - logical :: born_2_to_1 = .false. - logical :: make_dalitz_plot = .false. contains - <> - end type phs_fks_config_t -@ %def phs_fks_config_t -@ -<>= - procedure :: clear_phase_space => fks_config_clear_phase_space -<>= - subroutine fks_config_clear_phase_space (phs_config) - class(phs_fks_config_t), intent(inout) :: phs_config - end subroutine fks_config_clear_phase_space + subroutine dag_options_make_f_nodes_single + integer :: i_start, i_end + integer :: n_nodes + n_nodes = 0 + do i=1, n_obj + if (allocated (dag%node(i_obj(i))%f_node)) then + n_nodes = n_nodes + size (dag%node(i_obj(i))%f_node) + end if + end do + if (n_nodes /= 0) then + allocate (dag_options%f_node_ptr1 (n_nodes)) + i_end = 0 + do i = 1, n_obj + if (allocated (dag%node(i_obj(i))%f_node)) then + i_start = i_end + 1 + i_end = i_end + size (dag%node(i_obj(i))%f_node) + dag_options%f_node_ptr1(i_start:i_end) = dag%node(i_obj(i))%f_node + end if + end do + end if + end subroutine dag_options_make_f_nodes_single -@ %def fks_config_clear_phase_space -@ -<>= - procedure :: write => phs_fks_config_write -<>= - subroutine phs_fks_config_write (object, unit, include_id) - class(phs_fks_config_t), intent(in) :: object - integer, intent(in), optional :: unit - logical, intent(in), optional :: include_id - integer :: u - u = given_output_unit (unit) - call object%phs_wood_config_t%write (u) - write (u, "(3x,A,I0)") "NLO mode = ", object%mode - write (u, "(3x,A,L1)") "2->1 proc = ", object%born_2_to_1 - write (u, "(3x,A,L1)") "Dalitz = ", object%make_dalitz_plot - write (u, "(A,A)") "Extra Born md5sum: ", object%md5sum_born_config - end subroutine phs_fks_config_write + subroutine dag_options_make_f_nodes_pair + integer :: i_start, i_end + integer :: n_nodes +!!! get f_nodes from each combination + n_nodes = 0 + do i=1, n_obj + if (allocated (dag%combination(i_obj(i))%f_node_ptr1)) then + n_nodes = n_nodes + size (dag%combination(i_obj(i))%f_node_ptr1) + end if + end do + if (n_nodes /= 0) then + allocate (dag_options%f_node_ptr1 (n_nodes)) + allocate (dag_options%f_node_ptr2 (n_nodes)) + i_end = 0 + do i=1, n_obj + if (allocated (dag%combination(i_obj(i))%f_node_ptr1)) then + i_start = i_end + 1 + i_end = i_end + size (dag%combination(i_obj(i))%f_node_ptr1) + dag_options%f_node_ptr1(i_start:i_end) = dag%combination(i_obj(i))%f_node_ptr1 + dag_options%f_node_ptr2(i_start:i_end) = dag%combination(i_obj(i))%f_node_ptr2 + end if + end do + end if + end subroutine dag_options_make_f_nodes_pair + end subroutine dag_options_make_f_nodes -@ %def phs_fks_config_write -@ -<>= - procedure :: set_mode => phs_fks_config_set_mode -<>= - subroutine phs_fks_config_set_mode (phs_config, mode) - class(phs_fks_config_t), intent(inout) :: phs_config - integer, intent(in) :: mode - select case (mode) - case (NLO_REAL, NLO_MISMATCH) - phs_config%mode = PHS_MODE_ADDITIONAL_PARTICLE - case (NLO_DGLAP) - phs_config%mode = PHS_MODE_COLLINEAR_REMNANT - end select - end subroutine phs_fks_config_set_mode +@ %def dag_options_make_f_nodes +@ We create all combinations of daughter [[f_nodes]] for a combination. +In the combination each daughter can be either a single [[dag_node]] or +[[dag_options]] which are a set of single [[dag_nodes]]. Therefore, we +first create all possible [[f_nodes]] for daughter1, then all possible +[[f_nodes]] for daughter2. In the end we combine all [[daughter1]] nodes +with all [[daughter2]] nodes. +<>= + procedure :: make_f_nodes => dag_combination_make_f_nodes +<>= + module subroutine dag_combination_make_f_nodes (dag_combination, & + feyngraph_set, dag) + class(dag_combination_t), intent(inout) :: dag_combination + type(feyngraph_set_t), intent(inout) :: feyngraph_set + type(dag_t), intent(inout) :: dag + end subroutine dag_combination_make_f_nodes +<>= + module subroutine dag_combination_make_f_nodes (dag_combination, & + feyngraph_set, dag) + class(dag_combination_t), intent(inout) :: dag_combination + type(feyngraph_set_t), intent(inout) :: feyngraph_set + type(dag_t), intent(inout) :: dag + integer, dimension (2) :: obj, i_obj + integer :: n_obj + integer :: new_size, size1, size2 + integer :: i, j, pos + if (allocated (dag_combination%f_node_ptr1)) return + n_obj = 0 + do i = 1, size (dag_combination%string%t) + select case (dag_combination%string%t(i)%type) + case (DAG_NODE_TK, DAG_OPTIONS_TK, DAG_COMBINATION_TK) + n_obj = n_obj + 1 + if (n_obj > 2) return + obj(n_obj) = dag_combination%string%t(i)%type + i_obj(n_obj) = dag_combination%string%t(i)%index + end select + end do + size1 = 0 + size2 = 0 + if (obj(1) == DAG_NODE_TK) then + if (allocated (dag%node(i_obj(1))%f_node)) & + size1 = size (dag%node(i_obj(1))%f_node) + else if (obj(1) == DAG_OPTIONS_TK) then + if (allocated (dag%options(i_obj(1))%f_node_ptr1)) & + size1 = size (dag%options(i_obj(1))%f_node_ptr1) + end if + if (obj(2) == DAG_NODE_TK) then + if (allocated (dag%node(i_obj(2))%f_node)) & + size2 = size (dag%node(i_obj(2))%f_node) + else if (obj(2) == DAG_OPTIONS_TK) then + if (allocated (dag%options(i_obj(2))%f_node_ptr1)) & + size2 = size (dag%options(i_obj(2))%f_node_ptr1) + end if +!!! combine the 2 arrays of f_nodes + new_size = size1*size2 + if (new_size /= 0) then + allocate (dag_combination%f_node_ptr1 (new_size)) + allocate (dag_combination%f_node_ptr2 (new_size)) + pos = 0 + select case (obj(1)) + case (DAG_NODE_TK) + select case (obj(2)) + case (DAG_NODE_TK) + do i = 1, size1 + do j = 1, size2 + pos = pos + 1 + dag_combination%f_node_ptr1(pos) = & + dag%node(i_obj(1))%f_node(i) + dag_combination%f_node_ptr2(pos) = & + dag%node(i_obj(2))%f_node(j) + end do + end do + case (DAG_OPTIONS_TK) + do i = 1, size1 + do j = 1, size2 + pos = pos + 1 + dag_combination%f_node_ptr1(pos) = & + dag%node(i_obj(1))%f_node(i) + dag_combination%f_node_ptr2(pos) = & + dag%options(i_obj(2))%f_node_ptr1(j) + end do + end do + end select + case (DAG_OPTIONS_TK) + select case (obj(2)) + case (DAG_NODE_TK) + do i = 1, size1 + do j = 1, size2 + pos = pos + 1 + dag_combination%f_node_ptr1(pos) = & + dag%options(i_obj(1))%f_node_ptr1(i) + dag_combination%f_node_ptr2(pos) = & + dag%node(i_obj(2))%f_node(j) + end do + end do + case (DAG_OPTIONS_TK) + do i = 1, size1 + do j = 1, size2 + pos = pos + 1 + dag_combination%f_node_ptr1(pos) = & + dag%options(i_obj(1))%f_node_ptr1(i) + dag_combination%f_node_ptr2(pos) = & + dag%options(i_obj(2))%f_node_ptr1(j) + end do + end do + end select + end select + end if + end subroutine dag_combination_make_f_nodes -@ %def phs_fks_config_set_mod -@ -<>= - procedure :: configure => phs_fks_config_configure -<>= - subroutine phs_fks_config_configure (phs_config, sqrts, & - sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, & - ignore_mismatch, nlo_type, subdir) - class(phs_fks_config_t), intent(inout) :: phs_config - real(default), intent(in) :: sqrts - logical, intent(in), optional :: sqrts_fixed - logical, intent(in), optional :: lab_is_cm - logical, intent(in), optional :: azimuthal_dependence - logical, intent(in), optional :: rebuild - logical, intent(in), optional :: ignore_mismatch - integer, intent(in), optional :: nlo_type - type(string_t), intent(in), optional :: subdir - if (present (nlo_type)) phs_config%nlo_type = nlo_type - if (.not. phs_config%is_combined_integration) then - select case (phs_config%mode) - case (PHS_MODE_ADDITIONAL_PARTICLE) - phs_config%n_par = phs_config%n_par + 3 - if (phs_config%nlo_type == NLO_REAL .and. phs_config%n_out == 2) then - phs_config%born_2_to_1 = .true. +@ %def dag_combination_make_f_nodes +@ Here we create the [[feyngraphs]]. After the construction of the +[[dag]] the remaining [[dag_string]] should contain a token for a +single [[dag_node]] which corresponds to the roots of the +[[feyngraphs]]. Therefore we make all [[f_nodes]] for this [[dag_node]] +and create a [[feyngraph]] for each [[f_node]]. Note that only +3-vertices are accepted. All other vertices are rejected. The +starting point is the last dag node which has been added to the list, +since this corresponds to the root of the tree. +Is is important to understand that the structure of feyngraphs is not +the same as the structure of the dag which is read from file, because +for the calculations which are performed in this module we want to +reuse the nodes for the outgoing particles, which means that they +appear only once. In O'Mega's output, it is the first incoming particle +which appears only once and the outgoing particles appear many times. This +transition is incorporated in the subroutines which create [[f_nodes]] +from the different dag objects. +<>= + procedure :: make_feyngraphs => dag_make_feyngraphs +<>= + module subroutine dag_make_feyngraphs (dag, feyngraph_set) + class(dag_t), intent(inout) :: dag + type(feyngraph_set_t), intent(inout) :: feyngraph_set + end subroutine dag_make_feyngraphs +<>= + module subroutine dag_make_feyngraphs (dag, feyngraph_set) + class(dag_t), intent(inout) :: dag + type(feyngraph_set_t), intent(inout) :: feyngraph_set + integer :: i + integer :: max_subtree_size + max_subtree_size = dag%node(dag%n_nodes)%subtree_size + if (allocated (dag%node(dag%n_nodes)%f_node)) then + do i = 1, size (dag%node(dag%n_nodes)%f_node) + if (.not. associated (feyngraph_set%first)) then + allocate (feyngraph_set%last) + feyngraph_set%first => feyngraph_set%last + else + allocate (feyngraph_set%last%next) + feyngraph_set%last => feyngraph_set%last%next end if - case (PHS_MODE_COLLINEAR_REMNANT) - phs_config%n_par = phs_config%n_par + 1 - end select + feyngraph_set%last%root => dag%node(dag%n_nodes)%f_node(i)%node + !!! The first particle was correct in the O'Mega parsable DAG output. + !!! It was however changed to its anti-particle in + !!! f_node_assign_particle_properties, which we revert here. + feyngraph_set%last%root%particle => & + feyngraph_set%last%root%particle%anti + feyngraph_set%last%n_nodes = feyngraph_set%last%root%n_subtree_nodes + feyngraph_set%n_graphs = feyngraph_set%n_graphs + 1 + end do + feyngraph_set%f_node_list%max_tree_size = feyngraph_set%first%n_nodes end if - call phs_config%compute_md5sum () - end subroutine phs_fks_config_configure + end subroutine dag_make_feyngraphs -@ %def phs_fks_config_configure -@ -<>= - procedure :: startup_message => phs_fks_config_startup_message -<>= - subroutine phs_fks_config_startup_message (phs_config, unit) - class(phs_fks_config_t), intent(in) :: phs_config - integer, intent(in), optional :: unit - call phs_config%phs_wood_config_t%startup_message (unit) - end subroutine phs_fks_config_startup_message +@ %def dag_make_feyngraphs +@ A write procedure of the [[dag]] for debugging. +<>= + procedure :: write => dag_write +<>= + module subroutine dag_write (dag, u) + class(dag_t), intent(in) :: dag + integer, intent(in) :: u + end subroutine dag_write +<>= + module subroutine dag_write (dag, u) + class(dag_t), intent(in) :: dag + integer, intent(in) :: u + integer :: i + write (u,fmt='(A)') 'nodes' + do i=1, dag%n_nodes + write (u,fmt='(I5,3X,A)') i, char (dag%node(i)%string) + end do + write (u,fmt='(A)') 'options' + do i=1, dag%n_options + write (u,fmt='(I5,3X,A)') i, char (dag%options(i)%string) + end do + write (u,fmt='(A)') 'combination' + do i=1, dag%n_combinations + write (u,fmt='(I5,3X,A)') i, char (dag%combination(i)%string) + end do + end subroutine dag_write -@ %def phs_fks_config_startup_message -@ -<>= - procedure, nopass :: allocate_instance => phs_fks_config_allocate_instance -<>= - subroutine phs_fks_config_allocate_instance (phs) - class(phs_t), intent(inout), pointer :: phs - allocate (phs_fks_t :: phs) - end subroutine phs_fks_config_allocate_instance +@ %def dag_write +@ Make a copy of a resonant [[k_node]], where the copy is kept +nonresonant. +<>= + subroutine k_node_make_nonresonant_copy (k_node) + type(k_node_t), intent(in) :: k_node + type(k_node_t), pointer :: copy + call k_node%f_node%k_node_list%add_entry (copy, recycle=.true.) + copy%daughter1 => k_node%daughter1 + copy%daughter2 => k_node%daughter2 + copy = k_node + copy%mapping = NONRESONANT + copy%resonant = .false. + copy%on_shell = .false. + copy%mapping_assigned = .true. + copy%is_nonresonant_copy = .true. + end subroutine k_node_make_nonresonant_copy -@ %def phs_fks_config_allocate_instance -@ If the phase space is generated from file, but we want to have resonance -histories, we must force the cascade sets to be generated. However, it must -be assured that Born flavors are used for this. -<>= - procedure :: generate_phase_space_extra => phs_fks_config_generate_phase_space_extra -<>= - subroutine phs_fks_config_generate_phase_space_extra (phs_config) - class(phs_fks_config_t), intent(inout) :: phs_config - integer :: off_shell, extra_off_shell - type(flavor_t), dimension(:,:), allocatable :: flv_born +@ %def k_node_make_nonresonant_copy +@ For a given [[feyngraph]] we create all possible [[kingraphs]]. Here +we use existing [[k_nodes]] which have already been created when the +mapping calculations of the pure s-channel subgraphs are performed. The +nodes for the incoming particles or the nodes on the t-line will have +to be created in all cases because they are not used in several graphs. +To obtain the existing [[k_nodes]], we use the subroutine +[[k_node_init_from_f_node]] which itself uses [[f_node_list_get_nodes]] +to obtain all active [[k_nodes]] in the [[k_node_list]] of the [[f_node]]. +The created [[kingraphs]] are attached to the linked list +of the [[feyngraph]]. For scattering processes we have to split up the +t-line, because since all graphs are represented as a decay, different +nodes can share daughter nodes. This happens also for the t-line or +the incoming particle which appears as an outgoing particle. For the +[[t_line]] or [[incoming]] nodes we do not want to recycle nodes but +rather create a copy of this line for each [[kingraph]]. +<>= + procedure :: make_kingraphs => feyngraph_make_kingraphs +<>= + module subroutine feyngraph_make_kingraphs (feyngraph, feyngraph_set) + class(feyngraph_t), intent(inout) :: feyngraph + type(feyngraph_set_t), intent(in) :: feyngraph_set + end subroutine feyngraph_make_kingraphs +<>= + module subroutine feyngraph_make_kingraphs (feyngraph, feyngraph_set) + class(feyngraph_t), intent(inout) :: feyngraph + type(feyngraph_set_t), intent(in) :: feyngraph_set + type(k_node_ptr_t), dimension (:), allocatable :: kingraph_root + integer :: i + if (.not. associated (feyngraph%kin_first)) then + call k_node_init_from_f_node (feyngraph%root, & + kingraph_root, feyngraph_set) + if (.not. feyngraph%root%keep) return + if (feyngraph_set%process_type == SCATTERING) then + call split_up_t_lines (kingraph_root) + end if + do i=1, size (kingraph_root) + if (associated (feyngraph%kin_last)) then + allocate (feyngraph%kin_last%next) + feyngraph%kin_last => feyngraph%kin_last%next + else + allocate (feyngraph%kin_last) + feyngraph%kin_first => feyngraph%kin_last + end if + feyngraph%kin_last%root => kingraph_root(i)%node + feyngraph%kin_last%n_nodes = feyngraph%n_nodes + feyngraph%kin_last%keep = feyngraph%keep + if (feyngraph_set%process_type == SCATTERING) then + feyngraph%kin_last%root%bincode = & + f_node_get_external_bincode (feyngraph_set, feyngraph%root) + end if + end do + deallocate (kingraph_root) + end if + end subroutine feyngraph_make_kingraphs + +@ %def feyngraph_make_kingraphs +@ Create all [[k_nodes]] for a given [[f_node]]. We return these nodes +using [[k_node_ptr]]. If the node is external, we assign also the bincode +to the [[k_nodes]] because this is determined from substrings of the +input file which belong to the [[feyngraphs]] and [[f_nodes]]. +<>= + recursive subroutine k_node_init_from_f_node (f_node, k_node_ptr, feyngraph_set) + type(f_node_t), target, intent(inout) :: f_node + type(k_node_ptr_t), allocatable, dimension (:), intent(out) :: k_node_ptr + type(feyngraph_set_t), intent(in) :: feyngraph_set + type(k_node_ptr_t), allocatable, dimension(:) :: daughter_ptr1, daughter_ptr2 + integer :: n_nodes integer :: i, j - integer :: n_state, n_flv_born - integer :: unit_fds - logical :: valid - type(string_t) :: file_name - logical :: file_exists - if (phs_config%use_cascades2) then - allocate (phs_config%feyngraph_set) - else - allocate (phs_config%cascade_set) + integer :: pos + integer, save :: counter = 0 + if (.not. (f_node%incoming .or. f_node%t_line)) then + call f_node%k_node_list%get_nodes (k_node_ptr) + if (.not. allocated (k_node_ptr) .and. f_node%k_node_list%n_entries > 0) then + f_node%keep = .false. + return + end if end if - n_flv_born = size (phs_config%flv, 1) - 1 - n_state = size (phs_config%flv, 2) - allocate (flv_born (n_flv_born, n_state)) - do i = 1, n_flv_born - do j = 1, n_state - flv_born(i, j) = phs_config%flv(i, j) - end do - end do - if (phs_config%use_cascades2) then - file_name = char (phs_config%id) // ".fds" - inquire (file=char (file_name), exist=file_exists) - if (.not. file_exists) call msg_fatal & - ("The O'Mega input file " // char (file_name) // & - " does not exist. " // "Please make sure that the " // & - "variable ?omega_write_phs_output has been set correctly.") - unit_fds = free_unit () - open (unit=unit_fds, file=char(file_name), status='old', action='read') + if (.not. allocated (k_node_ptr)) then + if (associated (f_node%daughter1) .and. associated (f_node%daughter2)) then + call k_node_init_from_f_node (f_node%daughter1, daughter_ptr1, & + feyngraph_set) + call k_node_init_from_f_node (f_node%daughter2, daughter_ptr2, & + feyngraph_set) + if (.not. (f_node%daughter1%keep .and. f_node%daughter2%keep)) then + f_node%keep = .false. + return + end if + n_nodes = size (daughter_ptr1) * size (daughter_ptr2) + allocate (k_node_ptr (n_nodes)) + pos = 1 + do i=1, size (daughter_ptr1) + do j=1, size (daughter_ptr2) + if (f_node%incoming .or. f_node%t_line) then + call f_node%k_node_list%add_entry (k_node_ptr(pos)%node, recycle = .false.) + else + call f_node%k_node_list%add_entry (k_node_ptr(pos)%node, recycle = .true.) + end if + k_node_ptr(pos)%node%f_node => f_node + k_node_ptr(pos)%node%daughter1 => daughter_ptr1(i)%node + k_node_ptr(pos)%node%daughter2 => daughter_ptr2(j)%node + k_node_ptr(pos)%node%f_node_index = f_node%index + k_node_ptr(pos)%node%incoming = f_node%incoming + k_node_ptr(pos)%node%t_line = f_node%t_line + k_node_ptr(pos)%node%particle => f_node%particle + pos = pos + 1 + end do + end do + deallocate (daughter_ptr1, daughter_ptr2) + else + allocate (k_node_ptr(1)) + if (f_node%incoming .or. f_node%t_line) then + call f_node%k_node_list%add_entry (k_node_ptr(1)%node, recycle=.false.) + else + call f_node%k_node_list%add_entry (k_node_ptr(1)%node, recycle=.true.) + end if + k_node_ptr(1)%node%f_node => f_node + k_node_ptr(1)%node%f_node_index = f_node%index + k_node_ptr(1)%node%incoming = f_node%incoming + k_node_ptr(1)%node%t_line = f_node%t_line + k_node_ptr(1)%node%particle => f_node%particle + k_node_ptr(1)%node%bincode = f_node_get_external_bincode (feyngraph_set, & + f_node) + end if end if - off_shell = phs_config%par%off_shell - do extra_off_shell = 0, max (n_flv_born - 2, 0) - phs_config%par%off_shell = off_shell + extra_off_shell - if (phs_config%use_cascades2) then - call feyngraph_set_generate (phs_config%feyngraph_set, & - phs_config%model, phs_config%n_in, phs_config%n_out - 1, & - flv_born, phs_config%par, phs_config%fatal_beam_decay, unit_fds, & - phs_config%vis_channels) - if (feyngraph_set_is_valid (phs_config%feyngraph_set)) exit + end subroutine k_node_init_from_f_node + +@ %def k_node_init_from_f_node +@ The graphs resulting from [[k_node_init_from_f_node]] are fine if they +are used only in one direction. This is however not the case when one +wants to invert the graphs, i.e. take the other incoming particle of a +scattering process as the decaying particle, because the outgoing +[[f_nodes]] (and hence also the [[k_nodes]]) exist only once. This +problem is solved here by creating a distinct t-line for each of the +graphs. The following subroutine disentangles the data structure by +creating new nodes such that the different t-lines are not connected +any more. +<>= + recursive subroutine split_up_t_lines (t_node) + type(k_node_ptr_t), dimension(:), intent(inout) :: t_node + type(k_node_t), pointer :: ref_node => null () + type(k_node_t), pointer :: ref_daughter => null () + type(k_node_t), pointer :: new_daughter => null () + type(k_node_ptr_t), dimension(:), allocatable :: t_daughter + integer :: ref_daughter_index + integer :: i, j + allocate (t_daughter (size (t_node))) + do i=1, size (t_node) + ref_node => t_node(i)%node + if (associated (ref_node%daughter1) .and. associated (ref_node%daughter2)) then + ref_daughter => null () + if (ref_node%daughter1%incoming .or. ref_node%daughter1%t_line) then + ref_daughter => ref_node%daughter1 + ref_daughter_index = 1 + else if (ref_node%daughter2%incoming .or. ref_node%daughter2%t_line) then + ref_daughter => ref_node%daughter2 + ref_daughter_index = 2 + end if + do j=1, size (t_daughter) + if (.not. associated (t_daughter(j)%node)) then + t_daughter(j)%node => ref_daughter + exit + else if (t_daughter(j)%node%index == ref_daughter%index) then + new_daughter => null () + call ref_daughter%f_node%k_node_list%add_entry (new_daughter, recycle=.false.) + new_daughter = ref_daughter + new_daughter%daughter1 => ref_daughter%daughter1 + new_daughter%daughter2 => ref_daughter%daughter2 + if (ref_daughter_index == 1) then + ref_node%daughter1 => new_daughter + else if (ref_daughter_index == 2) then + ref_node%daughter2 => new_daughter + end if + ref_daughter => new_daughter + end if + end do else - call cascade_set_generate (phs_config%cascade_set, & - phs_config%model, phs_config%n_in, phs_config%n_out - 1, & - flv_born, phs_config%par, phs_config%fatal_beam_decay) - if (cascade_set_is_valid (phs_config%cascade_set)) exit + return end if end do - if (phs_config%use_cascades2) then - close (unit_fds) - valid = feyngraph_set_is_valid (phs_config%feyngraph_set) + call split_up_t_lines (t_daughter) + deallocate (t_daughter) + end subroutine split_up_t_lines + +@ %def split_up_t_lines +@ This subroutine sets the [[inverse_daughters]] of a [[k_node]]. If we +invert a [[kingraph]] such that not the first but the second incoming +particle appears as the root of the tree, the [[incoming]] and [[t_line]] +particles obtain other daughters. These are the former mother node and +the sister node [[s_daughter]]. Here we set only the pointers for +the [[inverse_daughters]]. The inversion happens in [[kingraph_make_inverse_copy]] +and [[node_inverse_deep_copy]]. +<>= + subroutine kingraph_set_inverse_daughters (kingraph) + type(kingraph_t), intent(inout) :: kingraph + type(k_node_t), pointer :: mother + type(k_node_t), pointer :: t_daughter + type(k_node_t), pointer :: s_daughter + mother => kingraph%root + do while (associated (mother)) + if (associated (mother%daughter1) .and. & + associated (mother%daughter2)) then + if (mother%daughter1%t_line .or. mother%daughter1%incoming) then + t_daughter => mother%daughter1; s_daughter => mother%daughter2 + else if (mother%daughter2%t_line .or. mother%daughter2%incoming) then + t_daughter => mother%daughter2; s_daughter => mother%daughter1 + else + exit + end if + t_daughter%inverse_daughter1 => mother + t_daughter%inverse_daughter2 => s_daughter + mother => t_daughter + else + exit + end if + end do + end subroutine kingraph_set_inverse_daughters + +@ %def kingraph_set_inverse_daughters +@ Set the bincode of an [[f_node]] which corresponds to an external +particle. This is done on the basis of the [[particle_label]] which is a +substring of the input file. Here it is not the particle name which is +important, but the number(s) in brackets which in general indicate the +external particles which are connected to the current node. This function +is however only used for external particles, so there can either be +one or [[n_out + 1]] particles in the brackets (in the DAG input file +always one, because also for the root there is only a single number). +In all cases we check the number of particles (in the DAG input the +numbers are separated by a slash). +<>= + function f_node_get_external_bincode (feyngraph_set, f_node) result (bincode) + type(feyngraph_set_t), intent(in) :: feyngraph_set + type(f_node_t), intent(in) :: f_node + integer (TC) :: bincode + character(len=LABEL_LEN) :: particle_label + integer :: start_pos, end_pos, n_out_decay + integer :: n_prt ! for DAG + integer :: i + bincode = 0 + if (feyngraph_set%process_type == DECAY) then + n_out_decay = feyngraph_set%n_out else - valid = cascade_set_is_valid (phs_config%cascade_set) + n_out_decay = feyngraph_set%n_out + 1 end if - if (.not. valid) & - call msg_fatal ("Resonance extraction: Phase space generation failed") - end subroutine phs_fks_config_generate_phase_space_extra - -@ %def phs_fks_config_generate_phase_space_extra -@ -<>= - procedure :: set_born_config => phs_fks_config_set_born_config -<>= - subroutine phs_fks_config_set_born_config (phs_config, phs_cfg_born) - class(phs_fks_config_t), intent(inout) :: phs_config - type(phs_wood_config_t), intent(in), target :: phs_cfg_born - if (debug_on) & - call msg_debug (D_PHASESPACE, "phs_fks_config_set_born_config") - phs_config%forest = phs_cfg_born%forest - phs_config%n_channel = phs_cfg_born%n_channel - allocate (phs_config%channel (phs_config%n_channel)) - phs_config%channel = phs_cfg_born%channel - phs_config%n_par = phs_cfg_born%n_par - phs_config%n_state = phs_cfg_born%n_state - phs_config%sqrts = phs_cfg_born%sqrts - phs_config%par = phs_cfg_born%par - phs_config%sqrts_fixed = phs_cfg_born%sqrts_fixed - phs_config%azimuthal_dependence = phs_cfg_born%azimuthal_dependence - phs_config%provides_chains = phs_cfg_born%provides_chains - phs_config%lab_is_cm = phs_cfg_born%lab_is_cm - phs_config%vis_channels = phs_cfg_born%vis_channels - phs_config%provides_equivalences = phs_cfg_born%provides_equivalences - allocate (phs_config%chain (size (phs_cfg_born%chain))) - phs_config%chain = phs_cfg_born%chain - phs_config%model => phs_cfg_born%model - phs_config%use_cascades2 = phs_cfg_born%use_cascades2 - if (allocated (phs_cfg_born%cascade_set)) then - allocate (phs_config%cascade_set) - phs_config%cascade_set = phs_cfg_born%cascade_set + particle_label = f_node%particle_label + start_pos = index (particle_label, '[') + 1 + end_pos = index (particle_label, ']') - 1 + particle_label = particle_label(start_pos:end_pos) +!!! n_out_decay is the number of outgoing particles in the +!!! O'Mega output, which is always represented as a decay + if (feyngraph_set%use_dag) then + n_prt = 1 + do i=1, len(particle_label) + if (particle_label(i:i) == '/') n_prt = n_prt + 1 + end do + else + n_prt = end_pos - start_pos + 1 end if - if (allocated (phs_cfg_born%feyngraph_set)) then - allocate (phs_config%feyngraph_set) - phs_config%feyngraph_set = phs_cfg_born%feyngraph_set + if (n_prt == 1) then + bincode = calculate_external_bincode (particle_label, & + feyngraph_set%process_type, n_out_decay) + else if (n_prt == n_out_decay) then + bincode = ibset (0, n_out_decay) end if - phs_config%md5sum_born_config = phs_cfg_born%md5sum_phs_config - end subroutine phs_fks_config_set_born_config + end function f_node_get_external_bincode -@ %def phs_fks_config_set_born_config -@ -<>= - procedure :: get_resonance_histories => phs_fks_config_get_resonance_histories -<>= - function phs_fks_config_get_resonance_histories (phs_config) result (resonance_histories) - type(resonance_history_t), dimension(:), allocatable :: resonance_histories - class(phs_fks_config_t), intent(inout) :: phs_config - if (allocated (phs_config%cascade_set)) then - call cascade_set_get_resonance_histories & - (phs_config%cascade_set, n_filter = 2, res_hists = resonance_histories) - else if (allocated (phs_config%feyngraph_set)) then - call feyngraph_set_get_resonance_histories & - (phs_config%feyngraph_set, n_filter = 2, res_hists = resonance_histories) - else - if (debug_on) call msg_debug (D_PHASESPACE, "Have to rebuild phase space for resonance histories") - call phs_config%generate_phase_space_extra () - if (phs_config%use_cascades2) then - call feyngraph_set_get_resonance_histories & - (phs_config%feyngraph_set, n_filter = 2, res_hists = resonance_histories) +@ %def f_node_get_external_bincode +@ Assign a bincode to an internal node, which is calculated from +the bincodes of [[daughter1]] and [[daughter2]]. +<>= + subroutine node_assign_bincode (node) + type(k_node_t), intent(inout) :: node + if (associated (node%daughter1) .and. associated (node%daughter2) & + .and. .not. node%incoming) then + node%bincode = ior(node%daughter1%bincode, node%daughter2%bincode) + end if + end subroutine node_assign_bincode + +@ %def node_assign_bincode +@ Calculate the [[bincode]] from the number in the brackets of the +[[particle_label]], if the node is external. For the root in the +non-factorized output, this is calculated directly in +[[f_node_get_external_bincode]] because in this case all the other +external particle numbers appear between the brackets. +<>= + function calculate_external_bincode (label_number_string, process_type, n_out_decay) result (bincode) + character(len=*), intent(in) :: label_number_string + integer, intent(in) :: process_type + integer, intent(in) :: n_out_decay + character :: number_char + integer :: number_int + integer (kind=TC) :: bincode + bincode = 0 + read (label_number_string, fmt='(A)') number_char +!!! check if the character is a letter (A,B,C,...) or a number (1...9) +!!! numbers 1 and 2 are special cases + select case (number_char) + case ('1') + if (process_type == SCATTERING) then + number_int = n_out_decay + 3 else - call cascade_set_get_resonance_histories & - (phs_config%cascade_set, n_filter = 2, res_hists = resonance_histories) + number_int = n_out_decay + 2 end if - end if - end function phs_fks_config_get_resonance_histories + case ('2') + if (process_type == SCATTERING) then + number_int = n_out_decay + 2 + else + number_int = 2 + end if + case ('A') + number_int = 10 + case ('B') + number_int = 11 + case ('C') + number_int = 12 + case ('D') + number_int = 13 + case default + read (number_char, fmt='(I1)') number_int + end select + bincode = ibset (bincode, number_int - process_type - 1) + end function calculate_external_bincode -@ %def phs_fks_config_get_resonance_histories +@ %def calculate_external_bincode @ -<>= - public :: dalitz_plot_t -<>= - type :: dalitz_plot_t - integer :: unit = -1 - type(string_t) :: filename - logical :: active = .false. - logical :: inverse = .false. +\subsection{Mapping calculations} +Once a [[k_node]] and its subtree nodes have been created, we can +perform the kinematical calculations and assign mappings, depending on +the particle properties and the results for the subtree nodes. This +could in principle be done recursively, calling the procedure first +for the daughter nodes and then perform the calculations for the actual +node. But for parallization and comparing the nodes, this will be done +simultaneously for all nodes with the same number of subtree nodes, and the number of +subtree nodes increases, starting from one, in steps of two. The +actual mapping calculations are done in complete analogy to cascades. +<>= + subroutine node_assign_mapping_s (feyngraph, node, feyngraph_set) + type(feyngraph_t), intent(inout) :: feyngraph + type(k_node_t), intent(inout) :: node + type(feyngraph_set_t), intent(inout) :: feyngraph_set + real(default) :: eff_mass_sum + logical :: keep + if (.not. node%mapping_assigned) then + if (node%particle%mass > feyngraph_set%phs_par%m_threshold_s) then + node%effective_mass = node%particle%mass + end if + if (associated (node%daughter1) .and. associated (node%daughter2)) then + if (.not. (node%daughter1%keep .and. node%daughter2%keep)) then + node%keep = .false.; return + end if + node%ext_mass_sum = node%daughter1%ext_mass_sum & + + node%daughter2%ext_mass_sum + keep = .false. +!!! Potentially resonant cases [sqrts = m_rea for on-shell decay] + if (node%particle%mass > node%ext_mass_sum & + .and. node%particle%mass <= feyngraph_set%phs_par%sqrts) then + if (node%particle%width /= 0) then + if (node%daughter1%on_shell .or. node%daughter2%on_shell) then + keep = .true. + node%mapping = S_CHANNEL + node%resonant = .true. + end if + else + call warn_decay (node%particle) + end if +!!! Collinear and IR singular cases + else if (node%particle%mass < feyngraph_set%phs_par%sqrts) then +!!! Massless splitting + if (node%daughter1%effective_mass == 0 & + .and. node%daughter2%effective_mass == 0 & + .and. .not. associated (node%daughter1%daughter1) & + .and. .not. associated (node%daughter1%daughter2) & + .and. .not. associated (node%daughter2%daughter1) & + .and. .not. associated (node%daughter2%daughter2)) then + keep = .true. + node%log_enhanced = .true. + if (node%particle%is_vector) then + if (node%daughter1%particle%is_vector & + .and. node%daughter2%particle%is_vector) then + node%mapping = COLLINEAR !!! three-vector-splitting + else + node%mapping = INFRARED !!! vector spliiting into matter + end if + else + if (node%daughter1%particle%is_vector & + .or. node%daughter2%particle%is_vector) then + node%mapping = COLLINEAR !!! vector radiation off matter + else + node%mapping = INFRARED !!! scalar radiation/splitting + end if + end if +!!! IR radiation off massive particle [cascades] + else if (node%effective_mass > 0 .and. & + node%daughter1%effective_mass > 0 .and. & + node%daughter2%effective_mass == 0 .and. & + (node%daughter1%on_shell .or. & + node%daughter1%mapping == RADIATION) .and. & + abs (node%effective_mass - & + node%daughter1%effective_mass) < feyngraph_set%phs_par%m_threshold_s) & + then + keep = .true. + node%log_enhanced = .true. + node%mapping = RADIATION + else if (node%effective_mass > 0 .and. & + node%daughter2%effective_mass > 0 .and. & + node%daughter1%effective_mass == 0 .and. & + (node%daughter2%on_shell .or. & + node%daughter2%mapping == RADIATION) .and. & + abs (node%effective_mass - & + node%daughter2%effective_mass) < feyngraph_set%phs_par%m_threshold_s) & + then + keep = .true. + node%log_enhanced = .true. + node%mapping = RADIATION + end if + end if +!!! Non-singular cases, including failed resonances [from cascades] + if (.not. keep) then +!!! Two on-shell particles from a virtual mother [from cascades, here eventually more than 2] + if (node%daughter1%on_shell .or. node%daughter2%on_shell) then + keep = .true. + eff_mass_sum = node%daughter1%effective_mass & + + node%daughter2%effective_mass + node%effective_mass = max (node%ext_mass_sum, eff_mass_sum) + if (node%effective_mass < feyngraph_set%phs_par%m_threshold_s) then + node%effective_mass = 0 + end if + end if + end if +!!! Complete and register feyngraph (make copy in case of resonance) + if (keep) then + node%on_shell = node%resonant .or. node%log_enhanced + if (node%resonant) then + if (feyngraph_set%phs_par%keep_nonresonant) then + call k_node_make_nonresonant_copy (node) + end if + node%ext_mass_sum = node%particle%mass + end if + end if + node%mapping_assigned = .true. + call node_assign_bincode (node) + call node%subtree%add_entry (node) + else !!! external (outgoing) particle + node%ext_mass_sum = node%particle%mass + node%mapping = EXTERNAL_PRT + node%multiplicity = 1 + node%mapping_assigned = .true. + call node%subtree%add_entry (node) + node%on_shell = .true. + if (node%particle%mass >= feyngraph_set%phs_par%m_threshold_s) then + node%effective_mass = node%particle%mass + end if + end if + else if (node%is_nonresonant_copy) then + call node_assign_bincode (node) + call node%subtree%add_entry (node) + node%is_nonresonant_copy = .false. + end if + call node_count_specific_properties (node) + if (node%n_off_shell > feyngraph_set%phs_par%off_shell) then + node%keep = .false. + end if contains - <> - end type dalitz_plot_t - -@ %def dalitz_plot_t -@ -<>= - procedure :: init => dalitz_plot_init -<>= - subroutine dalitz_plot_init (plot, unit, filename, inverse) - class(dalitz_plot_t), intent(inout) :: plot - integer, intent(in) :: unit - type(string_t), intent(in) :: filename - logical, intent(in) :: inverse - plot%active = .true. - plot%unit = unit - plot%inverse = inverse - open (plot%unit, file = char (filename), action = "write") - end subroutine dalitz_plot_init + subroutine warn_decay (particle) + type(part_prop_t), intent(in) :: particle + integer :: i + integer, dimension(MAX_WARN_RESONANCE), save :: warned_code = 0 + LOOP_WARNED: do i = 1, MAX_WARN_RESONANCE + if (warned_code(i) == 0) then + warned_code(i) = particle%pdg + write (msg_buffer, "(A)") & + & " Intermediate decay of zero-width particle " & + & // trim(particle%particle_label) & + & // " may be possible." + call msg_warning + exit LOOP_WARNED + else if (warned_code(i) == particle%pdg) then + exit LOOP_WARNED + end if + end do LOOP_WARNED + end subroutine warn_decay + end subroutine node_assign_mapping_s -@ %def daltiz_plot_init -@ -<>= - procedure :: write_header => dalitz_plot_write_header -<>= - subroutine dalitz_plot_write_header (plot) - class(dalitz_plot_t), intent(in) :: plot - write (plot%unit, "(A36)") "### Dalitz plot generated by WHIZARD" - if (plot%inverse) then - write (plot%unit, "(A10,1x,A4)") "### k0_n+1", "k0_n" - else - write (plot%unit, "(A8,1x,A6)") "### k0_n", "k0_n+1" +@ %def node_assign_mapping_s +@ We determine the numbers [[n_resonances]], [[multiplicity]], +[[n_off_shell]] and [[n_log_enhanced]] for a given node. +<>= + subroutine node_count_specific_properties (node) + type(k_node_t), intent(inout) :: node + if (associated (node%daughter1) .and. associated(node%daughter2)) then + if (node%resonant) then + node%multiplicity = 1 + node%n_resonances & + = node%daughter1%n_resonances & + + node%daughter2%n_resonances + 1 + else + node%multiplicity & + = node%daughter1%multiplicity & + + node%daughter2%multiplicity + node%n_resonances & + = node%daughter1%n_resonances & + + node%daughter2%n_resonances + end if + if (node%log_enhanced) then + node%n_log_enhanced & + = node%daughter1%n_log_enhanced & + + node%daughter2%n_log_enhanced + 1 + else + node%n_log_enhanced & + = node%daughter1%n_log_enhanced & + + node%daughter2%n_log_enhanced + end if + if (node%resonant) then + node%n_off_shell = 0 + else if (node%log_enhanced) then + node%n_off_shell & + = node%daughter1%n_off_shell & + + node%daughter2%n_off_shell + else + node%n_off_shell & + = node%daughter1%n_off_shell & + + node%daughter2%n_off_shell + 1 + end if + if (node%t_line) then + if (node%daughter1%t_line .or. node%daughter1%incoming) then + node%n_t_channel = node%daughter1%n_t_channel + 1 + else if (node%daughter2%t_line .or. node%daughter2%incoming) then + node%n_t_channel = node%daughter2%n_t_channel + 1 + end if + end if end if - end subroutine dalitz_plot_write_header + end subroutine node_count_specific_properties -@ %def dalitz_plot_write_header -@ -<>= - procedure :: register => dalitz_plot_register -<>= - subroutine dalitz_plot_register (plot, k0_n, k0_np1) - class(dalitz_plot_t), intent(in) :: plot - real(default), intent(in) :: k0_n, k0_np1 - if (plot%inverse) then - write (plot%unit, "(F8.4,1X,F8.4)") k0_np1, k0_n - else - write (plot%unit, "(F8.4,1X,F8.4)") k0_np1, k0_n +@ %def node_count_specific_properties +@ The subroutine [[kingraph_assign_mappings_s]] completes kinematical +calculations for a decay process, considering the [[root]] node. +<>= + subroutine kingraph_assign_mappings_s (feyngraph, kingraph, feyngraph_set) + type(feyngraph_t), intent(inout) :: feyngraph + type(kingraph_t), pointer, intent(inout) :: kingraph + type(feyngraph_set_t), intent(inout) :: feyngraph_set + if (.not. (kingraph%root%daughter1%keep .and. kingraph%root%daughter2%keep)) then + kingraph%keep = .false. + call kingraph%tree%final () end if - end subroutine dalitz_plot_register + if (kingraph%keep) then + kingraph%root%on_shell = .true. + kingraph%root%mapping = EXTERNAL_PRT + kingraph%root%mapping_assigned = .true. + call node_assign_bincode (kingraph%root) + kingraph%root%ext_mass_sum = & + kingraph%root%daughter1%ext_mass_sum + & + kingraph%root%daughter2%ext_mass_sum + if (kingraph%root%ext_mass_sum >= feyngraph_set%phs_par%sqrts) then + kingraph%root%keep = .false. + kingraph%keep = .false.; call kingraph%tree%final (); return + end if + call kingraph%root%subtree%add_entry (kingraph%root) + kingraph%root%multiplicity & + = kingraph%root%daughter1%multiplicity & + + kingraph%root%daughter2%multiplicity + kingraph%root%n_resonances & + = kingraph%root%daughter1%n_resonances & + + kingraph%root%daughter2%n_resonances + kingraph%root%n_off_shell & + = kingraph%root%daughter1%n_off_shell & + + kingraph%root%daughter2%n_off_shell + kingraph%root%n_log_enhanced & + = kingraph%root%daughter1%n_log_enhanced & + + kingraph%root%daughter2%n_log_enhanced + if (kingraph%root%n_off_shell > feyngraph_set%phs_par%off_shell) then + kingraph%root%keep = .false. + kingraph%keep = .false.; call kingraph%tree%final (); return + else + kingraph%grove_prop%multiplicity = & + kingraph%root%multiplicity + kingraph%grove_prop%n_resonances = & + kingraph%root%n_resonances + kingraph%grove_prop%n_off_shell = & + kingraph%root%n_off_shell + kingraph%grove_prop%n_log_enhanced = & + kingraph%root%n_log_enhanced + end if + kingraph%tree = kingraph%root%subtree + end if + end subroutine kingraph_assign_mappings_s -@ %def dalitz_plot_register -@ -<>= - procedure :: final => dalitz_plot_final -<>= - subroutine dalitz_plot_final (plot) - class(dalitz_plot_t), intent(inout) :: plot - logical :: opened - plot%active = .false. - plot%inverse = .false. - if (plot%unit >= 0) then - inquire (unit = plot%unit, opened = opened) - if (opened) close (plot%unit) +@ %def kingraph_assign_mappings_s +@ Compute mappings for the [[t_line]] and [[incoming]] nodes. This is +done recursively using [[node_compute_t_line]]. +<>= + subroutine kingraph_compute_mappings_t_line (feyngraph, kingraph, feyngraph_set) + type(feyngraph_t), intent(inout) :: feyngraph + type(kingraph_t), pointer, intent(inout) :: kingraph + type(feyngraph_set_t), intent(inout) :: feyngraph_set + call node_compute_t_line (feyngraph, kingraph, kingraph%root, feyngraph_set) + if (.not. kingraph%root%keep) then + kingraph%keep = .false. + call kingraph%tree%final () end if - plot%filename = var_str ('') - plot%unit = -1 - end subroutine dalitz_plot_final + if (kingraph%keep) kingraph%tree = kingraph%root%subtree + end subroutine kingraph_compute_mappings_t_line -@ %def dalitz_plot_final -@ -<>= - integer, parameter, public :: GEN_REAL_PHASE_SPACE = 1 - integer, parameter, public :: GEN_SOFT_MISMATCH = 2 - integer, parameter, public :: GEN_SOFT_LIMIT_TEST = 3 - integer, parameter, public :: GEN_COLL_LIMIT_TEST = 4 - integer, parameter, public :: GEN_ANTI_COLL_LIMIT_TEST = 5 - integer, parameter, public :: GEN_SOFT_COLL_LIMIT_TEST = 6 - integer, parameter, public :: GEN_SOFT_ANTI_COLL_LIMIT_TEST = 7 +@ %def kingraph_compute_mappings_t_line +@ Perform the kinematical calculations and mapping assignment for a node +which is either [[incoming]] or [[t_line]]. This is done recursively, +going first to the daughter node which has this property. Therefore we +first set the pointer [[t_node]] to this daughter node and [[s_node]] to +the other one. The mapping determination happens again in the same way as +in [[cascades]]. +<>= + recursive subroutine node_compute_t_line (feyngraph, kingraph, node, feyngraph_set) + type(feyngraph_t), intent(inout) :: feyngraph + type(kingraph_t), intent(inout) :: kingraph + type(k_node_t), intent(inout) :: node + type(feyngraph_set_t), intent(inout) :: feyngraph_set + type(k_node_t), pointer :: s_node + type(k_node_t), pointer :: t_node + type(k_node_t), pointer :: new_s_node + if (.not. (node%daughter1%keep .and. node%daughter2%keep)) then + node%keep = .false. + return + end if + s_node => null () + t_node => null () + new_s_node => null () + if (associated (node%daughter1) .and. associated (node%daughter2)) then + if (node%daughter1%t_line .or. node%daughter1%incoming) then + t_node => node%daughter1; s_node => node%daughter2 + else if (node%daughter2%t_line .or. node%daughter2%incoming) then + t_node => node%daughter2; s_node => node%daughter1 + end if + if (t_node%t_line) then + call node_compute_t_line (feyngraph, kingraph, t_node, feyngraph_set) + if (.not. t_node%keep) then + node%keep = .false. + return + end if + else if (t_node%incoming) then + t_node%mapping = EXTERNAL_PRT + t_node%on_shell = .true. + t_node%ext_mass_sum = t_node%particle%mass + if (t_node%particle%mass >= feyngraph_set%phs_par%m_threshold_t) then + t_node%effective_mass = t_node%particle%mass + end if + call t_node%subtree%add_entry (t_node) + end if +!!! root: + if (.not. node%incoming) then + if (t_node%incoming) then + node%ext_mass_sum = s_node%ext_mass_sum + else + node%ext_mass_sum & + = node%daughter1%ext_mass_sum & + + node%daughter2%ext_mass_sum + end if + if (node%particle%mass > feyngraph_set%phs_par%m_threshold_t) then + node%effective_mass = max (node%particle%mass, & + s_node%effective_mass) + else if (s_node%effective_mass > feyngraph_set%phs_par%m_threshold_t) then + node%effective_mass = s_node%effective_mass + else + node%effective_mass = 0 + end if +!!! Allowed decay of beam particle + if (t_node%incoming & + .and. t_node%particle%mass > s_node%particle%mass & + + node%particle%mass) then + call beam_decay (feyngraph_set%fatal_beam_decay) +!!! Massless splitting + else if (t_node%effective_mass == 0 & + .and. s_node%effective_mass < feyngraph_set%phs_par%m_threshold_t & + .and. node%effective_mass == 0) then + node%mapping = U_CHANNEL + node%log_enhanced = .true. +!!! IR radiation off massive particle + else if (t_node%effective_mass /= 0 & + .and. s_node%effective_mass == 0 & + .and. node%effective_mass /= 0 & + .and. (t_node%on_shell & + .or. t_node%mapping == RADIATION) & + .and. abs (t_node%effective_mass - node%effective_mass) & + < feyngraph_set%phs_par%m_threshold_t) then + node%log_enhanced = .true. + node%mapping = RADIATION + end if + node%mapping_assigned = .true. + call node_assign_bincode (node) + call node%subtree%add_entry (node) + call node_count_specific_properties (node) + if (node%n_off_shell > feyngraph_set%phs_par%off_shell) then + node%keep = .false. + kingraph%keep = .false.; call kingraph%tree%final (); return + else if (node%n_t_channel > feyngraph_set%phs_par%t_channel) then + node%keep = .false.; + kingraph%keep = .false.; call kingraph%tree%final (); return + end if + else + node%mapping = EXTERNAL_PRT + node%on_shell = .true. + node%ext_mass_sum & + = t_node%ext_mass_sum & + + s_node%ext_mass_sum + node%effective_mass = node%particle%mass + if (.not. (node%ext_mass_sum < feyngraph_set%phs_par%sqrts)) then + node%keep = .false. + kingraph%keep = .false.; call kingraph%tree%final (); return + end if + if (kingraph%keep) then + if (t_node%incoming .and. s_node%log_enhanced) then + call s_node%f_node%k_node_list%add_entry (new_s_node, recycle=.false.) + new_s_node = s_node + new_s_node%daughter1 => s_node%daughter1 + new_s_node%daughter2 => s_node%daughter2 + if (s_node%index == node%daughter1%index) then + node%daughter1 => new_s_node + else if (s_node%index == node%daughter2%index) then + node%daughter2 => new_s_node + end if + new_s_node%subtree = s_node%subtree + new_s_node%mapping = NO_MAPPING + new_s_node%log_enhanced = .false. + new_s_node%n_log_enhanced & + = new_s_node%n_log_enhanced - 1 + new_s_node%log_enhanced = .false. + where (new_s_node%subtree%bc == new_s_node%bincode) + new_s_node%subtree%mapping = NO_MAPPING + endwhere + else if ((t_node%t_line .or. t_node%incoming) .and. & + t_node%mapping == U_CHANNEL) then + t_node%mapping = T_CHANNEL + where (t_node%subtree%bc == t_node%bincode) + t_node%subtree%mapping = T_CHANNEL + endwhere + else if (t_node%incoming .and. & + .not. associated (s_node%daughter1) .and. & + .not. associated (s_node%daughter2)) then + call s_node%f_node%k_node_list%add_entry (new_s_node, recycle=.false.) + new_s_node = s_node + new_s_node%mapping = ON_SHELL + new_s_node%daughter1 => s_node%daughter1 + new_s_node%daughter2 => s_node%daughter2 + new_s_node%subtree = s_node%subtree + if (s_node%index == node%daughter1%index) then + node%daughter1 => new_s_node + else if (s_node%index == node%daughter2%index) then + node%daughter2 => new_s_node + end if + where (new_s_node%subtree%bc == new_s_node%bincode) + new_s_node%subtree%mapping = ON_SHELL + endwhere + end if + end if + call node%subtree%add_entry (node) + node%multiplicity & + = node%daughter1%multiplicity & + + node%daughter2%multiplicity + node%n_resonances & + = node%daughter1%n_resonances & + + node%daughter2%n_resonances + node%n_off_shell & + = node%daughter1%n_off_shell & + + node%daughter2%n_off_shell + node%n_log_enhanced & + = node%daughter1%n_log_enhanced & + + node%daughter2%n_log_enhanced + node%n_t_channel & + = node%daughter1%n_t_channel & + + node%daughter2%n_t_channel + if (node%n_off_shell > feyngraph_set%phs_par%off_shell) then + node%keep = .false. + kingraph%keep = .false.; call kingraph%tree%final (); return + else if (node%n_t_channel > feyngraph_set%phs_par%t_channel) then + node%keep = .false. + kingraph%keep = .false.; call kingraph%tree%final (); return + else + kingraph%grove_prop%multiplicity = node%multiplicity + kingraph%grove_prop%n_resonances = node%n_resonances + kingraph%grove_prop%n_off_shell = node%n_off_shell + kingraph%grove_prop%n_log_enhanced = node%n_log_enhanced + kingraph%grove_prop%n_t_channel = node%n_t_channel + end if + end if + end if + contains + subroutine beam_decay (fatal_beam_decay) + logical, intent(in) :: fatal_beam_decay + write (msg_buffer, "(1x,A,1x,'->',1x,A,1x,A)") & + t_node%particle%particle_label, & + node%particle%particle_label, & + s_node%particle%particle_label + call msg_message + write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") & + t_node%particle%particle_label, t_node%particle%mass + call msg_message + write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") & + node%particle%particle_label, node%particle%mass + call msg_message + write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") & + s_node%particle%particle_label, s_node%particle%mass + call msg_message + if (fatal_beam_decay) then + call msg_fatal (" Phase space: Initial beam particle can decay") + else + call msg_warning (" Phase space: Initial beam particle can decay") + end if + end subroutine beam_decay + end subroutine node_compute_t_line - integer, parameter, public :: SQRTS_FIXED = 1 - integer, parameter, public :: SQRTS_VAR = 2 +@ %def node_compute_t_line +@ After all pure s-channel subdiagrams have already been created from the +corresponding [[f_nodes]] and mappings have been determined for their +nodes, we complete the calculations here. In a first step, the +[[kingraphs]] have to be created on the basis of the existing +[[k_nodes]], which means in particular that a [[feyngraph]] can give +rise to several [[kingraphs]] which will all be attached to the linked +list of the [[feyngraph]]. The calculations which remain are of different +kinds for decay and scattering processes. In a decay process the +kinematical calculations have to be done for the [[root]] node. In a +scattering process, after the creation of [[kingraphs]] in the first +step, there will be only [[kingraphs]] with the first incoming particle +as the [[root]] of the tree. For these graphs the [[inverse]] variable +has the value [[.false.]]. Before performing any calculations on these +graphs we make a so-called inverse copy of the graph (see below), which +will also be attached to the linked list. Since the s-channel subgraph +calculations have already been completed, only the t-line computations +remain. +<>= + procedure :: make_inverse_kingraphs => feyngraph_make_inverse_kingraphs +<>= + module subroutine feyngraph_make_inverse_kingraphs (feyngraph) + class(feyngraph_t), intent(inout) :: feyngraph + end subroutine feyngraph_make_inverse_kingraphs +<>= + module subroutine feyngraph_make_inverse_kingraphs (feyngraph) + class(feyngraph_t), intent(inout) :: feyngraph + type(kingraph_t), pointer :: current + current => feyngraph%kin_first + do while (associated (current)) + if (current%inverse) exit + call current%make_inverse_copy (feyngraph) + current => current%next + end do + end subroutine feyngraph_make_inverse_kingraphs - real(default), parameter :: xi_tilde_test_soft = 0.00001_default - real(default), parameter :: xi_tilde_test_coll = 0.5_default - real(default), parameter :: y_test_soft = 0.5_default - real(default), parameter :: y_test_coll = 0.9999999_default - !!! for testing EW singularities: y_test_coll = 0.99999999_default +@ %def feyngraph_make_inverse_kingraphs +<>= + procedure :: compute_mappings => feyngraph_compute_mappings +<>= + module subroutine feyngraph_compute_mappings (feyngraph, feyngraph_set) + class(feyngraph_t), intent(inout) :: feyngraph + type(feyngraph_set_t), intent(inout) :: feyngraph_set + end subroutine feyngraph_compute_mappings +<>= + module subroutine feyngraph_compute_mappings (feyngraph, feyngraph_set) + class(feyngraph_t), intent(inout) :: feyngraph + type(feyngraph_set_t), intent(inout) :: feyngraph_set + type(kingraph_t), pointer :: current + current => feyngraph%kin_first + do while (associated (current)) + if (feyngraph_set%process_type == DECAY) then + call kingraph_assign_mappings_s (feyngraph, current, feyngraph_set) + else if (feyngraph_set%process_type == SCATTERING) then + call kingraph_compute_mappings_t_line & + (feyngraph, current, feyngraph_set) + end if + current => current%next + end do + end subroutine feyngraph_compute_mappings -@ -@ Very soft or collinear phase-space points can become a problem for -matrix elements providers, as some scalar products cannot be evaluated -properly. Here, a nonsensical result can spoil the whole integration. -We therefore check the scalar products appearing to be below a certain -tolerance.\\ -Naturally, this happens very rarely but for some processes, -setting [[?test_coll_limit = true]] and/or [[?test_soft_limit = true]] -leads to all phase space points beeing discarded by this routine. -<>= - public :: check_scalar_products -<>= - function check_scalar_products (p) result (valid) - logical :: valid - type(vector4_t), intent(in), dimension(:) :: p - real(default), parameter :: tolerance = 1E-7_default - !!! for testing EW singularities: tolerance = 5E-9_default - integer :: i, j - valid = .true. - do i = 1, size (p) - do j = i, size (p) - if (i /= j) then - if (abs(p(i) * p(j)) < tolerance) then - valid = .false. - exit +@ %def feyngraph_compute_mappings +@ Here we control the mapping calculations for the nodes of s-channel +subgraphs. We start with the nodes with the smallest number of subtree +nodes and always increase this number by two because nodes have exactly +zero or two daughter nodes. We create the [[k_nodes]] using the +[[k_node_list]] of each [[f_node]]. The number of nodes which have to +be created depends of the number of existing daughter nodes, which means +that we have to create a node for each combination of existing and +valid (the ones which we [[keep]]) daughter nodes. If the node +corresponds to an external particle, we create only one node, since +there are no daughter nodes. If the particle is not external and +the daughter [[f_nodes]] do not contain any valid [[k_nodes]], we do +not create a new [[k_nodes]] either. When the calculations for all nodes +with the same number of subtree nodes have been completed, we compare +the valid nodes to eliminate equivalences (see below). +<>= + subroutine f_node_list_compute_mappings_s (feyngraph_set) + type(feyngraph_set_t), intent(inout) :: feyngraph_set + type(f_node_ptr_t), dimension(:), allocatable :: set + type(k_node_ptr_t), dimension(:), allocatable :: k_set + type(k_node_entry_t), pointer :: k_entry + type(f_node_entry_t), pointer :: current + type(k_node_list_t), allocatable :: compare_list + integer :: n_entries + integer :: pos + integer :: i, j, k + do i = 1, feyngraph_set%f_node_list%max_tree_size - 2, 2 +!!! Counter number of f_nodes with subtree size i for s channel calculations + n_entries = 0 + if (feyngraph_set%use_dag) then + do j=1, feyngraph_set%dag%n_nodes + if (allocated (feyngraph_set%dag%node(j)%f_node)) then + do k=1, size(feyngraph_set%dag%node(j)%f_node) + if (associated (feyngraph_set%dag%node(j)%f_node(k)%node)) then + if (.not. (feyngraph_set%dag%node(j)%f_node(k)%node%incoming & + .or. feyngraph_set%dag%node(j)%f_node(k)%node%t_line) & + .and. feyngraph_set%dag%node(j)%f_node(k)%node%n_subtree_nodes == i) then + n_entries = n_entries + 1 + end if + end if + end do end if - end if + end do + else + current => feyngraph_set%f_node_list%first + do while (associated (current)) + if (.not. (current%node%incoming .or. current%node%t_line) & + .and. current%node%n_subtree_nodes == i) then + n_entries = n_entries + 1 + end if + current => current%next + end do + end if + if (n_entries == 0) exit +!!! Create a temporary k node list for comparison + allocate (set(n_entries)) + pos = 0 + if (feyngraph_set%use_dag) then + do j=1, feyngraph_set%dag%n_nodes + if (allocated (feyngraph_set%dag%node(j)%f_node)) then + do k=1, size(feyngraph_set%dag%node(j)%f_node) + if (associated (feyngraph_set%dag%node(j)%f_node(k)%node)) then + if (.not. (feyngraph_set%dag%node(j)%f_node(k)%node%incoming & + .or. feyngraph_set%dag%node(j)%f_node(k)%node%t_line) & + .and. feyngraph_set%dag%node(j)%f_node(k)%node%n_subtree_nodes == i) then + pos = pos + 1 + set(pos)%node => feyngraph_set%dag%node(j)%f_node(k)%node + end if + end if + end do + end if + end do + else + current => feyngraph_set%f_node_list%first + do while (associated (current)) + if (.not. (current%node%incoming .or. current%node%t_line) & + .and. current%node%n_subtree_nodes == i) then + pos = pos + 1 + set(pos)%node => current%node + end if + current => current%next + end do + end if + allocate (compare_list) + compare_list%observer = .true. + do j = 1, n_entries + call k_node_init_from_f_node (set(j)%node, k_set, & + feyngraph_set) + if (allocated (k_set)) deallocate (k_set) + end do + !$OMP PARALLEL DO PRIVATE (k_entry) + do j = 1, n_entries + k_entry => set(j)%node%k_node_list%first + do while (associated (k_entry)) + call node_assign_mapping_s(feyngraph_set%first, k_entry%node, feyngraph_set) + k_entry => k_entry%next + end do end do + !$OMP END PARALLEL DO + do j = 1, size (set) + k_entry => set(j)%node%k_node_list%first + do while (associated (k_entry)) + if (k_entry%node%keep) then + if (k_entry%node%mapping == NO_MAPPING .or. k_entry%node%mapping == NONRESONANT) then + call compare_list%add_pointer (k_entry%node) + end if + end if + k_entry => k_entry%next + end do + end do + deallocate (set) + call compare_list%check_subtree_equivalences(feyngraph_set%model) + call compare_list%final + deallocate (compare_list) end do - end function check_scalar_products - -@ %def check_scalar_products -@ [[xi_min]] should be set to a non-zero value in order to avoid -phase-space points with [[p_real(emitter) = 0]]. -<>= - public :: phs_fks_generator_t -<>= - type :: phs_fks_generator_t - integer, dimension(:), allocatable :: emitters - type(real_kinematics_t), pointer :: real_kinematics => null() - type(isr_kinematics_t), pointer :: isr_kinematics => null() - integer :: n_in - real(default) :: xi_min - real(default) :: y_max - real(default) :: sqrts - real(default) :: E_gluon - real(default) :: mrec2 - real(default), dimension(:), allocatable :: m2 - logical :: massive_phsp = .false. - logical, dimension(:), allocatable :: is_massive - logical :: singular_jacobian = .false. - integer :: i_fsr_first = -1 - type(resonance_contributors_t), dimension(:), allocatable :: resonance_contributors !!! Put somewhere else? - integer :: mode = GEN_REAL_PHASE_SPACE - contains - <> - end type phs_fks_generator_t - -@ %def phs_fks_generator_t -@ -<>= - procedure :: connect_kinematics => phs_fks_generator_connect_kinematics -<>= - subroutine phs_fks_generator_connect_kinematics & - (generator, isr_kinematics, real_kinematics, massive_phsp) - class(phs_fks_generator_t), intent(inout) :: generator - type(isr_kinematics_t), intent(in), pointer :: isr_kinematics - type(real_kinematics_t), intent(in), pointer :: real_kinematics - logical, intent(in) :: massive_phsp - generator%real_kinematics => real_kinematics - generator%isr_kinematics => isr_kinematics - generator%massive_phsp = massive_phsp - end subroutine phs_fks_generator_connect_kinematics + end subroutine f_node_list_compute_mappings_s -@ %def phs_fks_generator_connect_kinematics +@ %def f_node_list_compute_mappings_s @ -<>= - procedure :: compute_isr_kinematics => phs_fks_generator_compute_isr_kinematics -<>= - subroutine phs_fks_generator_compute_isr_kinematics (generator, r, p_in) - class(phs_fks_generator_t), intent(inout) :: generator - real(default), intent(in) :: r - type(vector4_t), dimension(2), intent(in), optional :: p_in - integer :: em - type(vector4_t), dimension(2) :: p +\subsection{Fill the grove list} +Find the [[grove]] within the [[grove_list]] for a [[kingraph]] for +which the kinematical calculations and mapping assignments have been completed. The [[groves]] +are defined by the [[grove_prop]] entries and the value of the resonance +hash ([[res_hash]]). Whenever a matching grove does not exist, we +create one. In a first step we consider only part of the grove properties +(see [[grove_prop_match]]) and the resonance hash is ignored, which leads +to a preliminary grove list. In the end all numbers in [[grove_prop]] as +well as the resonance hash are compared, i.e. we create a new +[[grove_list]]. +<>= + procedure :: get_grove => grove_list_get_grove +<>= + module subroutine grove_list_get_grove (grove_list, kingraph, & + return_grove, preliminary) + class(grove_list_t), intent(inout) :: grove_list + type(kingraph_t), intent(in), pointer :: kingraph + type(grove_t), intent(inout), pointer :: return_grove + logical, intent(in) :: preliminary + end subroutine grove_list_get_grove +<>= + module subroutine grove_list_get_grove (grove_list, kingraph, & + return_grove, preliminary) + class(grove_list_t), intent(inout) :: grove_list + type(kingraph_t), intent(in), pointer :: kingraph + type(grove_t), intent(inout), pointer :: return_grove + logical, intent(in) :: preliminary + type(grove_t), pointer :: current_grove + return_grove => null () + if (.not. associated(grove_list%first)) then + allocate (grove_list%first) + grove_list%first%grove_prop = kingraph%grove_prop + return_grove => grove_list%first + return + end if + current_grove => grove_list%first + do while (associated (current_grove)) + if ((preliminary .and. & + (current_grove%grove_prop .match. kingraph%grove_prop)) .or. & + (.not. preliminary .and. & + current_grove%grove_prop == kingraph%grove_prop)) then + return_grove => current_grove + exit + else if (.not. associated (current_grove%next)) then + allocate (current_grove%next) + current_grove%next%grove_prop = kingraph%grove_prop + if (size (kingraph%tree%bc) < 9) & + current_grove%compare_tree%depth = 1 + return_grove => current_grove%next + exit + end if + if (associated (current_grove%next)) then + current_grove => current_grove%next + end if + end do + end subroutine grove_list_get_grove - if (present (p_in)) then - p = p_in - else - p = generator%real_kinematics%p_born_lab%phs_point(1)%select ([1,2]) +@ %def grove_list_get_grove +@ Add a valid [[kingraph]] to a [[grove_list]]. We first look for the +[[grove]] which has the grove properties of the [[kingraph]]. If no such +[[grove]] exists so far, it is created. +<>= + procedure :: add_kingraph => grove_list_add_kingraph +<>= + module subroutine grove_list_add_kingraph (grove_list, kingraph, & + preliminary, check, model) + class(grove_list_t), intent(inout) :: grove_list + type(kingraph_t), pointer, intent(inout) :: kingraph + logical, intent(in) :: preliminary + logical, intent(in) :: check + type(model_data_t), optional, intent(in) :: model + end subroutine grove_list_add_kingraph +<>= + module subroutine grove_list_add_kingraph (grove_list, kingraph, & + preliminary, check, model) + class(grove_list_t), intent(inout) :: grove_list + type(kingraph_t), pointer, intent(inout) :: kingraph + logical, intent(in) :: preliminary + logical, intent(in) :: check + type(model_data_t), optional, intent(in) :: model + type(grove_t), pointer :: grove + type(kingraph_t), pointer :: current + integer, save :: index = 0 + grove => null () + current => null () + if (preliminary) then + if (kingraph%index == 0) then + index = index + 1 + kingraph%index = index + end if end if + call grove_list%get_grove (kingraph, grove, preliminary) + if (check) then + call grove%compare_tree%check_kingraph (kingraph, model, preliminary) + end if + if (kingraph%keep) then + if (associated (grove%first)) then + grove%last%grove_next => kingraph + grove%last => kingraph + else + grove%first => kingraph + grove%last => kingraph + end if + end if + end subroutine grove_list_add_kingraph - associate (isr_kinematics => generator%isr_kinematics) - do em = 1, 2 - isr_kinematics%x(em) = p(em)%p(0) / isr_kinematics%beam_energy(em) - isr_kinematics%z(em) = one - (one - isr_kinematics%x(em)) * r - isr_kinematics%jacobian(em) = one - isr_kinematics%x(em) +@ %ref grove_list_add_kingraph +@ For a given [[feyngraph]] we store all valid [[kingraphs]] in the +[[grove_list]]. +<>= + procedure :: add_feyngraph => grove_list_add_feyngraph +<>= + module subroutine grove_list_add_feyngraph (grove_list, feyngraph, model) + class(grove_list_t), intent(inout) :: grove_list + type(feyngraph_t), intent(inout) :: feyngraph + type(model_data_t), intent(in) :: model + end subroutine grove_list_add_feyngraph +<>= + module subroutine grove_list_add_feyngraph (grove_list, feyngraph, model) + class(grove_list_t), intent(inout) :: grove_list + type(feyngraph_t), intent(inout) :: feyngraph + type(model_data_t), intent(in) :: model + type(kingraph_t), pointer :: current_kingraph, add_kingraph + do while (associated (feyngraph%kin_first)) + if (feyngraph%kin_first%keep) then + add_kingraph => feyngraph%kin_first + feyngraph%kin_first => feyngraph%kin_first%next + add_kingraph%next => null () + call grove_list%add_kingraph (kingraph=add_kingraph, & + preliminary=.true., check=.true., model=model) + else + exit + end if + end do + if (associated (feyngraph%kin_first)) then + current_kingraph => feyngraph%kin_first + do while (associated (current_kingraph%next)) + if (current_kingraph%next%keep) then + add_kingraph => current_kingraph%next + current_kingraph%next => current_kingraph%next%next + add_kingraph%next => null () + call grove_list%add_kingraph (kingraph=add_kingraph, & + preliminary=.true., check=.true., model=model) + else + current_kingraph => current_kingraph%next + end if end do - isr_kinematics%sqrts_born = (p(1) + p(2))**1 - end associate - end subroutine phs_fks_generator_compute_isr_kinematics - -@ %def phs_fks_generator_compute_isr_kinematics -@ -<>= - procedure :: final => phs_fks_generator_final -<>= - subroutine phs_fks_generator_final (generator) - class(phs_fks_generator_t), intent(inout) :: generator - if (allocated (generator%emitters)) deallocate (generator%emitters) - if (associated (generator%real_kinematics)) nullify (generator%real_kinematics) - if (associated (generator%isr_kinematics)) nullify (generator%isr_kinematics) - if (allocated (generator%m2)) deallocate (generator%m2) - generator%massive_phsp = .false. - if (allocated (generator%is_massive)) deallocate (generator%is_massive) - generator%singular_jacobian = .false. - generator%i_fsr_first = -1 - if (allocated (generator%resonance_contributors)) & - deallocate (generator%resonance_contributors) - generator%mode = GEN_REAL_PHASE_SPACE - end subroutine phs_fks_generator_final + end if + end subroutine grove_list_add_feyngraph -@ %def phs_fks_generator_final -@ A resonance phase space is uniquely specified via the resonance contributors and the -corresponding emitters. The [[phs_identifier]] type also checks whether -the given contributor-emitter configuration has already been evaluated to -avoid duplicate computations. -<>= - public :: phs_identifier_t -<>= - type :: phs_identifier_t - integer, dimension(:), allocatable :: contributors - integer :: emitter = -1 - logical :: evaluated = .false. - contains - <> - end type phs_identifier_t +@ %def grove_list_add_feyngraph +@ Compare two [[grove_prop]] objects. The [[.match.]] operator is used +for preliminary groves in which the [[kingraphs]] share only the 3 +numbers [[n_resonances]], [[n_log_enhanced]] and [[n_t_channel]]. These +groves are only used for comparing the kingraphs, because only graphs +within these preliminary groves can be equivalent (the numbers which are +compared here are unambigously fixed by the combination of mappings in +these channels). +<>= + interface operator (.match.) + module procedure grove_prop_match + end interface operator (.match.) +<>= + module function grove_prop_match (grove_prop1, grove_prop2) & + result (gp_match) + type(grove_prop_t), intent(in) :: grove_prop1 + type(grove_prop_t), intent(in) :: grove_prop2 + logical :: gp_match + end function grove_prop_match +<>= + module function grove_prop_match (grove_prop1, grove_prop2) result (gp_match) + type(grove_prop_t), intent(in) :: grove_prop1 + type(grove_prop_t), intent(in) :: grove_prop2 + logical :: gp_match + gp_match = (grove_prop1%n_resonances == grove_prop2%n_resonances) & + .and. (grove_prop1%n_log_enhanced == grove_prop2%n_log_enhanced) & + .and. (grove_prop1%n_t_channel == grove_prop2%n_t_channel) + end function grove_prop_match -@ %def phs_identifier_t -@ -<>= - generic :: init => init_from_emitter, init_from_emitter_and_contributors - procedure :: init_from_emitter => phs_identifier_init_from_emitter - procedure :: init_from_emitter_and_contributors & - => phs_identifier_init_from_emitter_and_contributors -<>= - subroutine phs_identifier_init_from_emitter (phs_id, emitter) - class(phs_identifier_t), intent(out) :: phs_id - integer, intent(in) :: emitter - phs_id%emitter = emitter - end subroutine phs_identifier_init_from_emitter +@ %def grove_prop_match +@ The equal operator on the other hand will be used when all valid +[[kingraphs]] have been created and mappings have been determined, to +split up the existing (preliminary) grove list, i.e. to create new +groves which are determined by all entries in [[grove_prop_t]]. +<>= + interface operator (==) + module procedure grove_prop_equal + end interface operator (==) +<>= + module function grove_prop_equal (grove_prop1, grove_prop2) & + result (gp_equal) + type(grove_prop_t), intent(in) :: grove_prop1 + type(grove_prop_t), intent(in) :: grove_prop2 + logical :: gp_equal + end function grove_prop_equal +<>= + module function grove_prop_equal (grove_prop1, grove_prop2) result (gp_equal) + type(grove_prop_t), intent(in) :: grove_prop1 + type(grove_prop_t), intent(in) :: grove_prop2 + logical :: gp_equal + gp_equal = (grove_prop1%res_hash == grove_prop2%res_hash) & + .and. (grove_prop1%n_resonances == grove_prop2%n_resonances) & + .and. (grove_prop1%n_log_enhanced == grove_prop2%n_log_enhanced) & + .and. (grove_prop1%n_off_shell == grove_prop2%n_off_shell) & + .and. (grove_prop1%multiplicity == grove_prop2%multiplicity) & + .and. (grove_prop1%n_t_channel == grove_prop2%n_t_channel) + end function grove_prop_equal - subroutine phs_identifier_init_from_emitter_and_contributors & - (phs_id, emitter, contributors) - class(phs_identifier_t), intent(out) :: phs_id - integer, intent(in) :: emitter - integer, intent(in), dimension(:) :: contributors - allocate (phs_id%contributors (size (contributors))) - phs_id%contributors = contributors - phs_id%emitter = emitter - end subroutine phs_identifier_init_from_emitter_and_contributors -@ %def phs_identifier_init_from_emitter -@ %def phs_identifier_init_from_emitter_and_contributors +@ %def grove_prop_equal @ -<>= - procedure :: check => phs_identifier_check -<>= - function phs_identifier_check (phs_id, emitter, contributors) result (check) - logical :: check - class(phs_identifier_t), intent(in) :: phs_id - integer, intent(in) :: emitter - integer, intent(in), dimension(:), optional :: contributors - check = phs_id%emitter == emitter - if (present (contributors)) then - if (.not. allocated (phs_id%contributors)) & - call msg_fatal ("Phs identifier: contributors not allocated!") - check = check .and. all (phs_id%contributors == contributors) +\subsection{Remove equivalent channels} +Here we define the equivalence condition for completed [[kingraphs]]. +The aim is to keep those [[kingraphs]] which describe the strongest +peaks of the amplitude. The [[bincodes]] and [[mappings]] have to be +the same for an equivalence, but the [[pdgs]] can be different. At +the same time we check if the trees are exacly the same (up to the +sign of pdg codes) in which case we do not keep both of them. This +can be the case when the incoming particles are the same or their +mutual anti-particles and there are no t-channel lines in the +Feynman diagram to which the kingraph belongs. +<>= + integer, parameter :: EMPTY = -999 +<>= + function kingraph_eqv (kingraph1, kingraph2) result (eqv) + type(kingraph_t), intent(in) :: kingraph1 + type(kingraph_t), intent(inout) :: kingraph2 + logical :: eqv + integer :: i + logical :: equal + eqv = .false. + do i = kingraph1%tree%n_entries, 1, -1 + if (kingraph1%tree%bc(i) /= kingraph2%tree%bc(i)) return + end do + do i = kingraph1%tree%n_entries, 1, -1 + if ( .not. (kingraph1%tree%mapping(i) == kingraph2%tree%mapping(i) & + .or. ((kingraph1%tree%mapping(i) == NO_MAPPING .or. & + kingraph1%tree%mapping(i) == NONRESONANT) .and. & + (kingraph2%tree%mapping(i) == NO_MAPPING .or. & + kingraph2%tree%mapping(i) == NONRESONANT)))) return + end do + equal = .true. + do i = kingraph1%tree%n_entries, 1, -1 + if (abs(kingraph1%tree%pdg(i)) /= abs(kingraph2%tree%pdg(i))) then + equal = .false.; + select case (kingraph1%tree%mapping(i)) + case (S_CHANNEL, RADIATION) + select case (kingraph2%tree%mapping(i)) + case (S_CHANNEL, RADIATION) + return + end select + end select + end if + end do + if (equal) then + kingraph2%keep = .false. + call kingraph2%tree%final () + else + eqv = .true. end if - end function phs_identifier_check + end function kingraph_eqv -@ %def phs_identifier_check -@ -<>= - procedure :: write => phs_identifier_write -<>= - subroutine phs_identifier_write (phs_id, unit) - class(phs_identifier_t), intent(in) :: phs_id - integer, intent(in), optional :: unit - integer :: u, i - u = given_output_unit (unit); if (u < 0) return - write (u, '(A)') 'phs_identifier: ' - write (u, '(A,1X,I1)') 'Emitter: ', phs_id%emitter - if (allocated (phs_id%contributors)) then - write (u, '(A)', advance = 'no') 'Resonance contributors: ' - do i = 1, size (phs_id%contributors) - write (u, '(I1,1X)', advance = 'no') phs_id%contributors(i) +@ %def kingraph_eqv +@ Select between two [[kingraphs]] which fulfill the equivalence +condition above. This is done by comparing the [[pdg]] values of the +[[tree]] for increasing bincode. If the particles are different at +some place, we usually choose the one which would be returned first by the +subroutine [[match_vertex]] of the model for the daughter [[pdg]] codes. +Since we work here only on the basis of the the [[trees]] of the +completed [[kingraphs]], we have to use the [[bc]] array to determine +the positions of the daughter nodes' entries in the array. The graph +which has to be kept should correspond to the stronger peak at the place +which is compared. +<>= + subroutine kingraph_select (kingraph1, kingraph2, model, preliminary) + type(kingraph_t), intent(inout) :: kingraph1 + type(kingraph_t), intent(inout) :: kingraph2 + type(model_data_t), intent(in) :: model + logical, intent(in) :: preliminary + integer(TC), dimension(:), allocatable :: tmp_bc, daughter_bc + integer, dimension(:), allocatable :: tmp_pdg, daughter_pdg + integer, dimension (:), allocatable :: pdg_match + integer :: i, j + integer :: n_ext1, n_ext2 + if (kingraph_eqv (kingraph1, kingraph2)) then + if (.not. preliminary) then + kingraph2%keep = .false.; call kingraph2%tree%final () + return + end if + do i=1, size (kingraph1%tree%bc) + if (abs(kingraph1%tree%pdg(i)) /= abs(kingraph2%tree%pdg(i))) then + if (kingraph1%tree%mapping(i) /= EXTERNAL_PRT) then + n_ext1 = popcnt (kingraph1%tree%bc(i)) + n_ext2 = n_ext1 + do j=i+1, size (kingraph1%tree%bc) + if (abs(kingraph1%tree%pdg(j)) /= abs(kingraph2%tree%pdg(j))) then + n_ext2 = popcnt (kingraph1%tree%bc(j)) + if (n_ext2 < n_ext1) exit + end if + end do + if (n_ext2 < n_ext1) cycle + allocate (tmp_bc(i-1)) + tmp_bc = kingraph1%tree%bc(:i-1) + allocate (tmp_pdg(i-1)) + tmp_pdg = kingraph1%tree%pdg(:i-1) + do j=i-1, 1, - 1 + where (iand (tmp_bc(:j-1),tmp_bc(j)) /= 0 & + .or. iand(tmp_bc(:j-1),kingraph1%tree%bc(i)) == 0) + tmp_bc(:j-1) = 0 + tmp_pdg(:j-1) = 0 + endwhere + end do + allocate (daughter_bc(size(pack(tmp_bc, tmp_bc /= 0)))) + daughter_bc = pack (tmp_bc, tmp_bc /= 0) + allocate (daughter_pdg(size(pack(tmp_pdg, tmp_pdg /= 0)))) + daughter_pdg = pack (tmp_pdg, tmp_pdg /= 0) + if (size (daughter_pdg) == 2) then + call model%match_vertex(daughter_pdg(1), daughter_pdg(2), pdg_match) + end if + do j=1, size (pdg_match) + if (abs(pdg_match(j)) == abs(kingraph1%tree%pdg(i))) then + kingraph2%keep = .false.; call kingraph2%tree%final () + exit + else if (abs(pdg_match(j)) == abs(kingraph2%tree%pdg(i))) then + kingraph1%keep = .false.; call kingraph1%tree%final () + exit + end if + end do + deallocate (tmp_bc, tmp_pdg, daughter_bc, daughter_pdg, pdg_match) + if (.not. (kingraph1%keep .and. kingraph2%keep)) exit + end if + end if end do - else - write (u, '(A)') 'No Contributors allocated' end if - end subroutine phs_identifier_write - -@ %def phs_identifier_write -@ -<>= - public :: check_for_phs_identifier -<>= - subroutine check_for_phs_identifier (phs_id, n_in, emitter, contributors, phs_exist, i_phs) - type(phs_identifier_t), intent(in), dimension(:) :: phs_id - integer, intent(in) :: n_in, emitter - integer, intent(in), dimension(:), optional :: contributors - logical, intent(out) :: phs_exist - integer, intent(out) :: i_phs - integer :: i - phs_exist = .false. - i_phs = -1 - do i = 1, size (phs_id) - if (phs_id(i)%emitter < 0) then - i_phs = i - exit - end if - phs_exist = phs_id(i)%emitter == emitter - if (present (contributors)) & - phs_exist = phs_exist .and. all (phs_id(i)%contributors == contributors) - if (phs_exist) then - i_phs = i - exit - end if - end do - end subroutine check_for_phs_identifier - -@ %def check_for_phs_identifier -@ -@ The fks phase space type contains the wood phase space and -separately the in- and outcoming momenta for the real process and the -corresponding Born momenta. Additionally, there are the variables -$\xi$,$\xi_{max}$, $y$ and $\phi$ which are used to create the real -phase space, as well as the jacobian and its corresponding soft and -collinear limit. Lastly, the array \texttt{ch\_to\_em} connects each -channel with an emitter. -<>= - public :: phs_fks_t -<>= - type, extends (phs_wood_t) :: phs_fks_t - integer :: mode = PHS_MODE_UNDEFINED - type(vector4_t), dimension(:), allocatable :: p_born - type(vector4_t), dimension(:), allocatable :: q_born - type(vector4_t), dimension(:), allocatable :: p_real - type(vector4_t), dimension(:), allocatable :: q_real - type(vector4_t), dimension(:), allocatable :: p_born_tot - type(phs_fks_generator_t) :: generator - real(default) :: r_isr - type(phs_identifier_t), dimension(:), allocatable :: phs_identifiers - contains - <> - end type phs_fks_t - -@ %def phs_fks_t -@ -<>= - - interface compute_beta - module procedure compute_beta_massless - module procedure compute_beta_massive - end interface + end subroutine kingraph_select - interface get_xi_max_fsr - module procedure get_xi_max_fsr_massless - module procedure get_xi_max_fsr_massive - end interface +@ %def kingraph_select +@ At the beginning we do not care about the resonance hash, but only +about part of the grove properties, which is defined in +[[grove_prop_match]]. In these resulting preliminary groves the kingraphs +can be equivalent, i.e. we do not have to compare all graphs with each +other but only all graphs within each of these preliminary groves. In the +end we create a new grove list where the grove properties of the +[[kingraphs]] within a [[grove]] have to be exactly the same and in +addition the groves are distinguished by the resonance hash values. Here +the kingraphs are not compared any more, which means that the number of +channels is not reduced any more. +<>= + procedure :: merge => grove_list_merge +<>= + module subroutine grove_list_merge (target_list, grove_list, model, & + prc_component) + class(grove_list_t), intent(inout) :: target_list + type(grove_list_t), intent(inout) :: grove_list + type(model_data_t), intent(in) :: model + integer, intent(in) :: prc_component + end subroutine grove_list_merge +<>= + module subroutine grove_list_merge (target_list, grove_list, model, & + prc_component) + class(grove_list_t), intent(inout) :: target_list + type(grove_list_t), intent(inout) :: grove_list + type(model_data_t), intent(in) :: model + integer, intent(in) :: prc_component + type(grove_t), pointer :: current_grove + type(kingraph_t), pointer :: current_graph + current_grove => grove_list%first + do while (associated (current_grove)) + do while (associated (current_grove%first)) + current_graph => current_grove%first + current_grove%first => current_grove%first%grove_next + current_graph%grove_next => null () + if (current_graph%keep) then + current_graph%prc_component = prc_component + call target_list%add_kingraph(kingraph=current_graph, & + preliminary=.false., check=.true., model=model) + else + call current_graph%final () + deallocate (current_graph) + end if + end do + current_grove => current_grove%next + end do + end subroutine grove_list_merge -@ %def interfaces -@ -<>= - procedure :: write => phs_fks_write -<>= - subroutine phs_fks_write (object, unit, verbose) - class(phs_fks_t), intent(in) :: object - integer, intent(in), optional :: unit - logical, intent(in), optional :: verbose - integer :: u, i, n_id - u = given_output_unit (unit) - call object%base_write () - n_id = size (object%phs_identifiers) - if (n_id == 0) then - write (u, "(A)") "No phs identifiers allocated! " - else - do i = 1, n_id - call object%phs_identifiers(i)%write (u) +@ %def grove_list_merge +@ Recreate a grove list where we have different groves for different +resonance hashes. +<>= + procedure :: rebuild => grove_list_rebuild +<>= + module subroutine grove_list_rebuild (grove_list) + class(grove_list_t), intent(inout) :: grove_list + end subroutine grove_list_rebuild +<>= + module subroutine grove_list_rebuild (grove_list) + class(grove_list_t), intent(inout) :: grove_list + type(grove_list_t) :: tmp_list + type(grove_t), pointer :: current_grove + type(grove_t), pointer :: remove_grove + type(kingraph_t), pointer :: current_graph + type(kingraph_t), pointer :: next_graph + tmp_list%first => grove_list%first + grove_list%first => null () + current_grove => tmp_list%first + do while (associated (current_grove)) + current_graph => current_grove%first + do while (associated (current_graph)) + call current_graph%assign_resonance_hash () + next_graph => current_graph%grove_next + current_graph%grove_next => null () + if (current_graph%keep) then + call grove_list%add_kingraph (kingraph=current_graph, & + preliminary=.false., check=.false.) + end if + current_graph => next_graph end do - end if - end subroutine phs_fks_write + current_grove => current_grove%next + end do + call tmp_list%final + end subroutine grove_list_rebuild -@ %def phs_fks_write -@ Initializer for the phase space. Calls the initialization of the -corresponding Born phase space, sets up the -channel-emitter-association and allocates space for the momenta. -<>= - procedure :: init => phs_fks_init -<>= - subroutine phs_fks_init (phs, phs_config) - class(phs_fks_t), intent(out) :: phs - class(phs_config_t), intent(in), target :: phs_config +@ %def grove_list_rebuild +@ +\subsection{Write the phase-space file} +The phase-space file is written from the graphs which survive the +calculations and equivalence checks and are in the grove list. It is +written grove by grove. The output should be the same as in the +corresponding procedure [[cascade_set_write_file_format]] of +[[cascades]], up to the order of groves and channels. +<>= + public :: feyngraph_set_write_file_format +<>= + module subroutine feyngraph_set_write_file_format (feyngraph_set, u) + type(feyngraph_set_t), intent(in) :: feyngraph_set + integer, intent(in) :: u + end subroutine feyngraph_set_write_file_format +<>= + module subroutine feyngraph_set_write_file_format (feyngraph_set, u) + type(feyngraph_set_t), intent(in) :: feyngraph_set + integer, intent(in) :: u + type(grove_t), pointer :: grove + integer :: channel_number + integer :: grove_number + channel_number = 0 + grove_number = 0 + grove => feyngraph_set%grove_list%first + do while (associated (grove)) + grove_number = grove_number + 1 + call grove%write_file_format & + (feyngraph_set, grove_number, channel_number, u) + grove => grove%next + end do + end subroutine feyngraph_set_write_file_format - call phs%base_init (phs_config) - select type (phs_config) - type is (phs_fks_config_t) - phs%config => phs_config - phs%forest = phs_config%forest +@ %def feyngraph_set_write_file_format +@ Write the relevant information of the [[kingraphs]] of a [[grove]] and +the grove properties in the file format. +<>= + procedure :: write_file_format => grove_write_file_format +<>= + recursive module subroutine grove_write_file_format & + (grove, feyngraph_set, gr_number, ch_number, u) + class(grove_t), intent(in) :: grove + type(feyngraph_set_t), intent(in) :: feyngraph_set + integer, intent(in) :: u + integer, intent(inout) :: gr_number + integer, intent(inout) :: ch_number + end subroutine grove_write_file_format +<>= + recursive module subroutine grove_write_file_format & + (grove, feyngraph_set, gr_number, ch_number, u) + class(grove_t), intent(in) :: grove + type(feyngraph_set_t), intent(in) :: feyngraph_set + integer, intent(in) :: u + integer, intent(inout) :: gr_number + integer, intent(inout) :: ch_number + type(kingraph_t), pointer :: current +1 format(3x,A,1x,40(1x,I4)) + write (u, "(A)") + write (u, "(1x,'!',1x,A,1x,I0,A)", advance='no') & + 'Multiplicity =', grove%grove_prop%multiplicity, "," + select case (grove%grove_prop%n_resonances) + case (0) + write (u, '(1x,A)', advance='no') 'no resonances, ' + case (1) + write (u, '(1x,A)', advance='no') '1 resonance, ' + case default + write (u, '(1x,I0,1x,A)', advance='no') & + grove%grove_prop%n_resonances, 'resonances, ' end select - - select type (phs) - type is (phs_fks_t) - select type (phs_config) - type is (phs_fks_config_t) - phs%mode = phs_config%mode - end select - - select case (phs%mode) - case (PHS_MODE_ADDITIONAL_PARTICLE) - phs%n_r_born = phs%config%n_par - 3 - case (PHS_MODE_COLLINEAR_REMNANT) - phs%n_r_born = phs%config%n_par - 1 - end select + write (u, '(1x,I0,1x,A)', advance='no') & + grove%grove_prop%n_log_enhanced, 'logs, ' + write (u, '(1x,I0,1x,A)', advance='no') & + grove%grove_prop%n_off_shell, 'off-shell, ' + select case (grove%grove_prop%n_t_channel) + case (0); write (u, '(1x,A)') 's-channel graph' + case (1); write (u, '(1x,A)') '1 t-channel line' + case default + write(u,'(1x,I0,1x,A)') & + grove%grove_prop%n_t_channel, 't-channel lines' end select - end subroutine phs_fks_init - -@ %def phs_fks_init -@ For real components of $2\to 1$ NLO processes we have to recompute the -flux factor as this has to be the one of the underlying Born. -<>= - procedure :: compute_flux => phs_fks_compute_flux -<>= - subroutine phs_fks_compute_flux (phs) - class(phs_fks_t), intent(inout) :: phs - call phs%compute_base_flux () - select type (config => phs%config) - type is (phs_fks_config_t) - if (config%born_2_to_1) then - phs%flux = conv * twopi & - / (2 * config%sqrts ** 2 * phs%m_out(1) ** 2) + write (u, '(1x,A,I0)') 'grove #', gr_number + current => grove%first + do while (associated (current)) + if (current%keep) then + ch_number = ch_number + 1 + call current%write_file_format (feyngraph_set, ch_number, u) end if - end select - end subroutine phs_fks_compute_flux + current => current%grove_next + end do + end subroutine grove_write_file_format -@ %def phs_fks_compute_flux -@ -<>= - procedure :: allocate_momenta => phs_fks_allocate_momenta -<>= - subroutine phs_fks_allocate_momenta (phs, phs_config, data_is_born) - class(phs_fks_t), intent(inout) :: phs - class(phs_config_t), intent(in) :: phs_config - logical, intent(in) :: data_is_born - integer :: n_out_born - allocate (phs%p_born (phs_config%n_in)) - allocate (phs%p_real (phs_config%n_in)) - select case (phs%mode) - case (PHS_MODE_ADDITIONAL_PARTICLE) - if (data_is_born) then - n_out_born = phs_config%n_out - else - n_out_born = phs_config%n_out - 1 +@ %def grove_write_file_format +@ Write the relevant information of a valid [[kingraph]] in the file +format. The information is extracted from the [[tree]]. +<>= + procedure :: write_file_format => kingraph_write_file_format +<>= + module subroutine kingraph_write_file_format & + (kingraph, feyngraph_set, ch_number, u) + class(kingraph_t), intent(in) :: kingraph + type(feyngraph_set_t), intent(in) :: feyngraph_set + integer, intent(in) :: ch_number + integer, intent(in) :: u + end subroutine kingraph_write_file_format +<>= + module subroutine kingraph_write_file_format & + (kingraph, feyngraph_set, ch_number, u) + class(kingraph_t), intent(in) :: kingraph + type(feyngraph_set_t), intent(in) :: feyngraph_set + integer, intent(in) :: ch_number + integer, intent(in) :: u + integer :: i + integer(TC) :: bincode_incoming +2 format(3X,'map',1X,I3,1X,A,1X,I9,1X,'!',1X,A) + !!! determine bincode of incoming particle from tree + bincode_incoming = maxval (kingraph%tree%bc) + write (unit=u, fmt='(1X,A,I0)') '! Channel #', ch_number + write (unit=u, fmt='(3X,A,1X)', advance='no') 'tree' + do i=1, size (kingraph%tree%bc) + if (kingraph%tree%mapping(i) >=0 & + .or. kingraph%tree%mapping(i) == NONRESONANT & + .or. (kingraph%tree%bc(i) == bincode_incoming & + .and. feyngraph_set%process_type == DECAY)) then + write (unit=u, fmt='(1X,I0)', advance='no') kingraph%tree%bc(i) end if - allocate (phs%q_born (n_out_born)) - allocate (phs%q_real (n_out_born + 1)) - allocate (phs%p_born_tot (phs_config%n_in + n_out_born)) - end select - end subroutine phs_fks_allocate_momenta - -@ %def phs_fks_allocate_momenta -@ Evaluate selected channel. First, the subroutine calls the -evaluation procedure of the underlying Born phase space, using $n_r - -3$ random numbers. Then, the remaining three random numbers are used -to create $\xi$, $y$ and $\phi$, from which the real momenta are -calculated from the Born momenta. -<>= - procedure :: evaluate_selected_channel => phs_fks_evaluate_selected_channel -<>= - subroutine phs_fks_evaluate_selected_channel (phs, c_in, r_in) - class(phs_fks_t), intent(inout) :: phs - integer, intent(in) :: c_in - real(default), intent(in), dimension(:) :: r_in - integer :: n_in - - call phs%phs_wood_t%evaluate_selected_channel (c_in, r_in) - phs%r(:,c_in) = r_in - - phs%q_defined = phs%phs_wood_t%q_defined - if (.not. phs%q_defined) return - - select case (phs%mode) - case (PHS_MODE_ADDITIONAL_PARTICLE) - n_in = phs%config%n_in - phs%p_born = phs%phs_wood_t%p - phs%q_born = phs%phs_wood_t%q - phs%p_born_tot (1: n_in) = phs%p_born - phs%p_born_tot (n_in + 1 :) = phs%q_born - call phs%set_reference_frames (.true.) - call phs%set_isr_kinematics (.true.) - case (PHS_MODE_COLLINEAR_REMNANT) - call phs%compute_isr_kinematics (r_in(phs%n_r_born + 1)) - phs%r_isr = r_in(phs%n_r_born + 1) - end select - end subroutine phs_fks_evaluate_selected_channel - -@ %def phs_fks_evaluate_selected_channel -@ -<>= - procedure :: evaluate_other_channels => phs_fks_evaluate_other_channels -<>= - subroutine phs_fks_evaluate_other_channels (phs, c_in) - class(phs_fks_t), intent(inout) :: phs - integer, intent(in) :: c_in - call phs%phs_wood_t%evaluate_other_channels (c_in) - phs%r_defined = .true. - end subroutine phs_fks_evaluate_other_channels - -@ %def phs_fks_evaluate_other_channels -@ -<>= - procedure :: get_mcpar => phs_fks_get_mcpar -<>= - subroutine phs_fks_get_mcpar (phs, c, r) - class(phs_fks_t), intent(in) :: phs - integer, intent(in) :: c - real(default), dimension(:), intent(out) :: r - r(1 : phs%n_r_born) = phs%r(1 : phs%n_r_born,c) - select case (phs%mode) - case (PHS_MODE_ADDITIONAL_PARTICLE) - r(phs%n_r_born + 1 :) = phs%r_real - case (PHS_MODE_COLLINEAR_REMNANT) - r(phs%n_r_born + 1 :) = phs%r_isr - end select - end subroutine phs_fks_get_mcpar - -@ %def phs_fks_get_mcpar -@ -<>= - procedure :: set_beam_energy => phs_fks_set_beam_energy -<>= - subroutine phs_fks_set_beam_energy (phs) - class(phs_fks_t), intent(inout) :: phs - call phs%generator%set_sqrts_hat (phs%config%sqrts) - end subroutine phs_fks_set_beam_energy - -@ %def phs_fks_set_beam_energy -@ -<>= - procedure :: set_emitters => phs_fks_set_emitters -<>= - subroutine phs_fks_set_emitters (phs, emitters) - class(phs_fks_t), intent(inout) :: phs - integer, intent(in), dimension(:), allocatable :: emitters - call phs%generator%set_emitters (emitters) - end subroutine phs_fks_set_emitters - -@ %def phs_fks_set_emitters -@ -<>= - procedure :: set_momenta => phs_fks_set_momenta -<>= - subroutine phs_fks_set_momenta (phs, p) - class(phs_fks_t), intent(inout) :: phs - type(vector4_t), intent(in), dimension(:) :: p - integer :: n_in, n_tot_born - select case (phs%mode) - case (PHS_MODE_ADDITIONAL_PARTICLE) - n_in = phs%config%n_in; n_tot_born = phs%config%n_tot - 1 - phs%p_born = p(1 : n_in) - phs%q_born = p(n_in + 1 : n_tot_born) - phs%p_born_tot = p - end select - end subroutine phs_fks_set_momenta + end do + write (unit=u, fmt='(A)', advance='yes') + do i=1, size(kingraph%tree%bc) + select case (kingraph%tree%mapping(i)) + case (NO_MAPPING, NONRESONANT, EXTERNAL_PRT) + case (S_CHANNEL) + write (unit=u, fmt=2) kingraph%tree%bc(i), 's_channel', & + kingraph%tree%pdg(i), & + trim(get_particle_name (feyngraph_set, kingraph%tree%pdg(i))) + case (T_CHANNEL) + write (unit=u, fmt=2) kingraph%tree%bc(i), 't_channel', & + abs (kingraph%tree%pdg(i)), & + trim(get_particle_name (feyngraph_set, abs(kingraph%tree%pdg(i)))) + case (U_CHANNEL) + write (unit=u, fmt=2) kingraph%tree%bc(i), 'u_channel', & + abs (kingraph%tree%pdg(i)), & + trim(get_particle_name (feyngraph_set, abs(kingraph%tree%pdg(i)))) + case (RADIATION) + write (unit=u, fmt=2) kingraph%tree%bc(i), 'radiation', & + kingraph%tree%pdg(i), & + trim(get_particle_name (feyngraph_set, kingraph%tree%pdg(i))) + case (COLLINEAR) + write (unit=u, fmt=2) kingraph%tree%bc(i), 'collinear', & + kingraph%tree%pdg(i), & + trim(get_particle_name (feyngraph_set, kingraph%tree%pdg(i))) + case (INFRARED) + write (unit=u, fmt=2) kingraph%tree%bc(i), 'infrared ', & + kingraph%tree%pdg(i), & + trim(get_particle_name (feyngraph_set, kingraph%tree%pdg(i))) + case (ON_SHELL) + write (unit=u, fmt=2) kingraph%tree%bc(i), 'on_shell ', & + kingraph%tree%pdg(i), & + trim(get_particle_name (feyngraph_set, kingraph%tree%pdg(i))) + case default + call msg_bug (" Impossible mapping mode encountered") + end select + end do + end subroutine kingraph_write_file_format -@ %def phs_fks_set_momenta -@ -<>= - procedure :: setup_masses => phs_fks_setup_masses -<>= - subroutine phs_fks_setup_masses (phs, n_tot) - class(phs_fks_t), intent(inout) :: phs - integer, intent(in) :: n_tot - call phs%generator%setup_masses (n_tot) - end subroutine phs_fks_setup_masses +@ %def kingraph_write_file_format +@ Get the particle name from the [[particle]] array of the +[[feyngraph_set]]. This is needed for the phs file creation. +<>= + function get_particle_name (feyngraph_set, pdg) result (particle_name) + type(feyngraph_set_t), intent(in) :: feyngraph_set + integer, intent(in) :: pdg + character(len=LABEL_LEN) :: particle_name + integer :: i + do i=1, size (feyngraph_set%particle) + if (feyngraph_set%particle(i)%pdg == pdg) then + particle_name = feyngraph_set%particle(i)%particle_label + exit + end if + end do + end function get_particle_name -@ %def phs_fks_setup_masses +@ %def get_particle_name @ -<>= - procedure :: get_born_momenta => phs_fks_get_born_momenta -<>= - subroutine phs_fks_get_born_momenta (phs, p) - class(phs_fks_t), intent(inout) :: phs - type(vector4_t), intent(out), dimension(:) :: p - select case (phs%mode) - case (PHS_MODE_ADDITIONAL_PARTICLE) - p(1 : phs%config%n_in) = phs%p_born - p(phs%config%n_in + 1 :) = phs%q_born - case (PHS_MODE_COLLINEAR_REMNANT) - p(1:phs%config%n_in) = phs%phs_wood_t%p - p(phs%config%n_in + 1 : ) = phs%phs_wood_t%q - end select - if (.not. phs%config%lab_is_cm) p = phs%lt_cm_to_lab * p - end subroutine phs_fks_get_born_momenta +\subsection{Invert a graph} +All Feynman diagrams given by O'Mega look like a decay. The [[feyngraph]] +which is constructed from this output also looks like a decay, where one +of the incoming particles is the decaying particle (or the root of the +tree). The calculations can in principle be done on this data structure. +However, it is also performed with the other incoming particle as +the root. The first part of the calculation is the same for both cases. +For the second part we need to transform/turn the graphs such that the +other incoming particle becomes the root. This is done by identifying +the incoming particles from the O'Mega output (the first one is simply +the root of the existing tree, the second contains [2] in the +[[particle_label]]) and the nodes/particles which connect both incoming +particles (here we set [[t_line = .true.]]). At the same time we set the +pointers [[inverse_daughter1]] and [[inverse_daughter2]] for the +corresponding node, which point to the mother node and the other daughter +of the mother node; these will be the daughters of the node in the +inverted [[feyngraph]]. +<>= + procedure :: make_invertible => feyngraph_make_invertible +<>= + module subroutine feyngraph_make_invertible (feyngraph) + class(feyngraph_t), intent(inout) :: feyngraph + end subroutine feyngraph_make_invertible +<>= + module subroutine feyngraph_make_invertible (feyngraph) + class(feyngraph_t), intent(inout) :: feyngraph + logical :: t_line_found + feyngraph%root%incoming = .true. + t_line_found = .false. + if (associated (feyngraph%root%daughter1)) then + call f_node_t_line_check (feyngraph%root%daughter1, t_line_found) + if (.not. t_line_found) then + if (associated (feyngraph%root%daughter2)) then + call f_node_t_line_check (feyngraph%root%daughter2, t_line_found) + end if + end if + end if -@ %def phs_fks_get_born_momenta -@ -<>= - procedure :: get_outgoing_momenta => phs_fks_get_outgoing_momenta -<>= - subroutine phs_fks_get_outgoing_momenta (phs, q) - class(phs_fks_t), intent(in) :: phs - type(vector4_t), intent(out), dimension(:) :: q - select case (phs%mode) - case (PHS_MODE_ADDITIONAL_PARTICLE) - q = phs%q_real - case (PHS_MODE_COLLINEAR_REMNANT) - q = phs%phs_wood_t%q - end select - end subroutine phs_fks_get_outgoing_momenta + contains -@ %def phs_fks_get_outgoing_momenta -@ -<>= - procedure :: get_incoming_momenta => phs_fks_get_incoming_momenta -<>= - subroutine phs_fks_get_incoming_momenta (phs, p) - class(phs_fks_t), intent(in) :: phs - type(vector4_t), intent(inout), dimension(:), allocatable :: p - p = phs%p_real - end subroutine phs_fks_get_incoming_momenta +<> + end subroutine feyngraph_make_invertible -@ %def phs_fks_get_incoming_momenta -@ -<>= - procedure :: set_isr_kinematics => phs_fks_set_isr_kinematics -<>= - subroutine phs_fks_set_isr_kinematics (phs, requires_boost) - class(phs_fks_t), intent(inout) :: phs - logical, intent(in) :: requires_boost - type(vector4_t), dimension(2) :: p - if (phs%generator%isr_kinematics%isr_mode == SQRTS_VAR) then - if (requires_boost) then - p = phs%lt_cm_to_lab & - * phs%generator%real_kinematics%p_born_cms%phs_point(1)%select ([1,2]) - else - p = phs%generator%real_kinematics%p_born_lab%phs_point(1)%select ([1,2]) +@ %def feyngraph_make_invertible +@ Check if a node has to be [[t_line]] or [[incoming]] and assign +inverse daughter pointers. +<>= + recursive subroutine f_node_t_line_check (node, t_line_found) + type(f_node_t), target, intent(inout) :: node + integer :: pos + logical, intent(inout) :: t_line_found + if (associated (node%daughter1)) then + call f_node_t_line_check (node%daughter1, t_line_found) + if (node%daughter1%incoming .or. node%daughter1%t_line) then + node%t_line = .true. + else if (associated (node%daughter2)) then + call f_node_t_line_check (node%daughter2, t_line_found) + if (node%daughter2%incoming .or. node%daughter2%t_line) then + node%t_line = .true. + end if + end if + else + pos = index (node%particle_label, '[') + 1 + if (node%particle_label(pos:pos) == '2') then + node%incoming = .true. + t_line_found = .true. end if - call phs%generator%set_isr_kinematics (p) end if - end subroutine phs_fks_set_isr_kinematics + end subroutine f_node_t_line_check -@ %def phs_fks_set_isr_kinematics -@ -<>= - procedure :: generate_radiation_variables => & - phs_fks_generate_radiation_variables -<>= - subroutine phs_fks_generate_radiation_variables (phs, r_in, threshold) - class(phs_fks_t), intent(inout) :: phs - real(default), intent(in), dimension(:) :: r_in - logical, intent(in) :: threshold - type(vector4_t), dimension(:), allocatable :: p_born - if (size (r_in) /= 3) call msg_fatal & - ("Real kinematics need to be generated using three random numbers!") - select case (phs%mode) - case (PHS_MODE_ADDITIONAL_PARTICLE) - allocate (p_born (size (phs%p_born_tot))) - if (threshold) then - p_born = phs%get_onshell_projected_momenta () - else - p_born = phs%p_born_tot - if (.not. phs%lab_is_cm ()) & - p_born = inverse (phs%lt_cm_to_lab) * p_born +@ %def k_node_t_line_check +@ Make an inverted copy of a [[kingraph]] using the inverse daughter +pointers. +<>= + procedure :: make_inverse_copy => kingraph_make_inverse_copy +<>= + module subroutine kingraph_make_inverse_copy (original_kingraph, feyngraph) + class(kingraph_t), intent(inout) :: original_kingraph + type(feyngraph_t), intent(inout) :: feyngraph + end subroutine kingraph_make_inverse_copy +<>= + module subroutine kingraph_make_inverse_copy (original_kingraph, feyngraph) + class(kingraph_t), intent(inout) :: original_kingraph + type(feyngraph_t), intent(inout) :: feyngraph + type(kingraph_t), pointer :: kingraph_copy + type(k_node_t), pointer :: potential_root + allocate (kingraph_copy) + if (associated (feyngraph%kin_last)) then + allocate (feyngraph%kin_last%next) + feyngraph%kin_last => feyngraph%kin_last%next + else + allocate(feyngraph%kin_first) + feyngraph%kin_last => feyngraph%kin_first + end if + kingraph_copy => feyngraph%kin_last + call kingraph_set_inverse_daughters (original_kingraph) + kingraph_copy%inverse = .true. + kingraph_copy%n_nodes = original_kingraph%n_nodes + kingraph_copy%keep = original_kingraph%keep + potential_root => original_kingraph%root + do while (.not. potential_root%incoming .or. & + (associated (potential_root%daughter1) .and. & + associated (potential_root%daughter2))) + if (potential_root%daughter1%incoming .or. & + potential_root%daughter1%t_line) then + potential_root => potential_root%daughter1 + else if (potential_root%daughter2%incoming .or. & + potential_root%daughter2%t_line) then + potential_root => potential_root%daughter2 end if - call phs%generator%generate_radiation_variables & - (r_in, p_born, phs%phs_identifiers, threshold) - phs%r_real = r_in - end select - end subroutine phs_fks_generate_radiation_variables + end do + call node_inverse_deep_copy (potential_root, kingraph_copy%root) + end subroutine kingraph_make_inverse_copy -@ %def phs_fks_generate_radiation_variables -@ -<>= - procedure :: compute_xi_ref_momenta => phs_fks_compute_xi_ref_momenta -<>= - subroutine phs_fks_compute_xi_ref_momenta (phs, p_in, contributors) - class(phs_fks_t), intent(inout) :: phs - type(vector4_t), intent(in), dimension(:), optional :: p_in - type(resonance_contributors_t), intent(in), dimension(:), optional :: contributors - if (phs%mode == PHS_MODE_ADDITIONAL_PARTICLE) then - if (present (p_in)) then - call phs%generator%compute_xi_ref_momenta (p_in, contributors) - else - call phs%generator%compute_xi_ref_momenta (phs%p_born_tot, contributors) +@ %def kingraph_make_inverse_copy +@ Recursively deep-copy nodes, but along the t-line the inverse daughters +become the new daughters. We need a deep copy only for the [[incoming]] +or [[t_line]] nodes. For the other nodes (of s-channel subgraphs) we set +only pointers to the existing nodes of the non-inverted graph. +<>= + recursive subroutine node_inverse_deep_copy (original_node, node_copy) + type(k_node_t), intent(in) :: original_node + type(k_node_t), pointer, intent(out) :: node_copy + call original_node%f_node%k_node_list%add_entry(node_copy, recycle=.false.) + node_copy = original_node + if (node_copy%t_line .or. node_copy%incoming) then + node_copy%particle => original_node%particle%anti + else + node_copy%particle => original_node%particle + end if + if (associated (original_node%inverse_daughter1) .and. associated (original_node%inverse_daughter2)) then + if (original_node%inverse_daughter1%incoming .or. original_node%inverse_daughter1%t_line) then + node_copy%daughter2 => original_node%inverse_daughter2 + call node_inverse_deep_copy (original_node%inverse_daughter1, & + node_copy%daughter1) + else if (original_node%inverse_daughter2%incoming .or. original_node%inverse_daughter2%t_line) then + node_copy%daughter1 => original_node%inverse_daughter1 + call node_inverse_deep_copy (original_node%inverse_daughter2, & + node_copy%daughter2) end if end if - end subroutine phs_fks_compute_xi_ref_momenta - -@ %def phs_fks_compute_xi_ref_momenta -@ -<>= - procedure :: compute_xi_ref_momenta_threshold => phs_fks_compute_xi_ref_momenta_threshold -<>= - subroutine phs_fks_compute_xi_ref_momenta_threshold (phs) - class(phs_fks_t), intent(inout) :: phs - select case (phs%mode) - case (PHS_MODE_ADDITIONAL_PARTICLE) - call phs%generator%compute_xi_ref_momenta_threshold & - (phs%get_onshell_projected_momenta ()) - end select - end subroutine phs_fks_compute_xi_ref_momenta_threshold + end subroutine node_inverse_deep_copy -@ %def phs_fks_compute_xi_ref_momenta +@ %def node_inverse_deep_copy @ -<>= - procedure :: compute_cms_energy => phs_fks_compute_cms_energy -<>= - subroutine phs_fks_compute_cms_energy (phs) - class(phs_fks_t), intent(inout) :: phs - if (phs%mode == PHS_MODE_ADDITIONAL_PARTICLE) & - call phs%generator%compute_cms_energy (phs%p_born_tot) - end subroutine phs_fks_compute_cms_energy +\subsection{Find phase-space parametrizations} +Perform all mapping calculations for a single process and store valid +[[kingraphs]] (channels) into the grove list, without caring for instance +about the resonance hash values. +<>= + public :: feyngraph_set_generate_single +<>= + module subroutine feyngraph_set_generate_single (feyngraph_set, model, & + n_in, n_out, phs_par, fatal_beam_decay, u_in) + type(feyngraph_set_t), intent(inout) :: feyngraph_set + type(model_data_t), target, intent(in) :: model + integer, intent(in) :: n_in, n_out + type(phs_parameters_t), intent(in) :: phs_par + logical, intent(in) :: fatal_beam_decay + integer, intent(in) :: u_in + end subroutine feyngraph_set_generate_single +<>= + module subroutine feyngraph_set_generate_single (feyngraph_set, model, & + n_in, n_out, phs_par, fatal_beam_decay, u_in) + type(feyngraph_set_t), intent(inout) :: feyngraph_set + type(model_data_t), target, intent(in) :: model + integer, intent(in) :: n_in, n_out + type(phs_parameters_t), intent(in) :: phs_par + logical, intent(in) :: fatal_beam_decay + integer, intent(in) :: u_in + feyngraph_set%n_in = n_in + feyngraph_set%n_out = n_out + feyngraph_set%process_type = n_in + feyngraph_set%phs_par = phs_par + feyngraph_set%model => model + if (debug_on) call msg_debug & + (D_PHASESPACE, "Construct relevant Feynman diagrams from Omega output") + call feyngraph_set%build (u_in) + if (debug_on) call msg_debug & + (D_PHASESPACE, "Find phase-space parametrizations") + call feyngraph_set_find_phs_parametrizations(feyngraph_set) + end subroutine feyngraph_set_generate_single -@ %def phs_fks_compute_cms_energy -@ When initial-state radiation is involved, either due to beamstrahlung or -QCD/QED corrections, it is important to have access to both the phase -space points in the center-of-mass and lab frame. -<>= - procedure :: set_reference_frames => phs_fks_set_reference_frames -<>= - subroutine phs_fks_set_reference_frames (phs, is_cms) - class(phs_fks_t), intent(inout) :: phs - logical, intent(in) :: is_cms - associate (real_kinematics => phs%generator%real_kinematics) - if (phs%config%lab_is_cm) then - real_kinematics%p_born_cms%phs_point(1) = phs%p_born_tot - real_kinematics%p_born_lab%phs_point(1) = phs%p_born_tot - else - if (is_cms) then - real_kinematics%p_born_cms%phs_point(1) & - = phs%p_born_tot - real_kinematics%p_born_lab%phs_point(1) & - = phs%lt_cm_to_lab * phs%p_born_tot - else - real_kinematics%p_born_cms%phs_point(1) & - = inverse (phs%lt_cm_to_lab) * phs%p_born_tot - real_kinematics%p_born_lab%phs_point(1) & - = phs%p_born_tot +@ %def feyngraph_set_generate_single +@ Find the phase space parametrizations. We start with the computation +of pure s-channel subtrees, i.e. we determine mappings and compare +subtrees in order to reduce the number of channels. This can be +parallelized easily. When all s-channel [[k_nodes]] exist, the possible +[[kingraphs]] are created using these nodes and we determine mappings for +t-channel nodes. +<>= + subroutine feyngraph_set_find_phs_parametrizations (feyngraph_set) + class(feyngraph_set_t), intent(inout) :: feyngraph_set + type(feyngraph_t), pointer :: current => null () + type(feyngraph_ptr_t), dimension (:), allocatable :: set + integer :: pos + integer :: i + allocate (set (feyngraph_set%n_graphs)) + pos = 0 + current => feyngraph_set%first + do while (associated (current)) + pos = pos + 1 + set(pos)%graph => current + current => current%next + end do + if (feyngraph_set%process_type == SCATTERING) then + !$OMP PARALLEL DO + do i=1, feyngraph_set%n_graphs + if (set(i)%graph%keep) then + call set(i)%graph%make_invertible () end if + end do + !$OMP END PARALLEL DO + end if + call f_node_list_compute_mappings_s (feyngraph_set) + do i=1, feyngraph_set%n_graphs + if (set(i)%graph%keep) then + call set(i)%graph%make_kingraphs (feyngraph_set) end if - end associate - end subroutine phs_fks_set_reference_frames - -@ %def phs_fks_set_reference_frames -@ -<>= - procedure :: i_phs_is_isr => phs_fks_i_phs_is_isr -<>= - function phs_fks_i_phs_is_isr (phs, i_phs) result (is_isr) - logical :: is_isr - class(phs_fks_t), intent(in) :: phs - integer, intent(in) :: i_phs - is_isr = phs%phs_identifiers(i_phs)%emitter <= phs%generator%n_in - end function phs_fks_i_phs_is_isr - -@ %def phs_fks_i_phs_is_isr -@ -\subsection{Creation of the real phase space - FSR} -At this point, the Born phase space has been generated, as well as the -three random variables $\xi$, $y$ and $\phi$. The question is how the -real phase space is generated for a final-state emission -configuration. We work with two different sets of momenta, the Born -configuration $\Bigl\{ \bar{k}_{\oplus}, \bar{k}_{\ominus}, \bar{k}_{1}, ..., -\bar{k}_{n} \Bigr\}$ and the real configuration $\Bigl\{ k_{\oplus}, -k_{\ominus}, k_1,..., k_n, k_{n+1} \Bigr\}$. We define the momentum of -the emitter to be on the $n$-th position and the momentum of the -radiated particle to be at position $n+1$. The magnitude of the -spatial component of k is denoted by $\underline{k}$. - -For final-state emissions, it is $\bar{k}_\oplus = k_\oplus$ and -$\bar{k}_\ominus = k_\ominus$. Thus, the center-of-mass systems -coincide and it is -\begin{equation} - q = \sum_{i=1}^n \bar{k}_i = \sum_{i=1}^{n+1} k_i, -\end{equation} -with $\vec{q} = 0$ and $q^2 = \left(q^0\right)^2$. - -We want to construct the real phase space from the Born phase space -using three random numbers. They are defined as follows: -\begin{itemize} -\item $\xi = \frac{2k_{n+1}^0}{\sqrt{s}} \in [0, \xi_{max}]$, where - $k_{n+1}$ denotes the four-momentum of the radiated particle. -\item $y = \cos\theta = \frac{\vec{k}_n \cdot - \vec{k}_{n+1}}{\underline{k}_n \underline{k}_{n+1}}$ is the - splitting angle. -\item The angle between tho two splitting particles in the transversal - plane, $phi \in [0,2\pi]$. -\end{itemize} -Further, $k_{rec} = \sum_{i=1}^{n-1} k_i$ denotes the sum of all -recoiling momenta. -<>= - generic :: generate_fsr => generate_fsr_default, generate_fsr_resonances -<>= - procedure :: generate_fsr_default => phs_fks_generator_generate_fsr_default -<>= - subroutine phs_fks_generator_generate_fsr_default (generator, emitter, i_phs, & - p_born, p_real, xi_y_phi, no_jacobians) - class(phs_fks_generator_t), intent(inout) :: generator - integer, intent(in) :: emitter, i_phs - type(vector4_t), intent(in), dimension(:) :: p_born - type(vector4_t), intent(inout), dimension(:) :: p_real - real(default), intent(in), dimension(3), optional :: xi_y_phi - logical, intent(in), optional :: no_jacobians - real(default) :: q0 + end do + if (feyngraph_set%process_type == SCATTERING) then + do i=1, feyngraph_set%n_graphs + if (set(i)%graph%keep) then + call set(i)%graph%make_inverse_kingraphs () + end if + end do + end if + do i=1, feyngraph_set%n_graphs + if (set(i)%graph%keep) then + call set(i)%graph%compute_mappings (feyngraph_set) + end if + end do + do i=1, feyngraph_set%n_graphs + if (set(i)%graph%keep) then + call feyngraph_set%grove_list%add_feyngraph (set(i)%graph, & + feyngraph_set%model) + end if + end do + end subroutine feyngraph_set_find_phs_parametrizations - call generator%generate_fsr_in (p_born, p_real) - q0 = sum (p_born(1:generator%n_in))**1 - generator%i_fsr_first = generator%n_in + 1 - call generator%generate_fsr_out (emitter, i_phs, p_born, p_real, q0, & - xi_y_phi = xi_y_phi, no_jacobians = no_jacobians) - if (debug_active (D_PHASESPACE)) then - call vector4_check_momentum_conservation (p_real, generator%n_in, & - rel_smallness = 1000 * tiny_07, abs_smallness = tiny_07) +@ %def feyngraph_set_find_phs_parametrizations +@ Compare objects of type [[tree_t]]. +<>= + interface operator (==) + module procedure tree_equal + end interface operator (==) +<>= + elemental module function tree_equal (tree1, tree2) result (flag) + type(tree_t), intent(in) :: tree1, tree2 + logical :: flag + end function tree_equal +<>= + elemental module function tree_equal (tree1, tree2) result (flag) + type(tree_t), intent(in) :: tree1, tree2 + logical :: flag + if (tree1%n_entries == tree2%n_entries) then + if (tree1%bc(size(tree1%bc)) == tree2%bc(size(tree2%bc))) then + flag = all (tree1%mapping == tree2%mapping) .and. & + all (tree1%bc == tree2%bc) .and. & + all (abs(tree1%pdg) == abs(tree2%pdg)) + else + flag = .false. + end if + else + flag = .false. end if - end subroutine phs_fks_generator_generate_fsr_default + end function tree_equal -@ %def phs_fks_generator_generate_fsr -@ -<>= - procedure :: generate_fsr_resonances => phs_fks_generator_generate_fsr_resonances -<>= - subroutine phs_fks_generator_generate_fsr_resonances (generator, & - emitter, i_phs, i_con, p_born, p_real, xi_y_phi, no_jacobians) - class(phs_fks_generator_t), intent(inout) :: generator - integer, intent(in) :: emitter, i_phs - integer, intent(in) :: i_con - type(vector4_t), intent(in), dimension(:) :: p_born - type(vector4_t), intent(inout), dimension(:) :: p_real - real(default), intent(in), dimension(3), optional :: xi_y_phi - logical, intent(in), optional :: no_jacobians - integer, dimension(:), allocatable :: resonance_list - integer, dimension(size(p_born)) :: inv_resonance_list - type(vector4_t), dimension(:), allocatable :: p_tmp_born - type(vector4_t), dimension(:), allocatable :: p_tmp_real - type(vector4_t) :: p_resonance - real(default) :: q0 - integer :: i, j, nlegborn, nlegreal - integer :: i_emitter - type(lorentz_transformation_t) :: boost_to_resonance - integer :: n_resonant_particles - if (debug_on) call msg_debug2 (D_PHASESPACE, "phs_fks_generator_generate_fsr_resonances") - nlegborn = size (p_born); nlegreal = nlegborn + 1 - allocate (resonance_list (size (generator%resonance_contributors(i_con)%c))) - resonance_list = generator%resonance_contributors(i_con)%c - n_resonant_particles = size (resonance_list) +@ %def tree_equal +@ Select between equivalent subtrees (type [[tree_t]]). This is similar +to [[kingraph_select]], but we compare only positions with mappings +[[NONRESONANT]] and [[NO_MAPPING]]. +<>= + interface operator (.eqv.) + module procedure subtree_eqv + end interface operator (.eqv.) +<>= + pure module function subtree_eqv (subtree1, subtree2) result (eqv) + type(tree_t), intent(in) :: subtree1, subtree2 + logical :: eqv + end function subtree_eqv +<>= + pure module function subtree_eqv (subtree1, subtree2) result (eqv) + type(tree_t), intent(in) :: subtree1, subtree2 + logical :: eqv + integer :: root_pos + integer :: i + logical :: equal + eqv = .false. + if (subtree1%n_entries /= subtree2%n_entries) return + root_pos = subtree1%n_entries + if (subtree1%mapping(root_pos) == NONRESONANT .or. & + subtree2%mapping(root_pos) == NONRESONANT .or. & + (subtree1%mapping(root_pos) == NO_MAPPING .and. & + subtree2%mapping(root_pos) == NO_MAPPING .and. & + abs(subtree1%pdg(root_pos)) == abs(subtree2%pdg(root_pos)))) then + do i = subtree1%n_entries, 1, -1 + if (subtree1%bc(i) /= subtree2%bc(i)) return + end do + equal = .true. + do i = subtree1%n_entries, 1, -1 + if (abs(subtree1%pdg(i)) /= abs (subtree2%pdg(i))) then + select case (subtree1%mapping(i)) + case (NO_MAPPING, NONRESONANT) + select case (subtree2%mapping(i)) + case (NO_MAPPING, NONRESONANT) + equal = .false. + case default + return + end select + case default + return + end select + end if + end do + do i = subtree1%n_entries, 1, -1 + if (subtree1%mapping(i) /= subtree2%mapping(i)) then + select case (subtree1%mapping(i)) + case (NO_MAPPING, NONRESONANT) + select case (subtree2%mapping(i)) + case (NO_MAPPING, NONRESONANT) + case default + return + end select + case default + return + end select + end if + end do + if (.not. equal) eqv = .true. + end if + end function subtree_eqv - if (.not. any (resonance_list == emitter)) then - call msg_fatal ("Emitter must be included in the resonance list!") - else - do i = 1, n_resonant_particles - if (resonance_list (i) == emitter) i_emitter = i +@ %def subtree_eqv +<>= + subroutine subtree_select (subtree1, subtree2, model) + type(tree_t), intent(inout) :: subtree1, subtree2 + type(model_data_t), intent(in) :: model + integer :: j, k + integer(TC), dimension(:), allocatable :: tmp_bc, daughter_bc + integer, dimension(:), allocatable :: tmp_pdg, daughter_pdg + integer, dimension (:), allocatable :: pdg_match + if (subtree1 .eqv. subtree2) then + do j=1, subtree1%n_entries + if (abs(subtree1%pdg(j)) /= abs(subtree2%pdg(j))) then + tmp_bc = subtree1%bc(:j-1); tmp_pdg = subtree1%pdg(:j-1) + do k=j-1, 1, - 1 + where (iand (tmp_bc(:k-1),tmp_bc(k)) /= 0 & + .or. iand(tmp_bc(:k-1),subtree1%bc(j)) == 0) + tmp_bc(:k-1) = 0 + tmp_pdg(:k-1) = 0 + endwhere + end do + daughter_bc = pack (tmp_bc, tmp_bc /= 0) + daughter_pdg = pack (tmp_pdg, tmp_pdg /= 0) + if (size (daughter_pdg) == 2) then + call model%match_vertex(daughter_pdg(1), daughter_pdg(2), pdg_match) + if (.not. allocated (pdg_match)) then +!!! Relevant if tree contains only abs (pdg). In this case, changing the +!!! sign of one of the pdg codes should give a result. + call model%match_vertex(-daughter_pdg(1), daughter_pdg(2), pdg_match) + end if + end if + do k=1, size (pdg_match) + if (abs(pdg_match(k)) == abs(subtree1%pdg(j))) then + if (subtree1%keep) subtree2%keep = .false. + exit + else if (abs(pdg_match(k)) == abs(subtree2%pdg(j))) then + if (subtree2%keep) subtree1%keep = .false. + exit + end if + end do + deallocate (tmp_bc, tmp_pdg, daughter_bc, daughter_pdg, pdg_match) + if (.not. (subtree1%keep .and. subtree2%keep)) exit + end if end do end if + end subroutine subtree_select - inv_resonance_list = & - create_inverse_resonance_list (nlegborn, resonance_list) +@ %def subtree_select +@ Assign a resonance hash value to a [[kingraph]], like in [[cascades]], +but here without the array [[tree_resonant]]. +<>= + procedure :: assign_resonance_hash => kingraph_assign_resonance_hash +<>= + module subroutine kingraph_assign_resonance_hash (kingraph) + class(kingraph_t), intent(inout) :: kingraph + end subroutine kingraph_assign_resonance_hash +<>= + module subroutine kingraph_assign_resonance_hash (kingraph) + class(kingraph_t), intent(inout) :: kingraph + logical, dimension (:), allocatable :: tree_resonant + integer(i8), dimension(1) :: mold + allocate (tree_resonant (kingraph%tree%n_entries)) + tree_resonant = (kingraph%tree%mapping == S_CHANNEL) + kingraph%grove_prop%res_hash = hash (transfer & + ([sort (pack (kingraph%tree%pdg, tree_resonant)), & + sort (pack (abs (kingraph%tree%pdg), & + kingraph%tree%mapping == T_CHANNEL .or. & + kingraph%tree%mapping == U_CHANNEL))], mold)) + deallocate (tree_resonant) + end subroutine kingraph_assign_resonance_hash - allocate (p_tmp_born (n_resonant_particles)) - allocate (p_tmp_real (n_resonant_particles + 1)) - p_tmp_born = vector4_null - p_tmp_real = vector4_null - j = 1 - do i = 1, n_resonant_particles - p_tmp_born(j) = p_born(resonance_list(i)) - j = j + 1 +@ %def kingraph_assign_resonance_hash +@ Write the process in the bincode format. This is again a copy of the +corresponding procedure in [[cascades]], using [[feyngraph_set]] instead +of [[cascade_set]] as an argument. +<>= + public :: feyngraph_set_write_process_bincode_format +<>= + module subroutine feyngraph_set_write_process_bincode_format & + (feyngraph_set, unit) + type(feyngraph_set_t), intent(in), target :: feyngraph_set + integer, intent(in), optional :: unit + end subroutine feyngraph_set_write_process_bincode_format +<>= + module subroutine feyngraph_set_write_process_bincode_format & + (feyngraph_set, unit) + type(feyngraph_set_t), intent(in), target :: feyngraph_set + integer, intent(in), optional :: unit + integer, dimension(:), allocatable :: bincode, field_width + integer :: n_in, n_out, n_tot, n_flv + integer :: u, f, i, bc + character(20) :: str + type(string_t) :: fmt_head + type(string_t), dimension(:), allocatable :: fmt_proc + u = given_output_unit (unit); if (u < 0) return + if (.not. allocated (feyngraph_set%flv)) return + write (u, "('!',1x,A)") "List of subprocesses with particle bincodes:" + n_in = feyngraph_set%n_in + n_out = feyngraph_set%n_out + n_tot = n_in + n_out + n_flv = size (feyngraph_set%flv, 2) + allocate (bincode (n_tot), field_width (n_tot), fmt_proc (n_tot)) + bc = 1 + do i = 1, n_out + bincode(n_in + i) = bc + bc = 2 * bc end do + do i = n_in, 1, -1 + bincode(i) = bc + bc = 2 * bc + end do + do i = 1, n_tot + write (str, "(I0)") bincode(i) + field_width(i) = len_trim (str) + do f = 1, n_flv + field_width(i) = max (field_width(i), & + len (feyngraph_set%flv(i,f)%get_name ())) + end do + end do + fmt_head = "('!'" + do i = 1, n_tot + fmt_head = fmt_head // ",1x," + fmt_proc(i) = "(1x," + write (str, "(I0)") field_width(i) + fmt_head = fmt_head // "I" // trim(str) + fmt_proc(i) = fmt_proc(i) // "A" // trim(str) + if (i == n_in) then + fmt_head = fmt_head // ",1x,' '" + end if + end do + do i = 1, n_tot + fmt_proc(i) = fmt_proc(i) // ")" + end do + fmt_head = fmt_head // ")" + write (u, char (fmt_head)) bincode + do f = 1, n_flv + write (u, "('!')", advance="no") + do i = 1, n_tot + write (u, char (fmt_proc(i)), advance="no") & + char (feyngraph_set%flv(i,f)%get_name ()) + if (i == n_in) write (u, "(1x,'=>')", advance="no") + end do + write (u, *) + end do + write (u, char (fmt_head)) bincode + end subroutine feyngraph_set_write_process_bincode_format - call generator%generate_fsr_in (p_born, p_real) - - p_resonance = generator%real_kinematics%xi_ref_momenta(i_con) - q0 = p_resonance**1 - - boost_to_resonance = inverse (boost (p_resonance, q0)) - p_tmp_born = boost_to_resonance * p_tmp_born - - generator%i_fsr_first = 1 - call generator%generate_fsr_out (emitter, i_phs, p_tmp_born, p_tmp_real, & - q0, i_emitter, xi_y_phi) - p_tmp_real = inverse (boost_to_resonance) * p_tmp_real +@ %def feyngraph_set_write_process_bincode_format +@ Write tex file for graphical display of channels. +<>= + public :: feyngraph_set_write_graph_format +<>= + module subroutine feyngraph_set_write_graph_format & + (feyngraph_set, filename, process_id, unit) + type(feyngraph_set_t), intent(in), target :: feyngraph_set + type(string_t), intent(in) :: filename, process_id + integer, intent(in), optional :: unit + end subroutine feyngraph_set_write_graph_format +<>= + module subroutine feyngraph_set_write_graph_format & + (feyngraph_set, filename, process_id, unit) + type(feyngraph_set_t), intent(in), target :: feyngraph_set + type(string_t), intent(in) :: filename, process_id + integer, intent(in), optional :: unit + type(kingraph_t), pointer :: kingraph + type(grove_t), pointer :: grove + integer :: u, n_grove, count, pgcount + logical :: first_in_grove + u = given_output_unit (unit); if (u < 0) return + write (u, '(A)') "\documentclass[10pt]{article}" + write (u, '(A)') "\usepackage{amsmath}" + write (u, '(A)') "\usepackage{feynmp}" + write (u, '(A)') "\usepackage{url}" + write (u, '(A)') "\usepackage{color}" + write (u, *) + write (u, '(A)') "\textwidth 18.5cm" + write (u, '(A)') "\evensidemargin -1.5cm" + write (u, '(A)') "\oddsidemargin -1.5cm" + write (u, *) + write (u, '(A)') "\newcommand{\blue}{\color{blue}}" + write (u, '(A)') "\newcommand{\green}{\color{green}}" + write (u, '(A)') "\newcommand{\red}{\color{red}}" + write (u, '(A)') "\newcommand{\magenta}{\color{magenta}}" + write (u, '(A)') "\newcommand{\cyan}{\color{cyan}}" + write (u, '(A)') "\newcommand{\sm}{\footnotesize}" + write (u, '(A)') "\setlength{\parindent}{0pt}" + write (u, '(A)') "\setlength{\parsep}{20pt}" + write (u, *) + write (u, '(A)') "\begin{document}" + write (u, '(A)') "\begin{fmffile}{" // char (filename) // "}" + write (u, '(A)') "\fmfcmd{color magenta; magenta = red + blue;}" + write (u, '(A)') "\fmfcmd{color cyan; cyan = green + blue;}" + write (u, '(A)') "\begin{fmfshrink}{0.5}" + write (u, '(A)') "\begin{flushleft}" + write (u, *) + write (u, '(A)') "\noindent" // & + & "\textbf{\large\texttt{WHIZARD} phase space channels}" // & + & "\hfill\today" + write (u, *) + write (u, '(A)') "\vspace{10pt}" + write (u, '(A)') "\noindent" // & + & "\textbf{Process:} \url{" // char (process_id) // "}" + call feyngraph_set_write_process_tex_format (feyngraph_set, u) + write (u, *) + write (u, '(A)') "\noindent" // & + & "\textbf{Note:} These are pseudo Feynman graphs that " + write (u, '(A)') "visualize phase-space parameterizations " // & + & "(``integration channels''). " + write (u, '(A)') "They do \emph{not} indicate Feynman graphs used for the " // & + & "matrix element." + write (u, *) + write (u, '(A)') "\textbf{Color code:} " // & + & "{\blue resonance,} " // & + & "{\cyan t-channel,} " // & + & "{\green radiation,} " + write (u, '(A)') "{\red infrared,} " // & + & "{\magenta collinear,} " // & + & "external/off-shell" + write (u, *) + write (u, '(A)') "\noindent" // & + & "\textbf{Black square:} Keystone, indicates ordering of " // & + & "phase space parameters." + write (u, *) + write (u, '(A)') "\vspace{-20pt}" + count = 0 + pgcount = 0 + n_grove = 0 + grove => feyngraph_set%grove_list%first + do while (associated (grove)) + n_grove = n_grove + 1 + write (u, *) + write (u, '(A)') "\vspace{20pt}" + write (u, '(A)') "\begin{tabular}{l}" + write (u, '(A,I5,A)') & + & "\fbox{\bf Grove \boldmath$", n_grove, "$} \\[10pt]" + write (u, '(A,I1,A)') "Multiplicity: ", & + grove%grove_prop%multiplicity, "\\" + write (u, '(A,I1,A)') "Resonances: ", & + grove%grove_prop%n_resonances, "\\" + write (u, '(A,I1,A)') "Log-enhanced: ", & + grove%grove_prop%n_log_enhanced, "\\" + write (u, '(A,I1,A)') "Off-shell: ", & + grove%grove_prop%n_off_shell, "\\" + write (u, '(A,I1,A)') "t-channel: ", & + grove%grove_prop%n_t_channel, "" + write (u, '(A)') "\end{tabular}" + kingraph => grove%first + do while (associated (kingraph)) + count = count + 1 + call kingraph_write_graph_format (kingraph, count, unit) + kingraph => kingraph%grove_next + end do + grove => grove%next + end do + write (u, '(A)') "\end{flushleft}" + write (u, '(A)') "\end{fmfshrink}" + write (u, '(A)') "\end{fmffile}" + write (u, '(A)') "\end{document}" + end subroutine feyngraph_set_write_graph_format - do i = generator%n_in + 1, nlegborn - if (any (resonance_list == i)) then - p_real(i) = p_tmp_real(inv_resonance_list (i)) +@ %def feyngraph_set_write_graph_format +@ Write the process as a \LaTeX\ expression. This is a slightly modified +copy of [[cascade_set_write_process_tex_format]] which has only been +adapted to the types which are used here. +<>= + subroutine feyngraph_set_write_process_tex_format (feyngraph_set, unit) + type(feyngraph_set_t), intent(in), target :: feyngraph_set + integer, intent(in), optional :: unit + integer :: n_tot + integer :: u, f, i + n_tot = feyngraph_set%n_in + feyngraph_set%n_out + u = given_output_unit (unit); if (u < 0) return + if (.not. allocated (feyngraph_set%flv)) return + write (u, "(A)") "\begin{align*}" + do f = 1, size (feyngraph_set%flv, 2) + do i = 1, feyngraph_set%n_in + if (i > 1) write (u, "(A)", advance="no") "\quad " + write (u, "(A)", advance="no") & + char (feyngraph_set%flv(i,f)%get_tex_name ()) + end do + write (u, "(A)", advance="no") "\quad &\to\quad " + do i = feyngraph_set%n_in + 1, n_tot + if (i > feyngraph_set%n_in + 1) write (u, "(A)", advance="no") "\quad " + write (u, "(A)", advance="no") & + char (feyngraph_set%flv(i,f)%get_tex_name ()) + end do + if (f < size (feyngraph_set%flv, 2)) then + write (u, "(A)") "\\" else - p_real(i) = p_born (i) + write (u, "(A)") "" end if end do - p_real(nlegreal) = p_tmp_real (n_resonant_particles + 1) - - if (debug_active (D_PHASESPACE)) then - call vector4_check_momentum_conservation (p_real, generator%n_in, & - rel_smallness = 1000 * tiny_07, abs_smallness = tiny_07) - end if + write (u, "(A)") "\end{align*}" + end subroutine feyngraph_set_write_process_tex_format +@ %def feyngraph_set_write_process_tex_format +@ This creates metapost source for graphical display for a given [[kingraph]]. +It is the analogon to [[cascade_write_graph_format]] (a modified copy). +<>= + subroutine kingraph_write_graph_format (kingraph, count, unit) + type(kingraph_t), intent(in) :: kingraph + integer, intent(in) :: count + integer, intent(in), optional :: unit + integer :: u + type(string_t) :: left_str, right_str + u = given_output_unit (unit); if (u < 0) return + left_str = "" + right_str = "" + write (u, '(A)') "\begin{minipage}{105pt}" + write (u, '(A)') "\vspace{30pt}" + write (u, '(A)') "\begin{center}" + write (u, '(A)') "\begin{fmfgraph*}(55,55)" + call graph_write_node (kingraph%root) + write (u, '(A)') "\fmfleft{" // char (extract (left_str, 2)) // "}" + write (u, '(A)') "\fmfright{" // char (extract (right_str, 2)) // "}" + write (u, '(A)') "\end{fmfgraph*}\\" + write (u, '(A,I5,A)') "\fbox{$", count, "$}" + write (u, '(A)') "\end{center}" + write (u, '(A)') "\end{minipage}" + write (u, '(A)') "%" contains + recursive subroutine graph_write_node (node) + type(k_node_t), intent(in) :: node + if (associated (node%daughter1) .or. associated (node%daughter2)) then + if (node%daughter2%t_line .or. node%daughter2%incoming) then + call vertex_write (node, node%daughter2) + call vertex_write (node, node%daughter1) + else + call vertex_write (node, node%daughter1) + call vertex_write (node, node%daughter2) + end if + if (node%mapping == EXTERNAL_PRT) then + call line_write (node%bincode, 0, node%particle) + call external_write (node%bincode, node%particle%tex_name, & + left_str) + write (u, '(A,I0,A)') "\fmfv{d.shape=square}{v0}" + end if + else + if (node%incoming) then + call external_write (node%bincode, node%particle%anti%tex_name, & + left_str) + else + call external_write (node%bincode, node%particle%tex_name, & + right_str) + end if + end if + end subroutine graph_write_node + recursive subroutine vertex_write (node, daughter) + type(k_node_t), intent(in) :: node, daughter + integer :: bincode + if (associated (node%daughter1) .and. associated (node%daughter2) & + .and. node%mapping == EXTERNAL_PRT) then + bincode = 0 + else + bincode = node%bincode + end if + call graph_write_node (daughter) + if (associated (node%daughter1) .or. associated (node%daughter2)) then + call line_write (bincode, daughter%bincode, daughter%particle, & + mapping=daughter%mapping) + else + call line_write (bincode, daughter%bincode, daughter%particle) + end if + end subroutine vertex_write + subroutine line_write (i1, i2, particle, mapping) + integer(TC), intent(in) :: i1, i2 + type(part_prop_t), intent(in) :: particle + integer, intent(in), optional :: mapping + integer :: k1, k2 + type(string_t) :: prt_type + select case (particle%spin_type) + case (SCALAR); prt_type = "plain" + case (SPINOR); prt_type = "fermion" + case (VECTOR); prt_type = "boson" + case (VECTORSPINOR); prt_type = "fermion" + case (TENSOR); prt_type = "dbl_wiggly" + case default; prt_type = "dashes" + end select + if (particle%pdg < 0) then +!!! anti-particle + k1 = i2; k2 = i1 + else + k1 = i1; k2 = i2 + end if + if (present (mapping)) then + select case (mapping) + case (S_CHANNEL) + write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & + & ",f=blue,lab=\sm\blue$" // & + & char (particle%tex_name) // "$}" // & + & "{v", k1, ",v", k2, "}" + case (T_CHANNEL, U_CHANNEL) + write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & + & ",f=cyan,lab=\sm\cyan$" // & + & char (particle%tex_name) // "$}" // & + & "{v", k1, ",v", k2, "}" + case (RADIATION) + write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & + & ",f=green,lab=\sm\green$" // & + & char (particle%tex_name) // "$}" // & + & "{v", k1, ",v", k2, "}" + case (COLLINEAR) + write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & + & ",f=magenta,lab=\sm\magenta$" // & + & char (particle%tex_name) // "$}" // & + & "{v", k1, ",v", k2, "}" + case (INFRARED) + write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & + & ",f=red,lab=\sm\red$" // & + & char (particle%tex_name) // "$}" // & + & "{v", k1, ",v", k2, "}" + case default + write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & + & ",f=black}" // & + & "{v", k1, ",v", k2, "}" + end select + else + write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & + & "}" // & + & "{v", k1, ",v", k2, "}" + end if + end subroutine line_write + subroutine external_write (bincode, name, ext_str) + integer(TC), intent(in) :: bincode + type(string_t), intent(in) :: name + type(string_t), intent(inout) :: ext_str + character(len=20) :: str + write (str, '(A2,I0)') ",v", bincode + ext_str = ext_str // trim (str) + write (u, '(A,I0,A,I0,A)') "\fmflabel{\sm$" & + // char (name) & + // "\,(", bincode, ")" & + // "$}{v", bincode, "}" + end subroutine external_write + end subroutine kingraph_write_graph_format - function create_inverse_resonance_list (nlegborn, resonance_list) & - result (inv_resonance_list) - integer, intent(in) :: nlegborn - integer, intent(in), dimension(:) :: resonance_list - integer, dimension(nlegborn) :: inv_resonance_list - integer :: i, j - inv_resonance_list = 0 - j = 1 - do i = 1, nlegborn - if (any (i == resonance_list)) then - inv_resonance_list (i) = j - j = j + 1 - end if +@ %def kingraph_write_graph_format +@ Generate a [[feyngraph_set]] for several subprocesses. Mapping +calculations are performed separately, but the final grove list is shared +between the subsets [[fset]] of the [[feyngraph_set]]. +<>= + public :: feyngraph_set_generate +<>= + module subroutine feyngraph_set_generate & + (feyngraph_set, model, n_in, n_out, flv, phs_par, fatal_beam_decay, & + u_in, vis_channels, use_dag) + type(feyngraph_set_t), intent(out) :: feyngraph_set + class(model_data_t), intent(in), target :: model + integer, intent(in) :: n_in, n_out + type(flavor_t), dimension(:,:), intent(in) :: flv + type(phs_parameters_t), intent(in) :: phs_par + logical, intent(in) :: fatal_beam_decay + integer, intent(in) :: u_in + logical, intent(in) :: vis_channels + logical, optional, intent(in) :: use_dag + end subroutine feyngraph_set_generate +<>= + module subroutine feyngraph_set_generate & + (feyngraph_set, model, n_in, n_out, flv, phs_par, fatal_beam_decay, & + u_in, vis_channels, use_dag) + type(feyngraph_set_t), intent(out) :: feyngraph_set + class(model_data_t), intent(in), target :: model + integer, intent(in) :: n_in, n_out + type(flavor_t), dimension(:,:), intent(in) :: flv + type(phs_parameters_t), intent(in) :: phs_par + logical, intent(in) :: fatal_beam_decay + integer, intent(in) :: u_in + logical, intent(in) :: vis_channels + logical, optional, intent(in) :: use_dag + type(grove_t), pointer :: grove + integer :: i, j + type(kingraph_t), pointer :: kingraph + if (phase_space_vanishes (phs_par%sqrts, n_in, flv)) return + if (present (use_dag)) feyngraph_set%use_dag = use_dag + feyngraph_set%process_type = n_in + feyngraph_set%n_in = n_in + feyngraph_set%n_out = n_out + allocate (feyngraph_set%flv (size (flv, 1), size (flv, 2))) + do i = 1, size (flv, 2) + do j = 1, size (flv, 1) + call feyngraph_set%flv(j,i)%init (flv(j,i)%get_pdg (), model) end do - end function create_inverse_resonance_list + end do + allocate (feyngraph_set%particle (PRT_ARRAY_SIZE)) + allocate (feyngraph_set%grove_list) + allocate (feyngraph_set%fset (size (flv, 2))) + do i = 1, size (feyngraph_set%fset) + feyngraph_set%fset(i)%use_dag = feyngraph_set%use_dag + allocate (feyngraph_set%fset(i)%flv(size (flv,1),1)) + feyngraph_set%fset(i)%flv(:,1) = flv(:,i) + feyngraph_set%fset(i)%particle => feyngraph_set%particle + allocate (feyngraph_set%fset(i)%grove_list) + call feyngraph_set_generate_single (feyngraph_set%fset(i), & + model, n_in, n_out, phs_par, fatal_beam_decay, u_in) + call feyngraph_set%grove_list%merge & + (feyngraph_set%fset(i)%grove_list, model, i) + if (.not. vis_channels) call feyngraph_set%fset(i)%final() + end do + call feyngraph_set%grove_list%rebuild () + end subroutine feyngraph_set_generate - function boosted_energy () result (E) - real(default) :: E - type(vector4_t) :: p_boost - p_boost = boost_to_resonance * p_resonance - E = p_boost%p(0) - end function boosted_energy - end subroutine phs_fks_generator_generate_fsr_resonances +@ %def feyngraph_set_generate +@ Check whether the [[grove_list]] of the [[feyngraph_set]] contains any +[[kingraphs]] which are valid, i.e. where the [[keep]] variable has the +value [[.true.]]. This is necessary to write a non-empty phase-space +file. The function is the pendant to [[cascade_set_is_valid]]. +<>= + public :: feyngraph_set_is_valid +<>= + module function feyngraph_set_is_valid (feyngraph_set) result (flag) + class(feyngraph_set_t), intent(in) :: feyngraph_set + logical :: flag + end function feyngraph_set_is_valid +<>= + module function feyngraph_set_is_valid (feyngraph_set) result (flag) + class(feyngraph_set_t), intent(in) :: feyngraph_set + type(kingraph_t), pointer :: kingraph + type(grove_t), pointer :: grove + logical :: flag + flag = .false. + if (associated (feyngraph_set%grove_list)) then + grove => feyngraph_set%grove_list%first + do while (associated (grove)) + kingraph => grove%first + do while (associated (kingraph)) + if (kingraph%keep) then + flag = .true. + return + end if + kingraph => kingraph%next + end do + grove => grove%next + end do + end if + end function feyngraph_set_is_valid -@ %def phs_fks_generator_generate_fsr_resonances +@ %def feyngraph_set_is_valid @ -<>= - procedure :: generate_fsr_threshold => phs_fks_generator_generate_fsr_threshold -<>= - subroutine phs_fks_generator_generate_fsr_threshold (generator, & - emitter, i_phs, p_born, p_real, xi_y_phi) - class(phs_fks_generator_t), intent(inout) :: generator - integer, intent(in) :: emitter, i_phs - type(vector4_t), intent(in), dimension(:) :: p_born - type(vector4_t), intent(inout), dimension(:) :: p_real - real(default), intent(in), dimension(3), optional :: xi_y_phi - type(vector4_t), dimension(2) :: p_tmp_born - type(vector4_t), dimension(3) :: p_tmp_real - integer :: nlegborn, nlegreal - type(vector4_t) :: p_top - real(default) :: q0 - type(lorentz_transformation_t) :: boost_to_top - integer :: leg, other_leg - real(default) :: sqrts, mtop - if (debug_on) call msg_debug2 (D_PHASESPACE, "phs_fks_generator_generate_fsr_resonances") - nlegborn = size (p_born); nlegreal = nlegborn + 1 +\subsection{Return the resonance histories for subtraction} +The following procedures are copies of corresponding procedures in +[[cascades]], which only have been adapted to the new types used in +this module. - leg = thr_leg(emitter); other_leg = 3 - leg +Extract the resonance set from a valid [[kingraph]] which is kept in the +final grove list. +<>= + procedure :: extract_resonance_history => kingraph_extract_resonance_history +<>= + module subroutine kingraph_extract_resonance_history & + (kingraph, res_hist, model, n_out) + class(kingraph_t), intent(in), target :: kingraph + type(resonance_history_t), intent(out) :: res_hist + class(model_data_t), intent(in), target :: model + integer, intent(in) :: n_out + end subroutine kingraph_extract_resonance_history +<>= + module subroutine kingraph_extract_resonance_history & + (kingraph, res_hist, model, n_out) + class(kingraph_t), intent(in), target :: kingraph + type(resonance_history_t), intent(out) :: res_hist + class(model_data_t), intent(in), target :: model + integer, intent(in) :: n_out + type(resonance_info_t) :: resonance + integer :: i, mom_id, pdg + if (debug_on) call msg_debug2 & + (D_PHASESPACE, "kingraph_extract_resonance_history") + if (kingraph%grove_prop%n_resonances > 0) then + if (associated (kingraph%root%daughter1) .or. & + associated (kingraph%root%daughter2)) then + if (debug_on) call msg_debug2 & + (D_PHASESPACE, "kingraph has resonances, root has children") + do i = 1, kingraph%tree%n_entries + if (kingraph%tree%mapping(i) == S_CHANNEL) then + mom_id = kingraph%tree%bc (i) + pdg = kingraph%tree%pdg (i) + call resonance%init (mom_id, pdg, model, n_out) + if (debug2_active (D_PHASESPACE)) then + print *, 'D: Adding resonance' + call resonance%write () + end if + call res_hist%add_resonance (resonance) + end if + end do + end if + end if + end subroutine kingraph_extract_resonance_history - p_tmp_born(1) = p_born (ass_boson(leg)) - p_tmp_born(2) = p_born (ass_quark(leg)) +@ %def kingraph_extract_resonance_history +@ Determine the number of valid [[kingraphs]] in [[grove_list]]. +<>= + public :: grove_list_get_n_trees +<>= + module function grove_list_get_n_trees (grove_list) result (n) + class(grove_list_t), intent(in) :: grove_list + integer :: n + end function grove_list_get_n_trees +<>= + module function grove_list_get_n_trees (grove_list) result (n) + class(grove_list_t), intent(in) :: grove_list + integer :: n + type(kingraph_t), pointer :: kingraph + type(grove_t), pointer :: grove + if (debug_on) call msg_debug (D_PHASESPACE, "grove_list_get_n_trees") + n = 0 + grove => grove_list%first + do while (associated (grove)) + kingraph => grove%first + do while (associated (kingraph)) + if (kingraph%keep) n = n + 1 + kingraph => kingraph%grove_next + end do + grove => grove%next + end do + if (debug_on) call msg_debug (D_PHASESPACE, "n", n) + end function grove_list_get_n_trees - call generator%generate_fsr_in (p_born, p_real) +@ %def grove_list_get_n_trees +@ Extract the resonance histories from the [[feyngraph_set]], in complete +analogy to [[cascade_set_get_resonance_histories]] +<>= + public :: feyngraph_set_get_resonance_histories +<>= + module subroutine feyngraph_set_get_resonance_histories & + (feyngraph_set, n_filter, res_hists) + type(feyngraph_set_t), intent(in), target :: feyngraph_set + integer, intent(in), optional :: n_filter + type(resonance_history_t), dimension(:), allocatable, intent(out) :: & + res_hists + end subroutine feyngraph_set_get_resonance_histories +<>= + module subroutine feyngraph_set_get_resonance_histories & + (feyngraph_set, n_filter, res_hists) + type(feyngraph_set_t), intent(in), target :: feyngraph_set + integer, intent(in), optional :: n_filter + type(resonance_history_t), dimension(:), allocatable, intent(out) :: & + res_hists + type(kingraph_t), pointer :: kingraph + type(grove_t), pointer :: grove + type(resonance_history_t) :: res_hist + type(resonance_history_set_t) :: res_hist_set + integer :: i_grove + if (debug_on) call msg_debug & + (D_PHASESPACE, "grove_list_get_resonance_histories") + call res_hist_set%init (n_filter = n_filter) + grove => feyngraph_set%grove_list%first + i_grove = 0 + do while (associated (grove)) + i_grove = i_grove + 1 + kingraph => grove%first + do while (associated (kingraph)) + if (kingraph%keep) then + if (debug_on) call msg_debug2 (D_PHASESPACE, "grove", i_grove) + call kingraph%extract_resonance_history & + (res_hist, feyngraph_set%model, feyngraph_set%n_out) + call res_hist_set%enter (res_hist) + end if + kingraph => kingraph%grove_next + end do + end do + call res_hist_set%freeze () + call res_hist_set%to_array (res_hists) + end subroutine feyngraph_set_get_resonance_histories - p_top = generator%real_kinematics%xi_ref_momenta(leg) +@ %def feyngraph_set_get_resonance_histories +@ +<<[[cascades2_ut.f90]]>>= +<> - q0 = p_top**1 - sqrts = two * p_born(1)%p(0) - mtop = m1s_to_mpole (sqrts) - if (sqrts**2 - four * mtop**2 > zero) then - boost_to_top = inverse (boost (p_top, q0)) - else - boost_to_top = identity - end if - p_tmp_born = boost_to_top * p_tmp_born +module cascades2_ut + use unit_tests + use cascades2_uti - generator%i_fsr_first = 1 - call generator%generate_fsr_out (emitter, i_phs, p_tmp_born, & - p_tmp_real, q0, 2, xi_y_phi) - p_tmp_real = inverse (boost_to_top) * p_tmp_real +<> - p_real(ass_boson(leg)) = p_tmp_real(1) - p_real(ass_quark(leg)) = p_tmp_real(2) - p_real(ass_boson(other_leg)) = p_born(ass_boson(other_leg)) - p_real(ass_quark(other_leg)) = p_born(ass_quark(other_leg)) - p_real(THR_POS_GLUON) = p_tmp_real(3) +<> - end subroutine phs_fks_generator_generate_fsr_threshold +contains -@ %def phs_fks_generator_generate_fsr_threshold -@ -<>= - procedure :: generate_fsr_in => phs_fks_generator_generate_fsr_in -<>= - subroutine phs_fks_generator_generate_fsr_in (generator, p_born, p_real) - class(phs_fks_generator_t), intent(inout) :: generator - type(vector4_t), intent(in), dimension(:) :: p_born - type(vector4_t), intent(inout), dimension(:) :: p_real - integer :: i - do i = 1, generator%n_in - p_real(i) = p_born(i) - end do - end subroutine phs_fks_generator_generate_fsr_in +<> -@ %def phs_fks_generator_generate_fsr_in +end module cascades2_ut +@ %def cascades2_ut @ -<>= - procedure :: generate_fsr_out => phs_fks_generator_generate_fsr_out -<>= - subroutine phs_fks_generator_generate_fsr_out (generator, & - emitter, i_phs, p_born, p_real, q0, p_emitter_index, xi_y_phi, no_jacobians) - class(phs_fks_generator_t), intent(inout) :: generator - integer, intent(in) :: emitter, i_phs - type(vector4_t), intent(in), dimension(:) :: p_born - type(vector4_t), intent(inout), dimension(:) :: p_real - real(default), intent(in) :: q0 - integer, intent(in), optional :: p_emitter_index - real(default), intent(in), dimension(3), optional :: xi_y_phi - logical, intent(in), optional :: no_jacobians - real(default) :: xi, y, phi - integer :: nlegborn, nlegreal - real(default) :: uk_np1, uk_n - real(default) :: uk_rec, k_rec0 - type(vector3_t) :: k_n_born, k - real(default) :: uk_n_born, uk, k2, k0_n - real(default) :: cpsi, beta - type(vector3_t) :: vec, vec_orth - type(lorentz_transformation_t) :: rot - integer :: i, p_em - logical :: compute_jac - p_em = emitter; if (present (p_emitter_index)) p_em = p_emitter_index - compute_jac = .true. - if (present (no_jacobians)) compute_jac = .not. no_jacobians - if (generator%i_fsr_first < 0) & - call msg_fatal ("FSR generator is called for outgoing particles but "& - &"i_fsr_first is not set!") +<<[[cascades2_uti.f90]]>>= +<> - if (present (xi_y_phi)) then - xi = xi_y_phi(I_XI) - y = xi_y_phi(I_Y) - phi = xi_y_phi(I_PHI) - else - associate (rad_var => generator%real_kinematics) - xi = rad_var%xi_tilde - if (rad_var%supply_xi_max) xi = xi * rad_var%xi_max(i_phs) - y = rad_var%y(i_phs) - phi = rad_var%phi - end associate - end if +module cascades2_uti - nlegborn = size (p_born) - nlegreal = nlegborn + 1 - generator%E_gluon = q0 * xi / two - uk_np1 = generator%E_gluon - k_n_born = p_born(p_em)%p(1:3) - uk_n_born = k_n_born**1 +<> +<> + use numeric_utils - generator%mrec2 = (q0 - p_born(p_em)%p(0))**2 & - - space_part_norm(p_born(p_em))**2 - if (generator%is_massive(emitter)) then - call generator%compute_emitter_kinematics (y, emitter, & - i_phs, q0, k0_n, uk_n, uk, compute_jac) - else - call generator%compute_emitter_kinematics (y, q0, uk_n, uk) - generator%real_kinematics%y_soft(i_phs) = y - k0_n = uk_n - end if + use cascades2 + use flavors + use phs_forests, only: phs_parameters_t + use model_data - if (debug_on) call msg_debug2 (D_PHASESPACE, "phs_fks_generator_generate_fsr_out") - call debug_input_values () +<> - vec = uk_n / uk_n_born * k_n_born - vec_orth = create_orthogonal (vec) - p_real(p_em)%p(0) = k0_n - p_real(p_em)%p(1:3) = vec%p(1:3) - cpsi = (uk_n**2 + uk**2 - uk_np1**2) / (two * uk_n * uk) - !!! This is to catch the case where cpsi = 1, but numerically - !!! turns out to be slightly larger than 1. - call check_cpsi_bound (cpsi) - rot = rotation (cpsi, - sqrt (one - cpsi**2), vec_orth) - p_real(p_em) = rot * p_real(p_em) - vec = uk_np1 / uk_n_born * k_n_born - vec_orth = create_orthogonal (vec) - p_real(nlegreal)%p(0) = uk_np1 - p_real(nlegreal)%p(1:3) = vec%p(1:3) - cpsi = (uk_np1**2 + uk**2 - uk_n**2) / (two * uk_np1 * uk) - call check_cpsi_bound (cpsi) - rot = rotation (cpsi, sqrt (one - cpsi**2), vec_orth) - p_real(nlegreal) = rot * p_real(nlegreal) - call construct_recoiling_momenta () - if (compute_jac) call compute_jacobians () +<> - contains +contains -<> +<> - end subroutine phs_fks_generator_generate_fsr_out +end module cascades2_uti +@ %def cascades2_uti +@ API: driver for the unit tests below. +<>= + public :: cascades2_test +<>= + subroutine cascades2_test (u, results) + integer, intent(in) :: u + type(test_results_t), intent(inout) :: results + <> + end subroutine cascades2_test + +@ %def cascades2_test -@ %def phs_fks_generator_generate_fsr_out @ -<>= - subroutine debug_input_values () - if (debug2_active (D_PHASESPACE)) then - call generator%write () - print *, 'emitter = ', emitter - print *, 'p_born:' - call vector4_write_set (p_born) - print *, 'p_real:' - call vector4_write_set (p_real) - print *, 'q0 = ', q0 - if (present(p_emitter_index)) then - print *, 'p_emitter_index = ', p_emitter_index - else - print *, 'p_emitter_index not given' - end if - end if - end subroutine debug_input_values +<>= + call test (cascades2_1, "cascades2_1", & + "make phase-space", u, results) + call test (cascades2_2, "cascades2_2", & + "make phase-space (scattering)", u, results) +<>= + public :: cascades2_1 +<>= + subroutine cascades2_1 (u) + integer, intent(in) :: u + type(feyngraph_set_t) :: feyngraph_set + type(model_data_t) :: model + integer :: n_in = 1 + integer :: n_out = 6 + type(flavor_t), dimension(7,1) :: flv + type(phs_parameters_t) :: phs_par + logical :: fatal_beam_decay = .true. + integer :: u_in = 8 -<>= - subroutine check_cpsi_bound (cpsi) - real(default), intent(inout) :: cpsi - if (cpsi > one) then - cpsi = one - else if (cpsi < -one) then - cpsi = - one - end if - end subroutine check_cpsi_bound + write (u, "(A)") "* Test output: cascades2_1" + write (u, "(A)") "* Purpose: create a test phs file (decay) with the forest" + write (u, "(A)") "* output of O'Mega" + write (u, "(A)") -@ Construction of the recoiling momenta. The reshuffling of momenta -must not change the invariant mass of the recoiling system, which -means $k_{\rm{rec}}^2 = \bar{k_{\rm{rec}}}^2$. Therefore, the momenta -are related by a boost, $\bar{k}_i = \Lambda k_i$. The boost parameter -is -\begin{equation*} - \beta = \frac{q^2 - (k_{\rm{rec}}^0 + - \underline{k}_{\rm{rec}})^2}{q^2 + (k_{\rm{rec}}^0 + - \underline{k}_{\rm{rec}})^2} -\end{equation*} -<>= - subroutine construct_recoiling_momenta () - type(lorentz_transformation_t) :: lambda - k_rec0 = q0 - p_real(p_em)%p(0) - p_real(nlegreal)%p(0) - if (k_rec0**2 > generator%mrec2) then - uk_rec = sqrt (k_rec0**2 - generator%mrec2) - else - uk_rec = 0 - end if - if (generator%is_massive(emitter)) then - beta = compute_beta (q0**2, k_rec0, uk_rec, & - p_born(p_em)%p(0), uk_n_born) - else - beta = compute_beta (q0**2, k_rec0, uk_rec) - end if - k = p_real(p_em)%p(1:3) + p_real(nlegreal)%p(1:3) - vec%p(1:3) = one / uk * k%p(1:3) - lambda = boost (beta / sqrt(one - beta**2), vec) - do i = generator%i_fsr_first, nlegborn - if (i /= p_em) then - p_real(i) = lambda * p_born(i) - end if - end do - vec%p(1:3) = p_born(p_em)%p(1:3) / uk_n_born - rot = rotation (cos(phi), sin(phi), vec) - p_real(nlegreal) = rot * p_real(nlegreal) - p_real(p_em) = rot * p_real(p_em) - end subroutine construct_recoiling_momenta + write (u, "(A)") "* Initializing" + write (u, "(A)") -@ The factor $\frac{q^2}{(4\pi)^3}$ is not included here since it is -supplied during phase space generation. Also, we already divide by -$\xi$. -<>= - subroutine compute_jacobians () - associate (jac => generator%real_kinematics%jac(i_phs)) - if (generator%is_massive(emitter)) then - jac%jac(1) = jac%jac(1) * four / q0 / uk_n_born / xi - else - k2 = two * uk_n * uk_np1* (one - y) - jac%jac(1) = uk_n**2 / uk_n_born / (uk_n - k2 / (two * q0)) - end if - jac%jac(2) = one - jac%jac(3) = one - xi / two * q0 / uk_n_born - end associate - end subroutine compute_jacobians + call init_sm_full_test (model) -@ %def compute_jacobians -@ -<>= - procedure :: generate_fsr_in => phs_fks_generate_fsr_in -<>= - subroutine phs_fks_generate_fsr_in (phs) - class(phs_fks_t), intent(inout) :: phs - type(vector4_t), dimension(:), allocatable :: p - p = phs%generator%real_kinematics%p_born_lab%get_momenta (1, phs%generator%n_in) - end subroutine phs_fks_generate_fsr_in + call flv(1,1)%init (6, model) + call flv(2,1)%init (5, model) + call flv(3,1)%init (-11, model) + call flv(4,1)%init (12, model) + call flv(5,1)%init (21, model) + call flv(6,1)%init (22, model) + call flv(7,1)%init (21, model) -@ %def phs_fks_generate_fsr_in -@ -<>= - procedure :: generate_fsr => phs_fks_generate_fsr -<>= - subroutine phs_fks_generate_fsr (phs, emitter, i_phs, p_real, i_con, & - xi_y_phi, no_jacobians) - class(phs_fks_t), intent(inout) :: phs - integer, intent(in) :: emitter, i_phs - type(vector4_t), intent(inout), dimension(:) :: p_real - integer, intent(in), optional :: i_con - real(default), intent(in), dimension(3), optional :: xi_y_phi - logical, intent(in), optional :: no_jacobians - type(vector4_t), dimension(:), allocatable :: p - associate (generator => phs%generator) - p = generator%real_kinematics%p_born_cms%phs_point(1) - generator%real_kinematics%supply_xi_max = .true. - if (present (i_con)) then - call generator%generate_fsr (emitter, i_phs, i_con, p, p_real, & - xi_y_phi, no_jacobians) - else - call generator%generate_fsr (emitter, i_phs, p, p_real, & - xi_y_phi, no_jacobians) - end if - generator%real_kinematics%p_real_cms%phs_point(i_phs) = p_real - if (.not. phs%config%lab_is_cm) p_real = phs%lt_cm_to_lab * p_real - generator%real_kinematics%p_real_lab%phs_point(i_phs) = p_real - end associate - end subroutine phs_fks_generate_fsr + phs_par%sqrts = 173.1_default + phs_par%m_threshold_s = 50._default + phs_par%m_threshold_t = 100._default + phs_par%keep_nonresonant = .true. + phs_par%off_shell = 2 -@ %def phs_fks_generate_fsr -@ -<>= - procedure :: get_onshell_projected_momenta => phs_fks_get_onshell_projected_momenta -<>= - pure function phs_fks_get_onshell_projected_momenta (phs) result (p) - type(vector4_t), dimension(:), allocatable :: p - class(phs_fks_t), intent(in) :: phs - p = phs%generator%real_kinematics%p_born_onshell%phs_point(1) - end function phs_fks_get_onshell_projected_momenta + open (unit=u_in, file="cascades2_1.fds", status='old', action='read') -@ %def phs_fks_get_onshell_projected_momenta -@ -<>= - procedure :: generate_fsr_threshold => phs_fks_generate_fsr_threshold -<>= - subroutine phs_fks_generate_fsr_threshold (phs, emitter, i_phs, p_real) - class(phs_fks_t), intent(inout) :: phs - integer, intent(in) :: emitter, i_phs - type(vector4_t), intent(inout), dimension(:), optional :: p_real - type(vector4_t), dimension(:), allocatable :: p_born - type(vector4_t), dimension(:), allocatable :: pp - integer :: leg - associate (generator => phs%generator) - generator%real_kinematics%supply_xi_max = .true. - allocate (p_born (1 : generator%real_kinematics%p_born_cms%get_n_particles())) - p_born = generator%real_kinematics%p_born_onshell%get_momenta (1) - allocate (pp (size (p_born) + 1)) - call generator%generate_fsr_threshold (emitter, i_phs, p_born, pp) - leg = thr_leg (emitter) - call generator%real_kinematics%p_real_onshell(leg)%set_momenta (i_phs, pp) - if (present (p_real)) p_real = pp - end associate - end subroutine phs_fks_generate_fsr_threshold + write (u, "(A)") + write (u, "(A)") "* Generating phase-space parametrizations" + write (u, "(A)") -@ %def phs_fks_generate_fsr_threshold -@ -<>= - generic :: compute_xi_max => compute_xi_max_internal, compute_xi_max_with_output - procedure :: compute_xi_max_internal => phs_fks_compute_xi_max_internal -<>= - subroutine phs_fks_compute_xi_max_internal (phs, p, threshold) - class(phs_fks_t), intent(inout) :: phs - type(vector4_t), intent(in), dimension(:) :: p - logical, intent(in) :: threshold - integer :: i_phs, i_con, emitter - do i_phs = 1, size (phs%phs_identifiers) - associate (phs_id => phs%phs_identifiers(i_phs), generator => phs%generator) - emitter = phs_id%emitter - if (threshold) then - call generator%compute_xi_max (emitter, i_phs, p, & - generator%real_kinematics%xi_max(i_phs), i_con = thr_leg(emitter)) - else if (allocated (phs_id%contributors)) then - do i_con = 1, size (phs_id%contributors) - call generator%compute_xi_max (emitter, i_phs, p, & - generator%real_kinematics%xi_max(i_phs), i_con = 1) - end do - else - call generator%compute_xi_max (emitter, i_phs, p, & - generator%real_kinematics%xi_max(i_phs)) - end if - end associate - end do - end subroutine phs_fks_compute_xi_max_internal + call feyngraph_set_generate (feyngraph_set, model, n_in, n_out, & + flv, phs_par, fatal_beam_decay, u_in, use_dag = .false., & + vis_channels = .false.) + call feyngraph_set_write_process_bincode_format (feyngraph_set, u) + call feyngraph_set_write_file_format (feyngraph_set, u) -@ %def phs_fks_compute_xi_max -@ -<>= - procedure :: compute_xi_max_with_output => phs_fks_compute_xi_max_with_output -<>= - subroutine phs_fks_compute_xi_max_with_output (phs, emitter, i_phs, y, p, xi_max) - class(phs_fks_t), intent(inout) :: phs - integer, intent(in) :: i_phs, emitter - real(default), intent(in) :: y - type(vector4_t), intent(in), dimension(:) :: p - real(default), intent(out) :: xi_max - call phs%generator%compute_xi_max (emitter, i_phs, p, xi_max, y_in = y) - end subroutine phs_fks_compute_xi_max_with_output + write (u, "(A)") "* Cleanup" + write (u, "(A)") -@ %def phs_fks_compute_xi_max_with_output + close (u_in) + call feyngraph_set%final () + call model%final () + + write (u, *) + write (u, "(A)") "* Test output end: cascades2_1" + end subroutine cascades2_1 + +@ %def cascades2_1 @ -<>= - generic :: compute_emitter_kinematics => & - compute_emitter_kinematics_massless, & - compute_emitter_kinematics_massive - procedure :: compute_emitter_kinematics_massless => & - phs_fks_generator_compute_emitter_kinematics_massless - procedure :: compute_emitter_kinematics_massive => & - phs_fks_generator_compute_emitter_kinematics_massive -<>= - subroutine phs_fks_generator_compute_emitter_kinematics_massless & - (generator, y, q0, uk_em, uk) - class(phs_fks_generator_t), intent(inout) :: generator - real(default), intent(in) :: y, q0 - real(default), intent(out) :: uk_em, uk - real(default) :: k0_np1, q2 +<>= + public :: cascades2_2 +<>= + subroutine cascades2_2 (u) + integer, intent(in) :: u + type(feyngraph_set_t) :: feyngraph_set + type(model_data_t) :: model + integer :: n_in = 2 + integer :: n_out = 5 + type(flavor_t), dimension(7,1) :: flv + type(phs_parameters_t) :: phs_par + logical :: fatal_beam_decay = .true. + integer :: u_in = 8 - k0_np1 = generator%E_gluon - q2 = q0**2 + write (u, "(A)") "* Test output: cascades2_2" + write (u, "(A)") "* Purpose: create a test phs file (scattering) with the" + write (u, "(A)") "* parsable DAG output of O'Mega" + write (u, "(A)") - uk_em = (q2 - generator%mrec2 - two * q0 * k0_np1) / (two * (q0 - k0_np1 * (one - y))) - uk = sqrt (uk_em**2 + k0_np1**2 + two * uk_em * k0_np1 * y) - end subroutine phs_fks_generator_compute_emitter_kinematics_massless + write (u, "(A)") "* Initializing" + write (u, "(A)") - subroutine phs_fks_generator_compute_emitter_kinematics_massive & - (generator, y, em, i_phs, q0, k0_em, uk_em, uk, compute_jac) - class(phs_fks_generator_t), intent(inout) :: generator - real(default), intent(in) :: y - integer, intent(in) :: em, i_phs - real(default), intent(in) :: q0 - real(default), intent(inout) :: k0_em, uk_em, uk - logical, intent(in) :: compute_jac - real(default) :: k0_np1, q2, mrec2, m2 - real(default) :: k0_rec_max, k0_em_max, k0_rec, uk_rec - real(default) :: z, z1, z2 + call init_sm_full_test (model) - k0_np1 = generator%E_gluon - q2 = q0**2 - mrec2 = generator%mrec2 - m2 = generator%m2(em) + call flv(1,1)%init (-11, model) + call flv(2,1)%init (11, model) + call flv(3,1)%init (-11, model) + call flv(4,1)%init (12, model) + call flv(5,1)%init (1, model) + call flv(6,1)%init (-2, model) + call flv(7,1)%init (22, model) - k0_rec_max = (q2 - m2 + mrec2) / (two * q0) - k0_em_max = (q2 + m2 - mrec2) /(two * q0) - z1 = (k0_rec_max + sqrt (k0_rec_max**2 - mrec2)) / q0 - z2 = (k0_rec_max - sqrt (k0_rec_max**2 - mrec2)) / q0 - z = z2 - (z2 - z1) * (one + y) / two - k0_em = k0_em_max - k0_np1 * z - k0_rec = q0 - k0_np1 - k0_em - uk_em = sqrt(k0_em**2 - m2) - uk_rec = sqrt(k0_rec**2 - mrec2) - uk = uk_rec - if (compute_jac) & - generator%real_kinematics%jac(i_phs)%jac = q0 * (z1 - z2) / four * k0_np1 - generator%real_kinematics%y_soft(i_phs) = & - (two * q2 * z - q2 - mrec2 + m2) / (sqrt(k0_em_max**2 - m2) * q0) / two - end subroutine phs_fks_generator_compute_emitter_kinematics_massive + phs_par%sqrts = 500._default + phs_par%m_threshold_s = 50._default + phs_par%m_threshold_t = 100._default + phs_par%keep_nonresonant = .true. + phs_par%off_shell = 2 + phs_par%t_channel = 6 -@ %def phs_fks_generator_compute_emitter_kinematics -@ -<>= - function recompute_xi_max (q0, mrec2, m2, y) result (xi_max) - real(default) :: xi_max - real(default), intent(in) :: q0, mrec2, m2, y - real(default) :: q2, k0_np1_max, k0_rec_max - real(default) :: z1, z2, z - q2 = q0**2 - k0_rec_max = (q2 - m2 + mrec2) / (two * q0) - z1 = (k0_rec_max + sqrt (k0_rec_max**2 - mrec2)) / q0 - z2 = (k0_rec_max - sqrt (k0_rec_max**2 - mrec2)) / q0 - z = z2 - (z2 - z1) * (one + y) / 2 - k0_np1_max = - (q2 * z**2 - two * q0 * k0_rec_max * z + mrec2) / (two * q0 * z * (one - z)) - xi_max = two * k0_np1_max / q0 - end function recompute_xi_max + open (unit=u_in, file="cascades2_2.fds", & + status='old', action='read') -@ %def recompute_xi_max -@ -<>= - function compute_beta_massless (q2, k0_rec, uk_rec) result (beta) - real(default), intent(in) :: q2, k0_rec, uk_rec - real(default) :: beta - beta = (q2 - (k0_rec + uk_rec)**2) / (q2 + (k0_rec + uk_rec)**2) - end function compute_beta_massless + write (u, "(A)") + write (u, "(A)") "* Generating phase-space parametrizations" + write (u, "(A)") - function compute_beta_massive (q2, k0_rec, uk_rec, & - k0_em_born, uk_em_born) result (beta) - real(default), intent(in) :: q2, k0_rec, uk_rec - real(default), intent(in) :: k0_em_born, uk_em_born - real(default) :: beta - real(default) :: k0_rec_born, uk_rec_born, alpha - k0_rec_born = sqrt(q2) - k0_em_born - uk_rec_born = uk_em_born - alpha = (k0_rec + uk_rec) / (k0_rec_born + uk_rec_born) - beta = (one - alpha**2) / (one + alpha**2) - end function compute_beta_massive + call feyngraph_set_generate (feyngraph_set, model, n_in, n_out, & + flv, phs_par, fatal_beam_decay, u_in, use_dag = .true., & + vis_channels = .false.) + call feyngraph_set_write_process_bincode_format (feyngraph_set, u) + call feyngraph_set_write_file_format (feyngraph_set, u) -@ %def compute_beta -@ The momentum of the radiated particle is computed according to -\begin{equation} - \label{eq:phs_fks:compute_k_n} - \underline{k}_n = \frac{q^2 - M_{\rm{rec}}^2 - - 2q^0\underline{k}_{n+1}}{2(q^0 - \underline{k}_{n+1}(1-y))}, -\end{equation} -with $k = k_n + k_{n+1}$ and $M_{\rm{rec}}^2 = k_{\rm{rec}}^2 = -\left(q-k\right)^2$. Because of $\boldsymbol{\bar{k}}_n \parallel -\boldsymbol{k}_n + \boldsymbol{k}_{n+1}$ we find $M_{\rm{rec}}^2 = -\left(q-\bar{k}_n\right)^2$. -Equation \ref{eq:phs_fks:compute_k_n} follows from the fact that -$\left(\boldsymbol{k} - \boldsymbol{k}_n\right)^2 = -\boldsymbol{k}_{n+1}^2$, which is equivalent to $\boldsymbol{k}_n -\cdot \boldsymbol{k} = \frac{1}{2} \left(\underline{k}_n^2 + - \underline{k}^2 - \underline{k}_{n+1}^2\right)$.\\ -$\boldsymbol{k}_n$ and $\boldsymbol{k}_{n+1}$ are obtained by first -setting up vectors parallel to $\boldsymbol{\bar{k}}_n$, -\begin{equation*} - \boldsymbol{k}_n' = \underline{k}_n - \frac{\bar{\pmb{k}}_n}{\underline{\bar{k}}_n}, \quad \pmb{k}_{n+1}' - = \underline{k}_{n+1}\frac{\bar{\pmb{k}}_n}{\underline{\bar{k}}_n}, -\end{equation*} -and then rotating these vectors by an amount of $\cos\psi_n = -\frac{\boldsymbol{k}_n\cdot\pmb{k}}{\underline{k}_n \underline{k}}$. -@ The emitted particle cannot have more momentum than the emitter has -in the Born phase space. Thus, there is an upper bound for $\xi$, -determined by the condition $k_{n+1}^0 = \underline{\bar{k}}_n$, which -is equal to -\begin{equation*} -\xi_{\rm{max}} = \frac{2}{\underline{\bar{k}}_n}{q^0}. -\end{equation*} -<>= - pure function get_xi_max_fsr_massless (p_born, q0, emitter) result (xi_max) - type(vector4_t), intent(in), dimension(:) :: p_born - real(default), intent(in) :: q0 - integer, intent(in) :: emitter - real(default) :: xi_max - real(default) :: uk_n_born - uk_n_born = space_part_norm (p_born(emitter)) - xi_max = two * uk_n_born / q0 - end function get_xi_max_fsr_massless + write (u, "(A)") "* Cleanup" + write (u, "(A)") -@ %def get_xi_max_fsr_massless -@ The computation of $\xi_{\rm{max}}$ for massive emitters is described -in arXiv:1202.0465. Let's recapitulate it here. + close (u_in) + call feyngraph_set%final () + call model%final () -We consider the Dalitz-domain created by $k_{n+1}^0$, $k_n^0$ and -$k_{\rm{rec}}^0$ and introduce the parameterization -\begin{equation*} - k_n^0 = \bar{k}_n^0 - zk_{n+1}^0 -\end{equation*} -Then, for each value of $z$, there exists a maximum value of -$\underline{k}_{n+1}$ from which $\xi_{\rm{max}}$ can be extracted via -$\xi_{\rm{max}} = 2k_{n+1}^0/q$. It is determined by the condition -\begin{equation*} - \underline{k}_{n+1} \pm \underline{k}_n \pm \underline{k}_{\rm{rec}} = 0. -\end{equation*} -This can be manipulated to yield -\begin{equation*} - \left(\underline{k}_{n+1}^2 + \underline{k}_n^2 - - \underline{k}_{\rm{rec}}^2\right)^2 = - 4\underline{k}^2_{n+1}\underline{k}_n^2. -\end{equation*} -Here we can use $\underline{k}_n^2 = \left(k_n^0\right)^2 - m^2$ and -$\underline{k}_{\rm{rec}}^2 = \left(q - k_n^0 - k_{n+1}^0\right)^2 - -M_{\rm{rec}}^2$, as well as the above parameterization of $k_n^0$, to -obtain -\begin{equation*} - 4\underline{k}_{n+1}^2\left(2\underline{k}_{n+1}qz(1-z) + - q^2z^2 - 2q\bar{k}_{\rm{rec}}^0z + M_{\rm{rec}}^2\right) = 0. -\end{equation*} -Solving for $k_{n+1}^0$ gives -\begin{equation} - k_{n+1}^0 = \frac{2q\bar{k}^0_{\rm{rec}}z - q^2z^2 - M_{\rm{rec}}^2}{2qz(1-z)}. - \label{XiMaxMassive} -\end{equation} -It is still open how to compute $z$. For this, consider that the -right-hand-side of equation (\ref{XiMaxMassive}) vanishes for -\begin{equation*} - z_{1,2} = \left(\bar{k}_{\rm{rec}}^0 \pm - \sqrt{\left(\bar{k}_{\rm{rec}}^0\right)^2 - M_{\rm{rec}}^2}\right)/q, -\end{equation*} -which corresponds to the borders of the Dalitz-region where the gluon -momentum vanishes. Thus we define -\begin{equation*} - z = z_2 - \frac{1}{2} (z_2 - z_1)(1+y). -\end{equation*} -<>= - pure function get_xi_max_fsr_massive (p_born, q0, emitter, m2, y) result (xi_max) - real(default) :: xi_max - type(vector4_t), intent(in), dimension(:) :: p_born - real(default), intent(in) :: q0 - integer, intent(in) :: emitter - real(default), intent(in) :: m2, y - real(default) :: mrec2 - real(default) :: k0_rec_max - real(default) :: z, z1, z2 - real(default) :: k0_np1_max - associate (p => p_born(emitter)%p) - mrec2 = (q0 - p(0))**2 - p(1)**2 - p(2)**2 - p(3)**2 - end associate - call compute_dalitz_bounds (q0, m2, mrec2, z1, z2, k0_rec_max) - z = z2 - (z2 - z1) * (one + y) / two - k0_np1_max = - (q0**2 * z**2 - two * q0 * k0_rec_max * z + mrec2) & - / (two * q0 * z * (one - z)) - xi_max = two * k0_np1_max / q0 - end function get_xi_max_fsr_massive + write (u, *) + write (u, "(A)") "* Test output end: cascades2_2" + end subroutine cascades2_2 -@ %def get_xi_max_fsr_massive +@ %def cascades2_2 @ -<>= - integer, parameter, public :: I_PLUS = 1 - integer, parameter, public :: I_MINUS = 2 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{WOOD phase space} -@ %def parameters -@ Computes $\xi_{\text{max}}$ in the case of ISR as documented in eq. \ref{eqn:xi_max_isr}. -<>= - function get_xi_max_isr (xb, y) result (xi_max) - real(default) :: xi_max - real(default), dimension(2), intent(in) :: xb - real(default), intent(in) :: y - xi_max = one - max (xi_max_isr_plus (xb(I_PLUS), y), xi_max_isr_minus (xb(I_MINUS), y)) - contains - function xi_max_isr_plus (x, y) - real(default) :: xi_max_isr_plus - real(default), intent(in) :: x, y - real(default) :: deno - deno = sqrt ((one + x**2)**2 * (one - y)**2 + 16 * y * x**2) + (one - y) * (1 - x**2) - xi_max_isr_plus = two * (one + y) * x**2 / deno - end function xi_max_isr_plus +This is the module that interfaces the [[phs_forests]] phase-space +treatment and the [[cascades]] module for generating phase-space +channels. As an extension of the [[phs_base]] abstract type, +the phase-space configuration and instance implement the standard API. - function xi_max_isr_minus (x, y) - real(default) :: xi_max_isr_minus - real(default), intent(in) :: x, y - real(default) :: deno - deno = sqrt ((one + x**2)**2 * (one + y)**2 - 16 * y * x**2) + (one + y) * (1 - x**2) - xi_max_isr_minus = two * (one - y) * x**2 / deno - end function xi_max_isr_minus - end function get_xi_max_isr +(Currently, this is the only generic phase-space implementation of +\whizard. For trivial two-particle phase space, there is +[[phs_wood]] as an alternative.) +<<[[phs_wood.f90]]>>= +<> -@ %def get_xi_max_isr -@ -<>= - recursive function get_xi_max_isr_decay (p) result (xi_max) - real(default) :: xi_max - type(vector4_t), dimension(:), intent(in) :: p - integer :: n_tot - type(vector4_t), dimension(:), allocatable :: p_dec_new - n_tot = size (p) - if (n_tot == 3) then - xi_max = xi_max_one_to_two (p(1), p(2), p(3)) - else - allocate (p_dec_new (n_tot - 1)) - p_dec_new(1) = sum (p (3 : )) - p_dec_new(2 : n_tot - 1) = p (3 : n_tot) - xi_max = min (xi_max_one_to_two (p(1), p(2), sum(p(3 : ))), & - get_xi_max_isr_decay (p_dec_new)) - end if - contains - function xi_max_one_to_two (p_in, p_out1, p_out2) result (xi_max) - real(default) :: xi_max - type(vector4_t), intent(in) :: p_in, p_out1, p_out2 - real(default) :: m_in, m_out1, m_out2 - m_in = p_in**1 - m_out1 = p_out1**1; m_out2 = p_out2**1 - xi_max = one - (m_out1 + m_out2)**2 / m_in**2 - end function xi_max_one_to_two - end function get_xi_max_isr_decay +module phs_wood -@ %def get_xi_max_isr_decay -@ -\subsection{Creation of the real phase space - ISR} -<>= - procedure :: generate_isr => phs_fks_generate_isr -<>= - subroutine phs_fks_generate_isr (phs, i_phs, p_real) - class(phs_fks_t), intent(inout) :: phs - integer, intent(in) :: i_phs - type(vector4_t), intent(inout), dimension(:) :: p_real - type(vector4_t) :: p0, p1 - type(lorentz_transformation_t) :: lt - real(default) :: sqrts_hat - type(vector4_t), dimension(:), allocatable :: p_work +<> +<> + use os_interface + use lorentz + use model_data + use flavors + use phs_base + use mappings + use resonances, only: resonance_history_set_t + use phs_forests + use cascades + use cascades2 - associate (generator => phs%generator) - select case (generator%n_in) - case (1) - p_work = generator%real_kinematics%p_born_cms%phs_point(1) - call generator%generate_isr_fixed_beam_energy (i_phs, p_work, p_real) - phs%config%lab_is_cm = .true. - case (2) - select case (generator%isr_kinematics%isr_mode) - case (SQRTS_FIXED) - p_work = generator%real_kinematics%p_born_cms%phs_point(1) - call generator%generate_isr_fixed_beam_energy (i_phs, p_work, p_real) - case (SQRTS_VAR) - p_work = generator%real_kinematics%p_born_lab%phs_point(1) - call generator%generate_isr (i_phs, p_work, p_real) - end select - end select - generator%real_kinematics%p_real_lab%phs_point(i_phs) = p_real - if (.not. phs%config%lab_is_cm) then - sqrts_hat = (p_real(1) + p_real(2))**1 - p0 = p_real(1) + p_real(2) - lt = boost (p0, sqrts_hat) - p1 = inverse(lt) * p_real(1) - lt = lt * rotation_to_2nd (3, space_part (p1)) - phs%generator%real_kinematics%p_real_cms%phs_point(i_phs) & - = inverse (lt) * p_real - else - phs%generator%real_kinematics%p_real_cms%phs_point(i_phs) & - = p_real - end if - end associate - end subroutine phs_fks_generate_isr +<> -@ %def phs_fks_generate_isr -@ The real phase space for an inital-state emission involved in a decay -process is generated by first setting the gluon momentum like in the -scattering case by using its angular coordinates $y$ and $\phi$ and then -adjusting the gluon energy with $\xi$. The emitter momentum is kept -identical to the Born case, i.e. $p_{\rm{in}} = \bar{p}_{\rm{in}}$, so -that after the emission it has momentum $p_{\rm{virt}} = p_{\rm{in}} - -p_{\rm{g}}$ and invariant mass $m^2 = p_{\rm{virt}}^2$. Note that the -final state momenta have to remain on-shell, so that $p_1^2 = -\bar{p}_1^2 = m_1^2$ and $p_2^2 = \bar{p}_2^2 = m_2^2$. Let $\Lambda$ be -the boost from into the rest frame of the emitter after emission, i.e. -$\Lambda p_{\rm{virt}} = \left(m, 0, 0, 0\right)$. In this reference -frame, the spatial components of the final-state momenta sum up to zero, -and their magnitude is -\begin{equation*} - p = \frac{\sqrt {\lambda (m^2, m_1^2, m_2^2)}}{2m}, -\end{equation*} -a fact already used in the evaluation of the phase space trees of -[[phs_forest]]. Obviously, from this, the final-state energies can be -deferred via $E_i^2 = m_i^2 - p^2$. In the next step, the $p_{1,2}$ are -set up as vectors $(E,0,0,\pm p)$ along the z-axis and then rotated -about the same azimuthal and polar angles as in the Born system. -Finally, the momenta are boosted out of the rest frame by multiplying -with $\Lambda$. -<>= - procedure :: generate_isr_fixed_beam_energy => & - phs_fks_generator_generate_isr_fixed_beam_energy -<>= - subroutine phs_fks_generator_generate_isr_fixed_beam_energy & - (generator, i_phs, p_born, p_real) - class(phs_fks_generator_t), intent(inout) :: generator - integer, intent(in) :: i_phs - type(vector4_t), intent(in), dimension(:) :: p_born - type(vector4_t), intent(inout), dimension(:) :: p_real - real(default) :: xi_max, xi, y, phi - integer :: nlegborn, nlegreal, i - real(default) :: k0_np1 - real(default) :: msq_in - type(vector4_t) :: p_virt - real(default) :: jac_real - - associate (rad_var => generator%real_kinematics) - xi_max = rad_var%xi_max(i_phs) - xi = rad_var%xi_tilde * xi_max - y = rad_var%y(i_phs) - phi = rad_var%phi - rad_var%y_soft(i_phs) = y - end associate +<> - nlegborn = size (p_born) - nlegreal = nlegborn + 1 +<> - msq_in = sum (p_born(1:generator%n_in))**2 - generator%real_kinematics%jac(i_phs)%jac = one + interface +<> + end interface - p_real(1) = p_born(1) - if (generator%n_in > 1) p_real(2) = p_born(2) - k0_np1 = zero - do i = 1, generator%n_in - k0_np1 = k0_np1 + p_real(i)%p(0) * xi / two - end do - p_real(nlegreal)%p(0) = k0_np1 - p_real(nlegreal)%p(1) = k0_np1 * sqrt(one - y**2) * sin(phi) - p_real(nlegreal)%p(2) = k0_np1 * sqrt(one - y**2) * cos(phi) - p_real(nlegreal)%p(3) = k0_np1 * y - - p_virt = sum (p_real(1:generator%n_in)) - p_real(nlegreal) - - jac_real = one - call generate_on_shell_decay (p_virt, & - p_born(generator%n_in + 1 : nlegborn), p_real(generator%n_in + 1 : nlegreal - 1), & - 1, msq_in, jac_real) - - associate (jac => generator%real_kinematics%jac(i_phs)) - jac%jac(1) = jac_real - jac%jac(2) = one - end associate +contains - end subroutine phs_fks_generator_generate_isr_fixed_beam_energy +<> -@ %def phs_fks_generator_generate_isr_fixed_beam_energy +end module phs_wood +@ %def phs_wood @ -<>= - procedure :: generate_isr_factorized => phs_fks_generator_generate_isr_factorized -<>= - subroutine phs_fks_generator_generate_isr_factorized (generator, i_phs, emitter, p_born, p_real) - class(phs_fks_generator_t), intent(inout) :: generator - integer, intent(in) :: i_phs, emitter - type(vector4_t), intent(in), dimension(:) :: p_born - type(vector4_t), intent(inout), dimension(:) :: p_real - type(vector4_t), dimension(3) :: p_tmp_born - type(vector4_t), dimension(4) :: p_tmp_real - type(vector4_t) :: p_top - type(lorentz_transformation_t) :: boost_to_rest_frame - integer, parameter :: nlegreal = 7 !!! Factorized phase space so far only required for ee -> bwbw +<<[[phs_wood_sub.f90]]>>= +<> - p_tmp_born = vector4_null; p_tmp_real = vector4_null - p_real(1:2) = p_born(1:2) - if (emitter == THR_POS_B) then - p_top = p_born (THR_POS_WP) + p_born (THR_POS_B) - p_tmp_born(2) = p_born (THR_POS_WP) - p_tmp_born(3) = p_born (THR_POS_B) - else if (emitter == THR_POS_BBAR) then - p_top = p_born (THR_POS_WM) + p_born (THR_POS_BBAR) - p_tmp_born(2) = p_born (THR_POS_WM) - p_tmp_born(3) = p_born (THR_POS_BBAR) - else - call msg_fatal ("Threshold computation requires emitters to be at position 5 and 6 " // & - "Please check if your process specification fulfills this requirement.") - end if - p_tmp_born (1) = p_top - boost_to_rest_frame = inverse (boost (p_top, p_top**1)) - p_tmp_born = boost_to_rest_frame * p_tmp_born - call generator%compute_xi_max_isr_factorized (i_phs, p_tmp_born) - call generator%generate_isr_fixed_beam_energy (i_phs, p_tmp_born, p_tmp_real) - p_tmp_real = inverse (boost_to_rest_frame) * p_tmp_real - if (emitter == THR_POS_B) then - p_real(THR_POS_WP) = p_tmp_real(2) - p_real(THR_POS_B) = p_tmp_real(3) - p_real(THR_POS_WM) = p_born(THR_POS_WM) - p_real(THR_POS_BBAR) = p_born(THR_POS_BBAR) - !!! Exception has been handled above - else - p_real(THR_POS_WM) = p_tmp_real(2) - p_real(THR_POS_BBAR) = p_tmp_real(3) - p_real(THR_POS_WP) = p_born(THR_POS_WP) - p_real(THR_POS_B) = p_born(THR_POS_B) - end if - p_real(nlegreal) = p_tmp_real(4) - end subroutine phs_fks_generator_generate_isr_factorized +submodule (phs_wood) phs_wood_s -@ %def phs_fks_generator_generate_isr_factorized -@ Construction of the real momenta [[p_real]] in case of ISR. -Follows the discussion in [0709.2092] sec. 5.1. -The sequence of Lorentz boosts required to construct [[p_real]] from [[p_born]] is as follows: -\begin{enumerate} - \item[\labelitemii] We construct the IS momenta of [[p_real]] from the Born momenta via rescaling: - [[p_real(1:2)]] $= \frac{x}{\overline{x}} \cdot$ [[p_born(1:2)]]. - If the Born momenta are imported in the lab frame, these will define the real lab frame. - \item[\labelitemii] We construct the momentum of the radiated particle in the real CMS: - $k_{n+1} = \frac{s \xi}{2} \cdot (1, \sin(\theta) \sin(\phi), \sin(\theta) \cos(\phi), \cos(\theta))$ - \setcounter{enumi}{-1} - \item We first boost the momentum of the radiated particle from the real CMS to the real - lab frame determined from [[p_real(1:2)]]. - \item We initialize the non-radiated real FS momenta by a longitudinal boost of [[p_born]] - to a system with zero rapidity, i.e. zero longitudinal momenum. This is $\mathbb{B}_L$. - \item We boost these momenta in a transverse direction to compensate the transverse momentum - of the radiation. - This is $\mathbb{B}_T$. Note: we switched $\mathbb{B}_T$ and $\mathbb{B}^{-1}_T$ in Eq. (5.16) and - their definition w.r.t. [0709.2092]. - \item We restore longitudinal momentum conservation by applying the inverse boost of $\mathbb{B}_L$ - to all non-radiated real FS momenta. -\end{enumerate} -This way, all components of [[p_real]] are constructed in the real Lab frame. -<>= - procedure :: generate_isr => phs_fks_generator_generate_isr -<>= - subroutine phs_fks_generator_generate_isr (generator, i_phs, p_born, p_real) - !!! Important: Import Born momenta in the lab frame - class(phs_fks_generator_t), intent(inout) :: generator - integer, intent(in) :: i_phs - type(vector4_t), intent(in) , dimension(:) :: p_born - type(vector4_t), intent(inout), dimension(:) :: p_real - real(default) :: xi_max, xi_tilde, xi, y, phi - integer :: nlegborn, nlegreal - real(default) :: sqrts_real - real(default) :: k0_np1 - type(lorentz_transformation_t) :: lambda_transv, lambda_longit, lambda_longit_inv - real(default) :: x_plus, x_minus, xb_plus, xb_minus - real(default) :: onemy, onepy - integer :: i - real(default) :: xi_plus, xi_minus - real(default) :: beta_gamma - type(vector3_t) :: beta_vec + use io_units + use constants + use numeric_utils + use diagnostics + use physics_defs + use md5 + use process_constants + use sf_mappings + use sf_base - associate (rad_var => generator%real_kinematics) - xi_max = rad_var%xi_max(i_phs) - xi_tilde = rad_var%xi_tilde - xi = xi_tilde * xi_max - y = rad_var%y(i_phs) - onemy = one - y; onepy = one + y - phi = rad_var%phi - rad_var%y_soft(i_phs) = y - end associate + implicit none - nlegborn = size (p_born) - nlegreal = nlegborn + 1 - generator%isr_kinematics%sqrts_born = (p_born(1) + p_born(2))**1 +contains - !!! Initial state real momenta - xb_plus = generator%isr_kinematics%x(I_PLUS) - xb_minus = generator%isr_kinematics%x(I_MINUS) - x_plus = xb_plus / sqrt(one - xi) * sqrt ((two - xi * onemy) / (two - xi * onepy)) - x_minus = xb_minus / sqrt(one - xi) * sqrt ((two - xi * onepy) / (two - xi * onemy)) - xi_plus = xi_tilde * (one - xb_plus) - xi_minus = xi_tilde * (one - xb_minus) - p_real(I_PLUS) = x_plus / xb_plus * p_born(I_PLUS) - p_real(I_MINUS) = x_minus / xb_minus * p_born(I_MINUS) +<> - !!! Fraction of momentum fractions in a collinear splitting - generator%isr_kinematics%z(I_PLUS) = (one - xi_plus) - generator%isr_kinematics%z(I_MINUS) = (one - xi_minus) +end submodule phs_wood_s - !!! Create radiation momentum in the real CMS - sqrts_real = generator%isr_kinematics%sqrts_born / sqrt (one - xi) - k0_np1 = sqrts_real * xi / two - p_real(nlegreal)%p(0) = k0_np1 - p_real(nlegreal)%p(1) = k0_np1 * sqrt (one - y**2) * sin(phi) - p_real(nlegreal)%p(2) = k0_np1 * sqrt (one - y**2) * cos(phi) - p_real(nlegreal)%p(3) = k0_np1 * y +@ %def phs_wood_s +@ +\subsection{Configuration} +<>= + public :: phs_wood_config_t +<>= + type, extends (phs_config_t) :: phs_wood_config_t + character(32) :: md5sum_forest = "" + type(string_t) :: phs_path + integer :: io_unit = 0 + logical :: io_unit_keep_open = .false. + logical :: use_equivalences = .false. + logical :: fatal_beam_decay = .true. + type(mapping_defaults_t) :: mapping_defaults + type(phs_parameters_t) :: par + type(string_t) :: run_id + type(cascade_set_t), allocatable :: cascade_set + logical :: use_cascades2 = .false. + type(feyngraph_set_t), allocatable :: feyngraph_set + type(phs_forest_t) :: forest + type(os_data_t) :: os_data + logical :: is_combined_integration = .false. + contains + <> + end type phs_wood_config_t - !!! Boosts the radiation from real CMS to the real LAB frame - call get_boost_parameters (p_real, beta_gamma, beta_vec) - lambda_longit = create_longitudinal_boost (beta_gamma, beta_vec, inverse = .true.) - p_real(nlegreal) = lambda_longit * p_real(nlegreal) +@ %def phs_wood_config_t +@ Finalizer. We should delete the cascade set and the forest subobject. - call get_boost_parameters (p_born, beta_gamma, beta_vec) - lambda_longit = create_longitudinal_boost (beta_gamma, beta_vec, inverse = .false.) - forall (i = 3 : nlegborn) p_real(i) = lambda_longit * p_born(i) +Also close the I/O unit, just in case. (We assume that [[io_unit]] is +not standard input/output.) +<>= + procedure :: final => phs_wood_config_final +<>= + module subroutine phs_wood_config_final (object) + class(phs_wood_config_t), intent(inout) :: object + end subroutine phs_wood_config_final +<>= + module subroutine phs_wood_config_final (object) + class(phs_wood_config_t), intent(inout) :: object + logical :: opened + if (object%io_unit /= 0) then + inquire (unit = object%io_unit, opened = opened) + if (opened) close (object%io_unit) + end if + call object%clear_phase_space () + call object%forest%final () + end subroutine phs_wood_config_final - lambda_transv = create_transversal_boost (p_real(nlegreal), xi, sqrts_real) - forall (i = 3 : nlegborn) p_real(i) = lambda_transv * p_real(i) +@ %def phs_wood_config_final +@ +<>= + procedure :: increase_n_par => phs_wood_config_increase_n_par +<>= + module subroutine phs_wood_config_increase_n_par (phs_config) + class(phs_wood_config_t), intent(inout) :: phs_config + end subroutine phs_wood_config_increase_n_par +<>= + module subroutine phs_wood_config_increase_n_par (phs_config) + class(phs_wood_config_t), intent(inout) :: phs_config + if (phs_config%is_combined_integration) then + phs_config%n_par = phs_config%n_par + 3 + end if + end subroutine phs_wood_config_increase_n_par - lambda_longit_inv = create_longitudinal_boost (beta_gamma, beta_vec, inverse = .true.) - forall (i = 3 : nlegborn) p_real(i) = lambda_longit_inv * p_real(i) +@ %def phs_wood_config_increase_n_par +@ Output. The contents of the PHS forest are not printed explicitly. +<>= + procedure :: write => phs_wood_config_write +<>= + module subroutine phs_wood_config_write (object, unit, include_id) + class(phs_wood_config_t), intent(in) :: object + integer, intent(in), optional :: unit + logical, intent(in), optional :: include_id + end subroutine phs_wood_config_write +<>= + module subroutine phs_wood_config_write (object, unit, include_id) + class(phs_wood_config_t), intent(in) :: object + integer, intent(in), optional :: unit + logical, intent(in), optional :: include_id + integer :: u + u = given_output_unit (unit) + write (u, "(1x,A)") & + "Partonic phase-space configuration (phase-space forest):" + call object%base_write (unit) + write (u, "(1x,A)") "Phase-space configuration parameters:" + call object%par%write (u) + call object%mapping_defaults%write (u) + write (u, "(3x,A,A,A)") "Run ID: '", char (object%run_id), "'" + end subroutine phs_wood_config_write - !!! Compute Jacobians - associate (jac => generator%real_kinematics%jac(i_phs)) - !!! Additional 1 / (1 - xi) factor because in the real jacobian, - !!! there is s_real in the numerator - !!! We also have to adapt the flux factor, which is 1/2s_real for the real component - !!! The reweighting factor is s_born / s_real, cancelling the (1-x) factor from above - jac%jac(1) = one / (one - xi) - jac%jac(2) = one - jac%jac(3) = one / (one - xi_plus)**2 - jac%jac(4) = one / (one - xi_minus)**2 - end associate - contains - subroutine get_boost_parameters (p, beta_gamma, beta_vec) - type(vector4_t), intent(in), dimension(:) :: p - real(default), intent(out) :: beta_gamma - type(vector3_t), intent(out) :: beta_vec - beta_vec = (p(1)%p(1:3) + p(2)%p(1:3)) / (p(1)%p(0) + p(2)%p(0)) - beta_gamma = beta_vec**1 / sqrt (one - beta_vec**2) - beta_vec = beta_vec / beta_vec**1 - end subroutine get_boost_parameters +@ %def phs_wood_config_write +@ Print the PHS forest contents. +<>= + procedure :: write_forest => phs_wood_config_write_forest +<>= + module subroutine phs_wood_config_write_forest (object, unit) + class(phs_wood_config_t), intent(in) :: object + integer, intent(in), optional :: unit + end subroutine phs_wood_config_write_forest +<>= + module subroutine phs_wood_config_write_forest (object, unit) + class(phs_wood_config_t), intent(in) :: object + integer, intent(in), optional :: unit + integer :: u + u = given_output_unit (unit) + call object%forest%write (u) + end subroutine phs_wood_config_write_forest - function create_longitudinal_boost (beta_gamma, beta_vec, inverse) result (lambda) - real(default), intent(in) :: beta_gamma - type(vector3_t), intent(in) :: beta_vec - logical, intent(in) :: inverse - type(lorentz_transformation_t) :: lambda - if (inverse) then - lambda = boost (beta_gamma, beta_vec) - else - lambda = boost (-beta_gamma, beta_vec) - end if - end function create_longitudinal_boost +@ %def phs_wood_config_write_forest +@ Set the phase-space parameters that the configuration generator requests. +<>= + procedure :: set_parameters => phs_wood_config_set_parameters +<>= + module subroutine phs_wood_config_set_parameters (phs_config, par) + class(phs_wood_config_t), intent(inout) :: phs_config + type(phs_parameters_t), intent(in) :: par + end subroutine phs_wood_config_set_parameters +<>= + module subroutine phs_wood_config_set_parameters (phs_config, par) + class(phs_wood_config_t), intent(inout) :: phs_config + type(phs_parameters_t), intent(in) :: par + phs_config%par = par + end subroutine phs_wood_config_set_parameters - function create_transversal_boost (p_rad, xi, sqrts_real) result (lambda) - type(vector4_t), intent(in) :: p_rad - real(default), intent(in) :: xi, sqrts_real - type(lorentz_transformation_t) :: lambda - type(vector3_t) :: vec_transverse - real(default) :: pt2, beta, beta_gamma - pt2 = transverse_part (p_rad)**2 - beta = one / sqrt (one + sqrts_real**2 * (one - xi) / pt2) - beta_gamma = beta / sqrt (one - beta**2) - vec_transverse%p(1:2) = p_rad%p(1:2) - vec_transverse%p(3) = zero - vec_transverse = normalize (vec_transverse) - lambda = boost (-beta_gamma, vec_transverse) - end function create_transversal_boost - end subroutine phs_fks_generator_generate_isr +@ %def phs_wood_config_set_parameters +@ Enable the generation of channel equivalences (when calling [[configure]]). +<>= + procedure :: enable_equivalences => phs_wood_config_enable_equivalences +<>= + module subroutine phs_wood_config_enable_equivalences (phs_config) + class(phs_wood_config_t), intent(inout) :: phs_config + end subroutine phs_wood_config_enable_equivalences +<>= + module subroutine phs_wood_config_enable_equivalences (phs_config) + class(phs_wood_config_t), intent(inout) :: phs_config + phs_config%use_equivalences = .true. + end subroutine phs_wood_config_enable_equivalences -@ %def phs_fks_generator_generate_isr -@ -<>= - procedure :: set_sqrts_hat => phs_fks_generator_set_sqrts_hat -<>= - subroutine phs_fks_generator_set_sqrts_hat (generator, sqrts) - class(phs_fks_generator_t), intent(inout) :: generator - real(default), intent(in) :: sqrts - generator%sqrts = sqrts - end subroutine phs_fks_generator_set_sqrts_hat +@ %def phs_wood_config_enable_equivalences +@ Set the phase-space mapping parameters that the configuration generator +requests.g +<>= + procedure :: set_mapping_defaults => phs_wood_config_set_mapping_defaults +<>= + module subroutine phs_wood_config_set_mapping_defaults & + (phs_config, mapping_defaults) + class(phs_wood_config_t), intent(inout) :: phs_config + type(mapping_defaults_t), intent(in) :: mapping_defaults + end subroutine phs_wood_config_set_mapping_defaults +<>= + module subroutine phs_wood_config_set_mapping_defaults & + (phs_config, mapping_defaults) + class(phs_wood_config_t), intent(inout) :: phs_config + type(mapping_defaults_t), intent(in) :: mapping_defaults + phs_config%mapping_defaults = mapping_defaults + end subroutine phs_wood_config_set_mapping_defaults -@ %def phs_fks_generator_set_sqrts_hat -@ -<>= - procedure :: set_emitters => phs_fks_generator_set_emitters -<>= - subroutine phs_fks_generator_set_emitters (generator, emitters) - class(phs_fks_generator_t), intent(inout) :: generator - integer, intent(in), dimension(:), allocatable :: emitters - allocate (generator%emitters (size (emitters))) - generator%emitters = emitters - end subroutine phs_fks_generator_set_emitters +@ %def phs_wood_config_set_mapping_defaults +@ Define the input stream for the phase-space file as an open logical unit. +The unit must be connected. +<>= + procedure :: set_input => phs_wood_config_set_input +<>= + module subroutine phs_wood_config_set_input (phs_config, unit) + class(phs_wood_config_t), intent(inout) :: phs_config + integer, intent(in) :: unit + end subroutine phs_wood_config_set_input +<>= + module subroutine phs_wood_config_set_input (phs_config, unit) + class(phs_wood_config_t), intent(inout) :: phs_config + integer, intent(in) :: unit + phs_config%io_unit = unit + rewind (unit) + end subroutine phs_wood_config_set_input -@ %def phs_fks_generator_set_emitters +@ %def phs_wood_config_set_input @ -<>= - procedure :: setup_masses => phs_fks_generator_setup_masses -<>= - subroutine phs_fks_generator_setup_masses (generator, n_tot) - class (phs_fks_generator_t), intent(inout) :: generator - integer, intent(in) :: n_tot - if (.not. allocated (generator%m2)) then - allocate (generator%is_massive (n_tot)) - allocate (generator%m2 (n_tot)) - generator%is_massive = .false. - generator%m2 = zero +\subsection{Phase-space generation} +This subroutine generates a phase space configuration using the +[[cascades]] module. Note that this may take time, and the +[[cascade_set]] subobject may consume a large amount of memory. +<>= + procedure :: generate_phase_space => phs_wood_config_generate_phase_space +<>= + module subroutine phs_wood_config_generate_phase_space (phs_config) + class(phs_wood_config_t), intent(inout) :: phs_config + end subroutine phs_wood_config_generate_phase_space +<>= + module subroutine phs_wood_config_generate_phase_space (phs_config) + class(phs_wood_config_t), intent(inout) :: phs_config + integer :: off_shell, extra_off_shell + logical :: valid + integer :: unit_fds + type(string_t) :: file_name + logical :: file_exists + call msg_message ("Phase space: generating configuration ...") + off_shell = phs_config%par%off_shell + if (phs_config%use_cascades2) then + file_name = char (phs_config%id) // ".fds" + inquire (file=char (file_name), exist=file_exists) + if (.not. file_exists) call msg_fatal & + ("The O'Mega input file " // char (file_name) // & + " does not exist. " // "Please make sure that the " // & + "variable ?omega_write_phs_output has been set correctly.") + unit_fds = free_unit () + open (unit=unit_fds, file=char(file_name), status='old', action='read') + do extra_off_shell = 0, max (phs_config%n_tot - 3, 0) + phs_config%par%off_shell = off_shell + extra_off_shell + allocate (phs_config%feyngraph_set) + call feyngraph_set_generate (phs_config%feyngraph_set, & + phs_config%model, phs_config%n_in, phs_config%n_out, & + phs_config%flv, & + phs_config%par, phs_config%fatal_beam_decay, unit_fds, & + phs_config%vis_channels) + if (feyngraph_set_is_valid (phs_config%feyngraph_set)) then + exit + else + call msg_message ("Phase space: ... failed. & + &Increasing phs_off_shell ...") + call phs_config%feyngraph_set%final () + deallocate (phs_config%feyngraph_set) + end if + end do + close (unit_fds) + else + allocate (phs_config%cascade_set) + do extra_off_shell = 0, max (phs_config%n_tot - 3, 0) + phs_config%par%off_shell = off_shell + extra_off_shell + call cascade_set_generate (phs_config%cascade_set, & + phs_config%model, phs_config%n_in, phs_config%n_out, & + phs_config%flv, & + phs_config%par, phs_config%fatal_beam_decay) + if (cascade_set_is_valid (phs_config%cascade_set)) then + exit + else + call msg_message ("Phase space: ... failed. & + &Increasing phs_off_shell ...") + end if + end do end if - end subroutine phs_fks_generator_setup_masses - -@ %def phs_fks_generator_setup_masses -@ -<>= - procedure :: set_xi_and_y_bounds => phs_fks_generator_set_xi_and_y_bounds -<>= - subroutine phs_fks_generator_set_xi_and_y_bounds (generator, fks_xi_min, fks_y_max) - class(phs_fks_generator_t), intent(inout) :: generator - real(default), intent(in), optional :: fks_xi_min, fks_y_max - real(default) :: xi_min, y_max - xi_min = zero; y_max = one - if (present (fks_xi_min)) xi_min = fks_xi_min - if (present (fks_y_max)) y_max = fks_y_max - generator%xi_min = min (one, max (xi_min, tiny_07)) - generator%y_max = min (abs (y_max), one) - end subroutine phs_fks_generator_set_xi_and_y_bounds - -@ %def phs_fks_generator_set_xi_and_y_bounds -@ Sets [[x]] in the [[isr_kinematics]] of the generator. -<>= - procedure :: set_isr_kinematics => phs_fks_generator_set_isr_kinematics -<>= - subroutine phs_fks_generator_set_isr_kinematics (generator, p) - class(phs_fks_generator_t), intent(inout) :: generator - type(vector4_t), dimension(2), intent(in) :: p - if (allocated (generator%isr_kinematics%beam_energy)) then - select case (size (generator%isr_kinematics%beam_energy)) - case (1) - generator%isr_kinematics%x = p%p(0) / & - generator%isr_kinematics%beam_energy(1) - case (2) - generator%isr_kinematics%x = p%p(0) / & - generator%isr_kinematics%beam_energy - end select + if (phs_config%use_cascades2) then + valid = feyngraph_set_is_valid (phs_config%feyngraph_set) else - generator%isr_kinematics%x = 0 + valid = cascade_set_is_valid (phs_config%cascade_set) end if - end subroutine phs_fks_generator_set_isr_kinematics - -@ %def phs_fks_generator_set_isr_kinematics -@ -<>= - procedure :: generate_radiation_variables => & - phs_fks_generator_generate_radiation_variables -<>= - subroutine phs_fks_generator_generate_radiation_variables & - (generator, r_in, p_born, phs_identifiers, threshold) - class(phs_fks_generator_t), intent(inout) :: generator - real(default), intent(in), dimension(:) :: r_in - type(vector4_t), intent(in), dimension(:) :: p_born - type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers - logical, intent(in), optional :: threshold - - associate (rad_var => generator%real_kinematics) - rad_var%phi = r_in (I_PHI) * twopi - select case (generator%mode) - case (GEN_REAL_PHASE_SPACE) - rad_var%jac_rand = twopi - call generator%compute_y_real_phs (r_in(I_Y), p_born, phs_identifiers, & - rad_var%jac_rand, rad_var%y, threshold) - case (GEN_SOFT_MISMATCH) - rad_var%jac_mismatch = twopi - call generator%compute_y_mismatch (r_in(I_Y), rad_var%jac_mismatch, & - rad_var%y_mismatch, rad_var%y_soft) - case default - call generator%compute_y_test (rad_var%y) - end select - call generator%compute_xi_tilde (r_in(I_XI)) - call generator%set_masses (p_born, phs_identifiers) - end associate - end subroutine phs_fks_generator_generate_radiation_variables - -@ %def phs_fks_generator_generate_radiation_variables -@ -<>= - procedure :: compute_xi_ref_momenta => phs_fks_generator_compute_xi_ref_momenta -<>= - subroutine phs_fks_generator_compute_xi_ref_momenta & - (generator, p_born, resonance_contributors) - class(phs_fks_generator_t), intent(inout) :: generator - type(vector4_t), intent(in), dimension(:) :: p_born - type(resonance_contributors_t), intent(in), dimension(:), optional & - :: resonance_contributors - integer :: i_con, n_contributors - if (present (resonance_contributors)) then - n_contributors = size (resonance_contributors) - if (.not. allocated (generator%resonance_contributors)) & - allocate (generator%resonance_contributors (n_contributors)) - do i_con = 1, n_contributors - generator%real_kinematics%xi_ref_momenta(i_con) = & - get_resonance_momentum (p_born, resonance_contributors(i_con)%c) - generator%resonance_contributors(i_con) = resonance_contributors(i_con) - end do + if (valid) then + call msg_message ("Phase space: ... success.") else - generator%real_kinematics%xi_ref_momenta(1) = sum (p_born(1:generator%n_in)) + call msg_fatal ("Phase-space: generation failed") end if - end subroutine phs_fks_generator_compute_xi_ref_momenta - -@ %def phs_fks_generator_compute_xi_ref_momenta -@ -<>= - procedure :: compute_xi_ref_momenta_threshold & - => phs_fks_generator_compute_xi_ref_momenta_threshold -<>= - subroutine phs_fks_generator_compute_xi_ref_momenta_threshold (generator, p_born) - class(phs_fks_generator_t), intent(inout) :: generator - type(vector4_t), intent(in), dimension(:) :: p_born - generator%real_kinematics%xi_ref_momenta(1) = p_born(THR_POS_WP) + p_born(THR_POS_B) - generator%real_kinematics%xi_ref_momenta(2) = p_born(THR_POS_WM) + p_born(THR_POS_BBAR) - end subroutine phs_fks_generator_compute_xi_ref_momenta_threshold - -@ %def phs_fks_generator_compute_xi_ref_momenta -@ -<>= - procedure :: compute_cms_energy => phs_fks_generator_compute_cms_energy -<>= - subroutine phs_fks_generator_compute_cms_energy (generator, p_born) - class(phs_fks_generator_t), intent(inout) :: generator - type(vector4_t), intent(in), dimension(:) :: p_born - type(vector4_t) :: p_sum - p_sum = sum (p_born (1 : generator%n_in)) - generator%real_kinematics%cms_energy2 = p_sum**2 - end subroutine phs_fks_generator_compute_cms_energy + end subroutine phs_wood_config_generate_phase_space -@ %def phs_fks_generator_compute_cms_energy -@ -<>= - procedure :: compute_xi_max => phs_fks_generator_compute_xi_max -<>= - subroutine phs_fks_generator_compute_xi_max (generator, emitter, & - i_phs, p, xi_max, i_con, y_in) - class(phs_fks_generator_t), intent(inout) :: generator - integer, intent(in) :: i_phs, emitter - type(vector4_t), intent(in), dimension(:) :: p - real(default), intent(out) :: xi_max - integer, intent(in), optional :: i_con - real(default), intent(in), optional :: y_in - real(default) :: q0 - type(vector4_t), dimension(:), allocatable :: pp, pp_decay - type(vector4_t) :: p_res - type(lorentz_transformation_t) :: L_to_resonance - real(default) :: y - if (.not. any (generator%emitters == emitter)) return - allocate (pp (size (p))) - associate (rad_var => generator%real_kinematics) - if (present (i_con)) then - q0 = rad_var%xi_ref_momenta(i_con)**1 +@ %def phs_wood_config_generate_phase_space +@ Using the generated phase-space configuration, write an appropriate +phase-space file to the stored (or explicitly specified) I/O unit. +<>= + procedure :: write_phase_space => phs_wood_config_write_phase_space +<>= + module subroutine phs_wood_config_write_phase_space (phs_config, & + filename_vis, unit) + class(phs_wood_config_t), intent(in) :: phs_config + integer, intent(in), optional :: unit + type(string_t), intent(in), optional :: filename_vis + end subroutine phs_wood_config_write_phase_space +<>= + module subroutine phs_wood_config_write_phase_space (phs_config, & + filename_vis, unit) + class(phs_wood_config_t), intent(in) :: phs_config + integer, intent(in), optional :: unit + type(string_t), intent(in), optional :: filename_vis + type(string_t) :: setenv_tex, setenv_mp, pipe, pipe_dvi + integer :: u, unit_tex, unit_dev, status + if (allocated (phs_config%cascade_set) .or. & + allocated (phs_config%feyngraph_set)) then + if (present (unit)) then + u = unit else - q0 = energy (sum (p(1:generator%n_in))) + u = phs_config%io_unit end if - if (present (y_in)) then - y = y_in + write (u, "(1x,A,A)") "process ", char (phs_config%id) + write (u, "(A)") + if (phs_config%use_cascades2) then + call feyngraph_set_write_process_bincode_format (phs_config%feyngraph_set, u) else - y = rad_var%y(i_phs) + call cascade_set_write_process_bincode_format (phs_config%cascade_set, u) end if - if (present (i_con)) then - p_res = rad_var%xi_ref_momenta(i_con) - L_to_resonance = inverse (boost (p_res, q0)) - pp = L_to_resonance * p + write (u, "(A)") + write (u, "(3x,A,A,A32,A)") "md5sum_process = ", & + '"', phs_config%md5sum_process, '"' + write (u, "(3x,A,A,A32,A)") "md5sum_model_par = ", & + '"', phs_config%md5sum_model_par, '"' + write (u, "(3x,A,A,A32,A)") "md5sum_phs_config = ", & + '"', phs_config%md5sum_phs_config, '"' + call phs_config%par%write (u) + if (phs_config%use_cascades2) then + call feyngraph_set_write_file_format (phs_config%feyngraph_set, u) else - pp = p + call cascade_set_write_file_format (phs_config%cascade_set, u) end if - if (emitter <= generator%n_in) then - select case (generator%isr_kinematics%isr_mode) - case (SQRTS_FIXED) - if (generator%n_in > 1) then - allocate (pp_decay (size (pp) - 1)) - else - allocate (pp_decay (size (pp))) - end if - pp_decay (1) = sum (pp(1:generator%n_in)) - pp_decay (2 : ) = pp (generator%n_in + 1 : ) - xi_max = get_xi_max_isr_decay (pp_decay) - deallocate (pp_decay) - case (SQRTS_VAR) - xi_max = get_xi_max_isr (generator%isr_kinematics%x, y) - end select - else - if (generator%is_massive(emitter)) then - xi_max = get_xi_max_fsr (pp, q0, emitter, generator%m2(emitter), y) + if (phs_config%vis_channels) then + unit_tex = free_unit () + open (unit=unit_tex, file=char(filename_vis // ".tex"), & + action="write", status="replace") + if (phs_config%use_cascades2) then + call feyngraph_set_write_graph_format (phs_config%feyngraph_set, & + filename_vis // "-graphs", phs_config%id, unit_tex) else - xi_max = get_xi_max_fsr (pp, q0, emitter) + call cascade_set_write_graph_format (phs_config%cascade_set, & + filename_vis // "-graphs", phs_config%id, unit_tex) + end if + close (unit_tex) + call msg_message ("Phase space: visualizing channels in file " & + // char(trim(filename_vis)) // "...") + if (phs_config%os_data%event_analysis_ps) then + BLOCK: do + unit_dev = free_unit () + open (file = "/dev/null", unit = unit_dev, & + action = "write", iostat = status) + if (status /= 0) then + pipe = "" + pipe_dvi = "" + else + pipe = " > /dev/null" + pipe_dvi = " 2>/dev/null 1>/dev/null" + end if + close (unit_dev) + if (phs_config%os_data%whizard_texpath /= "") then + setenv_tex = "TEXINPUTS=" // & + phs_config%os_data%whizard_texpath // ":$TEXINPUTS " + setenv_mp = "MPINPUTS=" // & + phs_config%os_data%whizard_texpath // ":$MPINPUTS " + else + setenv_tex = "" + setenv_mp = "" + end if + call os_system_call (setenv_tex // & + phs_config%os_data%latex // " " // & + filename_vis // ".tex " // pipe, status) + if (status /= 0) exit BLOCK + if (phs_config%os_data%mpost /= "") then + call os_system_call (setenv_mp // & + phs_config%os_data%mpost // " " // & + filename_vis // "-graphs.mp" // pipe, status) + else + call msg_fatal ("Could not use MetaPOST.") + end if + if (status /= 0) exit BLOCK + call os_system_call (setenv_tex // & + phs_config%os_data%latex // " " // & + filename_vis // ".tex" // pipe, status) + if (status /= 0) exit BLOCK + call os_system_call & + (phs_config%os_data%dvips // " -o " // filename_vis & + // ".ps " // filename_vis // ".dvi" // pipe_dvi, status) + if (status /= 0) exit BLOCK + if (phs_config%os_data%event_analysis_pdf) then + call os_system_call (phs_config%os_data%ps2pdf // " " // & + filename_vis // ".ps", status) + if (status /= 0) exit BLOCK + end if + exit BLOCK + end do BLOCK + if (status /= 0) then + call msg_error ("Unable to compile analysis output file") + end if end if end if - deallocate (pp) - end associate - end subroutine phs_fks_generator_compute_xi_max + else + call msg_fatal ("Phase-space configuration: & + &no phase space object generated") + end if + end subroutine phs_wood_config_write_phase_space -@ %def phs_fks_generator_compute_xi_max -@ -<>= - procedure :: compute_xi_max_isr_factorized & - => phs_fks_generator_compute_xi_max_isr_factorized -<>= - subroutine phs_fks_generator_compute_xi_max_isr_factorized & - (generator, i_phs, p) - class(phs_fks_generator_t), intent(inout) :: generator - integer, intent(in) :: i_phs - type(vector4_t), intent(in), dimension(:) :: p - generator%real_kinematics%xi_max(i_phs) = get_xi_max_isr_decay (p) - end subroutine phs_fks_generator_compute_xi_max_isr_factorized +@ %def phs_config_write_phase_space +@ Clear the phase-space configuration. This is useful since the +object may become \emph{really} large. +<>= + procedure :: clear_phase_space => phs_wood_config_clear_phase_space +<>= + module subroutine phs_wood_config_clear_phase_space (phs_config) + class(phs_wood_config_t), intent(inout) :: phs_config + end subroutine phs_wood_config_clear_phase_space +<>= + module subroutine phs_wood_config_clear_phase_space (phs_config) + class(phs_wood_config_t), intent(inout) :: phs_config + if (allocated (phs_config%cascade_set)) then + call cascade_set_final (phs_config%cascade_set) + deallocate (phs_config%cascade_set) + end if + if (allocated (phs_config%feyngraph_set)) then + call phs_config%feyngraph_set%final () + deallocate (phs_config%feyngraph_set) + end if + end subroutine phs_wood_config_clear_phase_space -@ %def phs_fks_generator_compute_xi_max_isr_factorized +@ %def phs_wood_config_clear_phase_space @ -<>= - procedure :: set_masses => phs_fks_generator_set_masses -<>= - subroutine phs_fks_generator_set_masses (generator, p, phs_identifiers) - class(phs_fks_generator_t), intent(inout) :: generator - type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers - type(vector4_t), intent(in), dimension(:) :: p - integer :: emitter, i_phs - do i_phs = 1, size (phs_identifiers) - emitter = phs_identifiers(i_phs)%emitter - if (any (generator%emitters == emitter) .and. emitter > 0) then - if (generator%is_massive (emitter) .and. emitter > generator%n_in) & - generator%m2(emitter) = p(emitter)**2 - end if - end do - end subroutine phs_fks_generator_set_masses +Extract the set of resonance histories +<>= + procedure :: extract_resonance_history_set & + => phs_wood_config_extract_resonance_history_set +<>= + module subroutine phs_wood_config_extract_resonance_history_set & + (phs_config, res_set, include_trivial) + class(phs_wood_config_t), intent(in) :: phs_config + type(resonance_history_set_t), intent(out) :: res_set + logical, intent(in), optional :: include_trivial + end subroutine phs_wood_config_extract_resonance_history_set +<>= + module subroutine phs_wood_config_extract_resonance_history_set & + (phs_config, res_set, include_trivial) + class(phs_wood_config_t), intent(in) :: phs_config + type(resonance_history_set_t), intent(out) :: res_set + logical, intent(in), optional :: include_trivial + call phs_config%forest%extract_resonance_history_set & + (res_set, include_trivial) + end subroutine phs_wood_config_extract_resonance_history_set -@ %def phs_fhs_generator_set_masses +@ %def phs_wood_config_extract_resonance_history_set @ -<>= - public :: compute_y_from_emitter -<>= - subroutine compute_y_from_emitter (r_y, p, n_in, emitter, massive, & - y_max, jac_rand, y, contributors, threshold) - real(default), intent(in) :: r_y - type(vector4_t), intent(in), dimension(:) :: p - integer, intent(in) :: n_in - integer, intent(in) :: emitter - logical, intent(in) :: massive - real(default), intent(in) :: y_max - real(default), intent(inout) :: jac_rand - real(default), intent(out) :: y - integer, intent(in), dimension(:), allocatable, optional :: contributors - logical, intent(in), optional :: threshold - logical :: thr, resonance - type(vector4_t) :: p_res, p_em - real(default) :: q0 - type(lorentz_transformation_t) :: boost_to_resonance - integer :: i - real(default) :: beta, one_m_beta, one_p_beta - thr = .false.; if (present (threshold)) thr = threshold - p_res = vector4_null - if (present (contributors)) then - resonance = allocated (contributors) +\subsection{Phase-space configuration} +We read the phase-space configuration from the stored I/O unit. If +this is not set, we assume that we have to generate a phase space +configuration. When done, we open a scratch file and write the +configuration. + +If [[rebuild]] is set, we should trash any existing phase space file +and build a new one. Otherwise, we try to use an old one, which we +check for existence and integrity. If [[ignore_mismatch]] is set, we +reuse an existing file even if it does not match the current setup. +<>= + procedure :: configure => phs_wood_config_configure +<>= + module subroutine phs_wood_config_configure (phs_config, sqrts, & + sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, & + ignore_mismatch, nlo_type, subdir) + class(phs_wood_config_t), intent(inout) :: phs_config + real(default), intent(in) :: sqrts + logical, intent(in), optional :: sqrts_fixed + logical, intent(in), optional :: lab_is_cm + logical, intent(in), optional :: azimuthal_dependence + logical, intent(in), optional :: rebuild + logical, intent(in), optional :: ignore_mismatch + integer, intent(in), optional :: nlo_type + type(string_t), intent(in), optional :: subdir + end subroutine phs_wood_config_configure +<>= + module subroutine phs_wood_config_configure (phs_config, sqrts, & + sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, & + ignore_mismatch, nlo_type, subdir) + class(phs_wood_config_t), intent(inout) :: phs_config + real(default), intent(in) :: sqrts + logical, intent(in), optional :: sqrts_fixed + logical, intent(in), optional :: lab_is_cm + logical, intent(in), optional :: azimuthal_dependence + logical, intent(in), optional :: rebuild + logical, intent(in), optional :: ignore_mismatch + integer, intent(in), optional :: nlo_type + type(string_t), intent(in), optional :: subdir + type(string_t) :: filename, filename_vis + logical :: variable_limits + logical :: ok, exist, found, check, match, rebuild_phs + integer :: g, c0, c1, n + if (present (nlo_type)) then + phs_config%nlo_type = nlo_type else - resonance = .false. + phs_config%nlo_type = BORN end if - if (massive) then - if (resonance) then - do i = 1, size (contributors) - p_res = p_res + p(contributors(i)) - end do - else if (thr) then - p_res = p(ass_boson(thr_leg(emitter))) + p(ass_quark(thr_leg(emitter))) - else - p_res = sum (p(1:n_in)) - end if - q0 = p_res**1 - boost_to_resonance = inverse (boost (p_res, q0)) - p_em = boost_to_resonance * p(emitter) - beta = beta_emitter (q0, p_em) - one_m_beta = one - beta - one_p_beta = one + beta - y = one / beta * (one - one_p_beta * & - exp ( - r_y * log(one_p_beta / one_m_beta))) - jac_rand = jac_rand * & - (one - beta * y) * log(one_p_beta / one_m_beta) / beta + phs_config%sqrts = sqrts + phs_config%par%sqrts = sqrts + if (present (sqrts_fixed)) & + phs_config%sqrts_fixed = sqrts_fixed + if (present (lab_is_cm)) & + phs_config%lab_is_cm = lab_is_cm + if (present (azimuthal_dependence)) & + phs_config%azimuthal_dependence = azimuthal_dependence + if (present (rebuild)) then + rebuild_phs = rebuild else - y = (one - two * r_y) * y_max - jac_rand = jac_rand * 3 * (one - y**2) * y_max - y = 1.5_default * (y - y**3 / 3) + rebuild_phs = .true. end if - end subroutine compute_y_from_emitter - -@ %def compute_y_from_emitter -@ -<>= - procedure :: compute_y_real_phs => phs_fks_generator_compute_y_real_phs -<>= - subroutine phs_fks_generator_compute_y_real_phs (generator, r_y, p, phs_identifiers, & - jac_rand, y, threshold) - class(phs_fks_generator_t), intent(inout) :: generator - real(default), intent(in) :: r_y - type(vector4_t), intent(in), dimension(:) :: p - type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers - real(default), intent(inout), dimension(:) :: jac_rand - real(default), intent(out), dimension(:) :: y - logical, intent(in), optional :: threshold - real(default) :: beta, one_p_beta, one_m_beta - type(lorentz_transformation_t) :: boost_to_resonance - real(default) :: q0 - type(vector4_t) :: p_res, p_em - integer :: i, i_phs, emitter - logical :: thr - logical :: construct_massive_fsr - construct_massive_fsr = .false. - thr = .false.; if (present (threshold)) thr = threshold - do i_phs = 1, size (phs_identifiers) - emitter = phs_identifiers(i_phs)%emitter - !!! We need this additional check because of decay phase spaces - !!! t -> bW has a massive emitter at position 1, which should - !!! not be treated here. - construct_massive_fsr = emitter > generator%n_in - if (construct_massive_fsr) construct_massive_fsr = & - construct_massive_fsr .and. generator%is_massive (emitter) - call compute_y_from_emitter (r_y, p, generator%n_in, emitter, construct_massive_fsr, & - generator%y_max, jac_rand(i_phs), y(i_phs), & - phs_identifiers(i_phs)%contributors, threshold) - end do - end subroutine phs_fks_generator_compute_y_real_phs - -@ %def phs_fks_generator_compute_y_real_phs -@ -<>= - procedure :: compute_y_mismatch => phs_fks_generator_compute_y_mismatch -<>= - subroutine phs_fks_generator_compute_y_mismatch (generator, r_y, jac_rand, y, y_soft) - class(phs_fks_generator_t), intent(inout) :: generator - real(default), intent(in) :: r_y - real(default), intent(inout) :: jac_rand - real(default), intent(out) :: y - real(default), intent(out), dimension(:) :: y_soft - y = (one - two * r_y) * generator%y_max - jac_rand = jac_rand * 3 * (one - y**2) * generator%y_max - y = 1.5_default * (y - y**3 / 3) - y_soft = y - end subroutine phs_fks_generator_compute_y_mismatch - -@ %def phs_fks_generator_compute_y_mismatch -@ -<>= - procedure :: compute_y_test => phs_fks_generator_compute_y_test -<>= - subroutine phs_fks_generator_compute_y_test (generator, y) - class(phs_fks_generator_t), intent(inout) :: generator - real(default), intent(out), dimension(:):: y - select case (generator%mode) - case (GEN_SOFT_LIMIT_TEST) - y = y_test_soft - case (GEN_COLL_LIMIT_TEST) - y = y_test_coll - case (GEN_ANTI_COLL_LIMIT_TEST) - y = - y_test_coll - case (GEN_SOFT_COLL_LIMIT_TEST) - y = y_test_coll - case (GEN_SOFT_ANTI_COLL_LIMIT_TEST) - y = - y_test_coll - end select - end subroutine phs_fks_generator_compute_y_test - -@ %def phs_fks_generator_compute_y_test -@ -<>= - public :: beta_emitter -<>= - pure function beta_emitter (q0, p) result (beta) - real(default), intent(in) :: q0 - type(vector4_t), intent(in) :: p - real(default) :: beta - real(default) :: m2, mrec2, k0_max - m2 = p**2 - mrec2 = (q0 - p%p(0))**2 - p%p(1)**2 - p%p(2)**2 - p%p(3)**2 - k0_max = (q0**2 - mrec2 + m2) / (two * q0) - beta = sqrt(one - m2 / k0_max**2) - end function beta_emitter - -@ %def beta_emitter -@ -<>= - procedure :: compute_xi_tilde => phs_fks_generator_compute_xi_tilde -<>= - pure subroutine phs_fks_generator_compute_xi_tilde (generator, r) - class(phs_fks_generator_t), intent(inout) :: generator - real(default), intent(in) :: r - real(default) :: deno - associate (rad_var => generator%real_kinematics) - select case (generator%mode) - case (GEN_REAL_PHASE_SPACE) - if (generator%singular_jacobian) then - rad_var%xi_tilde = (one - generator%xi_min) - (one - r)**2 * & - (one - two * generator%xi_min) - rad_var%jac_rand = rad_var%jac_rand * two * (one - r) * & - (one - two * generator%xi_min) + if (present (ignore_mismatch)) then + check = .not. ignore_mismatch + if (ignore_mismatch) & + call msg_warning ("Reading phs file: MD5 sum check disabled") + else + check = .true. + end if + phs_config%md5sum_forest = "" + call phs_config%compute_md5sum (include_id = .false.) + if (phs_config%io_unit == 0) then + filename = phs_config%make_phs_filename (subdir) + filename_vis = phs_config%make_phs_filename (subdir) // "-vis" + if (.not. rebuild_phs) then + if (check) then + call phs_config%read_phs_file (exist, found, match, subdir=subdir) + rebuild_phs = .not. (exist .and. found .and. match) else - rad_var%xi_tilde = generator%xi_min + r * (one - generator%xi_min) - rad_var%jac_rand = rad_var%jac_rand * (one - generator%xi_min) + call phs_config%read_phs_file (exist, found, subdir=subdir) + rebuild_phs = .not. (exist .and. found) end if - case (GEN_SOFT_MISMATCH) - deno = one - r - if (deno < tiny_13) deno = tiny_13 - rad_var%xi_mismatch = generator%xi_min + r / deno - rad_var%jac_mismatch = rad_var%jac_mismatch / deno**2 - case (GEN_SOFT_LIMIT_TEST) - rad_var%xi_tilde = r * two * xi_tilde_test_soft - rad_var%jac_rand = two * xi_tilde_test_soft - case (GEN_COLL_LIMIT_TEST) - rad_var%xi_tilde = xi_tilde_test_coll - rad_var%jac_rand = xi_tilde_test_coll - case (GEN_ANTI_COLL_LIMIT_TEST) - rad_var%xi_tilde = xi_tilde_test_coll - rad_var%jac_rand = xi_tilde_test_coll - case (GEN_SOFT_COLL_LIMIT_TEST) - rad_var%xi_tilde = r * two * xi_tilde_test_soft - rad_var%jac_rand = two * xi_tilde_test_soft - case (GEN_SOFT_ANTI_COLL_LIMIT_TEST) - rad_var%xi_tilde = r * two * xi_tilde_test_soft - rad_var%jac_rand = two * xi_tilde_test_soft - end select - end associate - end subroutine phs_fks_generator_compute_xi_tilde - -@ %def phs_fks_generator_compute_xi_tilde -@ -<>= - procedure :: prepare_generation => phs_fks_generator_prepare_generation -<>= - subroutine phs_fks_generator_prepare_generation (generator, r_in, i_phs, & - emitter, p_born, phs_identifiers, contributors, i_con) - class(phs_fks_generator_t), intent(inout) :: generator - real(default), dimension(3), intent(in) :: r_in - integer, intent(in) :: i_phs, emitter - type(vector4_t), intent(in), dimension(:) :: p_born - type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers - type(resonance_contributors_t), intent(in), dimension(:), optional :: contributors - integer, intent(in), optional :: i_con - call generator%generate_radiation_variables (r_in, p_born, phs_identifiers) - call generator%compute_xi_ref_momenta & - (generator%real_kinematics%p_born_lab%phs_point(1)%get (), contributors) - call generator%compute_xi_max (emitter, i_phs, p_born, & - generator%real_kinematics%xi_max(i_phs), i_con = i_con) - end subroutine phs_fks_generator_prepare_generation + end if + if (.not. mpi_is_comm_master ()) then + rebuild_phs = .false. + call msg_message ("MPI: Workers do not build phase space configuration.") + end if + if (rebuild_phs) then + call phs_config%generate_phase_space () + phs_config%io_unit = free_unit () + if (phs_config%id /= "") then + call msg_message ("Phase space: writing configuration file '" & + // char (filename) // "'") + open (phs_config%io_unit, file = char (filename), & + status = "replace", action = "readwrite") + else + open (phs_config%io_unit, status = "scratch", action = "readwrite") + end if + call phs_config%write_phase_space (filename_vis) + rewind (phs_config%io_unit) + else + call msg_message ("Phase space: keeping configuration file '" & + // char (filename) // "'") + end if + end if + if (phs_config%io_unit == 0) then + ok = .true. + else + call phs_config%forest%read (phs_config%io_unit, phs_config%id, & + phs_config%n_in, phs_config%n_out, phs_config%model, ok) + if (.not. phs_config%io_unit_keep_open) then + close (phs_config%io_unit) + phs_config%io_unit = 0 + end if + end if + if (ok) then + call phs_config%forest%set_flavors (phs_config%flv(:,1)) + variable_limits = .not. phs_config%lab_is_cm + call phs_config%forest%set_parameters (phs_config%mapping_defaults, & + variable_limits) + call phs_config%forest%setup_prt_combinations () + phs_config%n_channel = phs_config%forest%get_n_channels () + phs_config%n_par = phs_config%forest%get_n_parameters () + allocate (phs_config%channel (phs_config%n_channel)) + if (phs_config%use_equivalences) then + call phs_config%forest%set_equivalences () + call phs_config%forest%get_equivalences (phs_config%channel, & + phs_config%azimuthal_dependence) + phs_config%provides_equivalences = .true. + end if + call phs_config%forest%set_s_mappings () + call phs_config%record_on_shell () + if (phs_config%mapping_defaults%enable_s_mapping) then + call phs_config%record_s_mappings () + end if + allocate (phs_config%chain (phs_config%n_channel), source = 0) + do g = 1, phs_config%forest%get_n_groves () + call phs_config%forest%get_grove_bounds (g, c0, c1, n) + phs_config%chain (c0:c1) = g + end do + phs_config%provides_chains = .true. + call phs_config%compute_md5sum_forest () + else + write (msg_buffer, "(A,A,A)") & + "Phase space: process '", & + char (phs_config%id), "' not found in configuration file" + call msg_fatal () + end if + end subroutine phs_wood_config_configure -@ %def phs_fks_generator_prepare_generation -@ Get [[xi]] and [[y]] from an external routine (e.g. [[powheg]]) and -generate an FSR phase space. Note that the flag [[supply_xi_max]] is -set to [[.false.]] because it is assumed that the upper bound on [[xi]] -has already been taken into account during its generation. -<>= - procedure :: generate_fsr_from_xi_and_y => & - phs_fks_generator_generate_fsr_from_xi_and_y -<>= - subroutine phs_fks_generator_generate_fsr_from_xi_and_y (generator, xi, y, & - phi, emitter, i_phs, p_born, p_real) - class(phs_fks_generator_t), intent(inout) :: generator - real(default), intent(in) :: xi, y, phi - integer, intent(in) :: emitter, i_phs - type(vector4_t), intent(in), dimension(:) :: p_born - type(vector4_t), intent(inout), dimension(:) :: p_real - associate (rad_var => generator%real_kinematics) - rad_var%supply_xi_max = .false. - rad_var%xi_tilde = xi - rad_var%y(i_phs) = y - rad_var%phi = phi - end associate - call generator%set_sqrts_hat (p_born(1)%p(0) + p_born(2)%p(0)) - call generator%generate_fsr (emitter, i_phs, p_born, p_real) - end subroutine phs_fks_generator_generate_fsr_from_xi_and_y +@ %def phs_wood_config_configure +@ The MD5 sum of the forest is computed in addition to the MD5 sum of +the configuration. The reason is that the forest may depend on a +user-provided external file. On the other hand, this MD5 sum encodes +all information that is relevant for further processing. Therefore, +the [[get_md5sum]] method returns this result, once it is available. +<>= + procedure :: compute_md5sum_forest => phs_wood_config_compute_md5sum_forest +<>= + module subroutine phs_wood_config_compute_md5sum_forest (phs_config) + class(phs_wood_config_t), intent(inout) :: phs_config + end subroutine phs_wood_config_compute_md5sum_forest +<>= + module subroutine phs_wood_config_compute_md5sum_forest (phs_config) + class(phs_wood_config_t), intent(inout) :: phs_config + integer :: u + u = free_unit () + open (u, status = "scratch", action = "readwrite") + call phs_config%write_forest (u) + rewind (u) + phs_config%md5sum_forest = md5sum (u) + close (u) + end subroutine phs_wood_config_compute_md5sum_forest -@ %def phs_fks_generator_generate_fsr_from_xi_and_y -@ -<>= - procedure :: get_radiation_variables => & - phs_fks_generator_get_radiation_variables -<>= - pure subroutine phs_fks_generator_get_radiation_variables (generator, & - i_phs, xi, y, phi) - class(phs_fks_generator_t), intent(in) :: generator - integer, intent(in) :: i_phs - real(default), intent(out) :: xi, y - real(default), intent(out), optional :: phi - associate (rad_var => generator%real_kinematics) - xi = rad_var%xi_max(i_phs) * rad_var%xi_tilde - y = rad_var%y(i_phs) - if (present (phi)) phi = rad_var%phi - end associate - end subroutine phs_fks_generator_get_radiation_variables +@ %def phs_wood_config_compute_md5sum_forest +@ Create filenames according to standard conventions. The [[id]] is the +process name including the suffix [[_iX]] where [[X]] stands for the component +identifier (an integer). The [[run_id]] may be set or unset. -@ %def phs_fks_generator_get_radiation_variables -@ -<>= - procedure :: write => phs_fks_generator_write -<>= - subroutine phs_fks_generator_write (generator, unit) - class(phs_fks_generator_t), intent(in) :: generator - integer, intent(in), optional :: unit - integer :: u - type(string_t) :: massive_phsp - u = given_output_unit (unit); if (u < 0) return - if (generator%massive_phsp) then - massive_phsp = " massive " +The convention for file names that include the run ID is to separate prefix, run +ID, and any extensions by dots. We construct the file name by concatenating +the individual elements accordingly. If there is no run ID, we nevertheless +replace [[_iX]] by [[.iX]]. +<>= + procedure :: make_phs_filename => phs_wood_make_phs_filename +<>= + module function phs_wood_make_phs_filename & + (phs_config, subdir) result (filename) + class(phs_wood_config_t), intent(in) :: phs_config + type(string_t), intent(in), optional :: subdir + type(string_t) :: filename + end function phs_wood_make_phs_filename +<>= + module function phs_wood_make_phs_filename & + (phs_config, subdir) result (filename) + class(phs_wood_config_t), intent(in) :: phs_config + type(string_t), intent(in), optional :: subdir + type(string_t) :: filename + type(string_t) :: basename, suffix, comp_code, comp_index + basename = phs_config%id + call split (basename, suffix, "_", back=.true.) + comp_code = extract (suffix, 1, 1) + comp_index = extract (suffix, 2) + if (comp_code == "i" .and. verify (comp_index, "1234567890") == 0) then + suffix = "." // comp_code // comp_index else - massive_phsp = " massless " + basename = phs_config%id + suffix = "" end if - write (u, "(A)") char ("This is a generator for a" & - // massive_phsp // "phase space") - if (associated (generator%real_kinematics)) then - call generator%real_kinematics%write () + if (phs_config%run_id /= "") then + filename = basename // "." // phs_config%run_id // suffix // ".phs" else - write (u, "(A)") "Warning: There are no real " // & - "kinematics associated with this generator" + filename = basename // suffix // ".phs" end if - call write_separator (u) - write (u, "(A," // FMT_17 // ",1X)") "sqrts : ", generator%sqrts - write (u, "(A," // FMT_17 // ",1X)") "E_gluon : ", generator%E_gluon - write (u, "(A," // FMT_17 // ",1X)") "mrec2 : ", generator%mrec2 - end subroutine phs_fks_generator_write - -@ %def phs_fks_generator_write -@ -<>= - procedure :: compute_isr_kinematics => phs_fks_compute_isr_kinematics -<>= - subroutine phs_fks_compute_isr_kinematics (phs, r) - class(phs_fks_t), intent(inout) :: phs - real(default), intent(in) :: r - if (.not. phs%config%lab_is_cm) then - call phs%generator%compute_isr_kinematics (r, phs%lt_cm_to_lab * phs%phs_wood_t%p) - else - call phs%generator%compute_isr_kinematics (r, phs%phs_wood_t%p) + if (present (subdir)) then + filename = subdir // "/" // filename end if - end subroutine phs_fks_compute_isr_kinematics + end function phs_wood_make_phs_filename -@ %def phs_fks_compute_isr_kinematics +@ %def phs_wood_make_phs_filename @ -<>= - procedure :: final => phs_fks_final -<>= - subroutine phs_fks_final (object) - class(phs_fks_t), intent(inout) :: object - call phs_forest_final (object%forest) - call object%generator%final () - end subroutine phs_fks_final +<>= + procedure :: reshuffle_flavors => phs_wood_config_reshuffle_flavors +<>= + module subroutine phs_wood_config_reshuffle_flavors & + (phs_config, reshuffle, flv_extra) + class(phs_wood_config_t), intent(inout) :: phs_config + integer, intent(in), dimension(:), allocatable :: reshuffle + type(flavor_t), intent(in) :: flv_extra + end subroutine phs_wood_config_reshuffle_flavors +<>= + module subroutine phs_wood_config_reshuffle_flavors & + (phs_config, reshuffle, flv_extra) + class(phs_wood_config_t), intent(inout) :: phs_config + integer, intent(in), dimension(:), allocatable :: reshuffle + type(flavor_t), intent(in) :: flv_extra + call phs_config%forest%set_flavors (phs_config%flv(:,1), reshuffle, & + flv_extra) + end subroutine phs_wood_config_reshuffle_flavors -@ %def phs_fks_final +@ %def phs_wood_config_reshuffle_flavors @ -<>= - public :: get_filtered_resonance_histories -<>= - subroutine filter_particles_from_resonances (res_hist, exclusion_list, & - model, res_hist_filtered) - type(resonance_history_t), intent(in), dimension(:) :: res_hist - type(string_t), intent(in), dimension(:) :: exclusion_list - type(model_t), intent(in) :: model - type(resonance_history_t), intent(out), dimension(:), allocatable :: res_hist_filtered - integer :: i_hist, i_flv, i_new, n_orig - logical, dimension(size (res_hist)) :: to_filter - type(flavor_t) :: flv - to_filter = .false. - n_orig = size (res_hist) - do i_flv = 1, size (exclusion_list) - call flv%init (exclusion_list (i_flv), model) - do i_hist = 1, size (res_hist) - if (res_hist(i_hist)%has_flavor (flv)) to_filter (i_hist) = .true. - end do +<>= + procedure :: set_momentum_links => phs_wood_config_set_momentum_links +<>= + module subroutine phs_wood_config_set_momentum_links (phs_config, reshuffle) + class(phs_wood_config_t), intent(inout) :: phs_config + integer, intent(in), dimension(:), allocatable :: reshuffle + end subroutine phs_wood_config_set_momentum_links +<>= + module subroutine phs_wood_config_set_momentum_links (phs_config, reshuffle) + class(phs_wood_config_t), intent(inout) :: phs_config + integer, intent(in), dimension(:), allocatable :: reshuffle + call phs_config%forest%set_momentum_links (reshuffle) + end subroutine phs_wood_config_set_momentum_links + +@ %def phs_wood_config_set_momentum_links +@ Identify resonances which are marked by s-channel mappings for the +whole phase space and report them to the channel array. +<>= + procedure :: record_s_mappings => phs_wood_config_record_s_mappings +<>= + module subroutine phs_wood_config_record_s_mappings (phs_config) + class(phs_wood_config_t), intent(inout) :: phs_config + end subroutine phs_wood_config_record_s_mappings +<>= + module subroutine phs_wood_config_record_s_mappings (phs_config) + class(phs_wood_config_t), intent(inout) :: phs_config + logical :: flag + real(default) :: mass, width + integer :: c + do c = 1, phs_config%n_channel + call phs_config%forest%get_s_mapping (c, flag, mass, width) + if (flag) then + if (mass == 0) then + call msg_fatal ("Phase space: s-channel resonance " & + // " has zero mass") + end if + if (width == 0) then + call msg_fatal ("Phase space: s-channel resonance " & + // " has zero width") + end if + call phs_config%channel(c)%set_resonant (mass, width) + end if end do - allocate (res_hist_filtered (n_orig - count (to_filter))) - i_new = 1 - do i_hist = 1, size (res_hist) - if (.not. to_filter (i_hist)) then - res_hist_filtered (i_new) = res_hist (i_hist) - i_new = i_new + 1 + end subroutine phs_wood_config_record_s_mappings + +@ %def phs_wood_config_record_s_mappings +@ Identify on-shell mappings for the whole phase space and report them +to the channel array. +<>= + procedure :: record_on_shell => phs_wood_config_record_on_shell +<>= + module subroutine phs_wood_config_record_on_shell (phs_config) + class(phs_wood_config_t), intent(inout) :: phs_config + end subroutine phs_wood_config_record_on_shell +<>= + module subroutine phs_wood_config_record_on_shell (phs_config) + class(phs_wood_config_t), intent(inout) :: phs_config + logical :: flag + real(default) :: mass + integer :: c + do c = 1, phs_config%n_channel + call phs_config%forest%get_on_shell (c, flag, mass) + if (flag) then + call phs_config%channel(c)%set_on_shell (mass) end if end do - end subroutine filter_particles_from_resonances + end subroutine phs_wood_config_record_on_shell -@ %def filter_particles_from_resonances -@ -<>= - subroutine clean_resonance_histories (res_hist, n_in, flv, res_hist_clean, success) - type(resonance_history_t), intent(in), dimension(:) :: res_hist - integer, intent(in) :: n_in - integer, intent(in), dimension(:) :: flv - type(resonance_history_t), intent(out), dimension(:), allocatable :: res_hist_clean - logical, intent(out) :: success - integer :: i_hist - type(resonance_history_t), dimension(:), allocatable :: res_hist_colored, res_hist_contracted +@ %def phs_wood_config_record_on_shell +@ Return the most relevant MD5 sum. This overrides the method of the +base type. +<>= + procedure :: get_md5sum => phs_wood_config_get_md5sum +<>= + module function phs_wood_config_get_md5sum (phs_config) result (md5sum) + class(phs_wood_config_t), intent(in) :: phs_config + character(32) :: md5sum + end function phs_wood_config_get_md5sum +<>= + module function phs_wood_config_get_md5sum (phs_config) result (md5sum) + class(phs_wood_config_t), intent(in) :: phs_config + character(32) :: md5sum + if (phs_config%md5sum_forest /= "") then + md5sum = phs_config%md5sum_forest + else + md5sum = phs_config%md5sum_phs_config + end if + end function phs_wood_config_get_md5sum - if (debug_on) call msg_debug (D_SUBTRACTION, "resonance_mapping_init") - if (debug_active (D_SUBTRACTION)) then - call msg_debug (D_SUBTRACTION, "Original resonances:") - do i_hist = 1, size(res_hist) - call res_hist(i_hist)%write () - end do +@ %def phs_wood_config_get_md5sum +@ Check whether a phase-space configuration for the current process exists. +We look for the phase-space file that should correspond to the current +process. If we find it, we check the MD5 sums stored in the file against the +MD5 sums in the current configuration (if required). + +If successful, read the PHS file. +<>= + procedure :: read_phs_file => phs_wood_read_phs_file +<>= + module subroutine phs_wood_read_phs_file & + (phs_config, exist, found, match, subdir) + class(phs_wood_config_t), intent(inout) :: phs_config + logical, intent(out) :: exist + logical, intent(out) :: found + logical, intent(out), optional :: match + type(string_t), intent(in), optional :: subdir + end subroutine phs_wood_read_phs_file +<>= + module subroutine phs_wood_read_phs_file & + (phs_config, exist, found, match, subdir) + class(phs_wood_config_t), intent(inout) :: phs_config + logical, intent(out) :: exist + logical, intent(out) :: found + logical, intent(out), optional :: match + type(string_t), intent(in), optional :: subdir + type(string_t) :: filename + integer :: u + filename = phs_config%make_phs_filename (subdir) + inquire (file = char (filename), exist = exist) + if (exist) then + u = free_unit () + open (u, file = char (filename), action = "read", status = "old") + call phs_config%forest%read (u, phs_config%id, phs_config%n_in, & + phs_config%n_out, phs_config%model, found, & + phs_config%md5sum_process, phs_config%md5sum_model_par, & + phs_config%md5sum_phs_config, match = match) + close (u) + else + found = .false. + if (present (match)) match = .false. end if + end subroutine phs_wood_read_phs_file - call remove_uncolored_resonances () - call contract_resonances (res_hist_colored, res_hist_contracted) - call remove_subresonances (res_hist_contracted, res_hist_clean) - !!! Here, we are still not sure whether we actually would rather use - !!! call remove_multiple_resonances (res_hist_contracted, res_hist_clean) - if (debug_active (D_SUBTRACTION)) then - call msg_debug (D_SUBTRACTION, "Resonances after removing uncolored and duplicates: ") - do i_hist = 1, size (res_hist_clean) - call res_hist_clean(i_hist)%write () - end do +@ %def phs_wood_read_phs_file +@ Startup message, after configuration is complete. +<>= + procedure :: startup_message => phs_wood_config_startup_message +<>= + module subroutine phs_wood_config_startup_message (phs_config, unit) + class(phs_wood_config_t), intent(in) :: phs_config + integer, intent(in), optional :: unit + end subroutine phs_wood_config_startup_message +<>= + module subroutine phs_wood_config_startup_message (phs_config, unit) + class(phs_wood_config_t), intent(in) :: phs_config + integer, intent(in), optional :: unit + integer :: n_groves, n_eq + n_groves = phs_config%forest%get_n_groves () + n_eq = phs_config%forest%get_n_equivalences () + call phs_config%base_startup_message (unit) + if (phs_config%n_channel == 1) then + write (msg_buffer, "(A,2(I0,A))") & + "Phase space: found ", phs_config%n_channel, & + " channel, collected in ", n_groves, & + " grove." + else if (n_groves == 1) then + write (msg_buffer, "(A,2(I0,A))") & + "Phase space: found ", phs_config%n_channel, & + " channels, collected in ", n_groves, & + " grove." + else + write (msg_buffer, "(A,2(I0,A))") & + "Phase space: found ", phs_config%n_channel, & + " channels, collected in ", n_groves, & + " groves." end if - if (size (res_hist_clean) == 0) then - call msg_warning ("No resonances found. Proceed in usual FKS mode.") - success = .false. + call msg_message (unit = unit) + if (phs_config%use_equivalences) then + if (n_eq == 1) then + write (msg_buffer, "(A,I0,A)") & + "Phase space: Using ", n_eq, & + " equivalence between channels." + else + write (msg_buffer, "(A,I0,A)") & + "Phase space: Using ", n_eq, & + " equivalences between channels." + end if else - success = .true. + write (msg_buffer, "(A)") & + "Phase space: no equivalences between channels used." end if + call msg_message (unit = unit) + write (msg_buffer, "(A,2(1x,I0,1x,A))") & + "Phase space: wood" + call msg_message (unit = unit) + end subroutine phs_wood_config_startup_message - contains - subroutine remove_uncolored_resonances () - type(resonance_history_t), dimension(:), allocatable :: res_hist_tmp - integer :: n_hist, nleg_out, n_removed - integer :: i_res, i_hist - n_hist = size (res_hist) - nleg_out = size (flv) - n_in - allocate (res_hist_tmp (n_hist)) - allocate (res_hist_colored (n_hist)) - do i_hist = 1, n_hist - res_hist_tmp(i_hist) = res_hist(i_hist) - call res_hist_tmp(i_hist)%add_offset (n_in) - n_removed = 0 - do i_res = 1, res_hist_tmp(i_hist)%n_resonances - associate (resonance => res_hist_tmp(i_hist)%resonances(i_res - n_removed)) - if (.not. any (is_colored (flv (resonance%contributors%c))) & - .or. size (resonance%contributors%c) == nleg_out) then - call res_hist_tmp(i_hist)%remove_resonance (i_res - n_removed) - n_removed = n_removed + 1 - end if - end associate - end do - if (allocated (res_hist_tmp(i_hist)%resonances)) then - if (any (res_hist_colored == res_hist_tmp(i_hist))) then - cycle - else - do i_res = 1, res_hist_tmp(i_hist)%n_resonances - associate (resonance => res_hist_tmp(i_hist)%resonances(i_res)) - call res_hist_colored(i_hist)%add_resonance (resonance) - end associate - end do - end if - end if - end do - end subroutine remove_uncolored_resonances +@ %def phs_wood_config_startup_message +@ Allocate an instance: the actual phase-space object. +Gfortran 7/8/9 bug, has to remain in the main module. +<>= + procedure, nopass :: allocate_instance => phs_wood_config_allocate_instance +<>= + subroutine phs_wood_config_allocate_instance (phs) + class(phs_t), intent(inout), pointer :: phs + allocate (phs_wood_t :: phs) + end subroutine phs_wood_config_allocate_instance - subroutine contract_resonances (res_history_in, res_history_out) - type(resonance_history_t), intent(in), dimension(:) :: res_history_in - type(resonance_history_t), intent(out), dimension(:), allocatable :: res_history_out - logical, dimension(:), allocatable :: i_non_zero - integer :: n_hist_non_zero, n_hist - integer :: i_hist_new - n_hist = size (res_history_in); n_hist_non_zero = 0 - allocate (i_non_zero (n_hist)) - i_non_zero = .false. - do i_hist = 1, n_hist - if (res_history_in(i_hist)%n_resonances /= 0) then - n_hist_non_zero = n_hist_non_zero + 1 - i_non_zero(i_hist) = .true. - end if - end do - allocate (res_history_out (n_hist_non_zero)) - i_hist_new = 1 - do i_hist = 1, n_hist - if (i_non_zero (i_hist)) then - res_history_out (i_hist_new) = res_history_in (i_hist) - i_hist_new = i_hist_new + 1 - end if - end do - end subroutine contract_resonances +@ %def phs_wood_config_allocate_instance +@ +\subsection{Kinematics implementation} +We generate $\cos\theta$ and $\phi$ uniformly, covering the solid angle. +<>= + public :: phs_wood_t +<>= + type, extends (phs_t) :: phs_wood_t + real(default) :: sqrts = 0 + type(phs_forest_t) :: forest + real(default), dimension(3) :: r_real + integer :: n_r_born = 0 + contains + <> + end type phs_wood_t - subroutine remove_subresonances (res_history_in, res_history_out) - type(resonance_history_t), intent(in), dimension(:) :: res_history_in - type(resonance_history_t), intent(out), dimension(:), allocatable :: res_history_out - logical, dimension(:), allocatable :: i_non_sub_res - integer :: n_hist, n_hist_non_sub_res - integer :: i_hist1, i_hist2 - logical :: is_not_subres - n_hist = size (res_history_in); n_hist_non_sub_res = 0 - allocate (i_non_sub_res (n_hist)); i_non_sub_res = .false. - do i_hist1 = 1, n_hist - is_not_subres = .true. - do i_hist2 = 1, n_hist - if (i_hist1 == i_hist2) cycle - is_not_subres = is_not_subres .and. & - .not.(res_history_in(i_hist2) .contains. res_history_in(i_hist1)) - end do - if (is_not_subres) then - n_hist_non_sub_res = n_hist_non_sub_res + 1 - i_non_sub_res (i_hist1) = .true. - end if - end do +@ %def phs_wood_t +@ Output. The [[verbose]] setting is irrelevant, we just display the contents +of the base object. +<>= + procedure :: write => phs_wood_write +<>= + module subroutine phs_wood_write (object, unit, verbose) + class(phs_wood_t), intent(in) :: object + integer, intent(in), optional :: unit + logical, intent(in), optional :: verbose + end subroutine phs_wood_write +<>= + module subroutine phs_wood_write (object, unit, verbose) + class(phs_wood_t), intent(in) :: object + integer, intent(in), optional :: unit + logical, intent(in), optional :: verbose + integer :: u + u = given_output_unit (unit) + call object%base_write (u) + end subroutine phs_wood_write - allocate (res_history_out (n_hist_non_sub_res)) - i_hist2 = 1 - do i_hist1 = 1, n_hist - if (i_non_sub_res (i_hist1)) then - res_history_out (i_hist2) = res_history_in (i_hist1) - i_hist2 = i_hist2 + 1 - end if - end do - end subroutine remove_subresonances +@ %def phs_wood_write +@ Write the forest separately. +<>= + procedure :: write_forest => phs_wood_write_forest +<>= + module subroutine phs_wood_write_forest (object, unit) + class(phs_wood_t), intent(in) :: object + integer, intent(in), optional :: unit + end subroutine phs_wood_write_forest +<>= + module subroutine phs_wood_write_forest (object, unit) + class(phs_wood_t), intent(in) :: object + integer, intent(in), optional :: unit + integer :: u + u = given_output_unit (unit) + call object%forest%write (u) + end subroutine phs_wood_write_forest - subroutine remove_multiple_resonances (res_history_in, res_history_out) - type(resonance_history_t), intent(in), dimension(:) :: res_history_in - type(resonance_history_t), intent(out), dimension(:), allocatable :: res_history_out - integer :: n_hist, n_hist_single - logical, dimension(:), allocatable :: i_hist_single - integer :: i_hist, j - n_hist = size (res_history_in) - n_hist_single = 0 - allocate (i_hist_single (n_hist)); i_hist_single = .false. - do i_hist = 1, n_hist - if (res_history_in(i_hist)%n_resonances == 1) then - n_hist_single = n_hist_single + 1 - i_hist_single(i_hist) = .true. - end if - end do +@ %def phs_wood_write_forest +@ Finalizer. +<>= + procedure :: final => phs_wood_final +<>= + module subroutine phs_wood_final (object) + class(phs_wood_t), intent(inout) :: object + end subroutine phs_wood_final +<>= + module subroutine phs_wood_final (object) + class(phs_wood_t), intent(inout) :: object + call object%forest%final () + end subroutine phs_wood_final - allocate (res_history_out (n_hist_single)) - j = 1 - do i_hist = 1, n_hist - if (i_hist_single(i_hist)) then - res_history_out(j) = res_history_in(i_hist) - j = j + 1 - end if - end do - end subroutine remove_multiple_resonances - end subroutine clean_resonance_histories +@ %def phs_wood_final +@ Initialization. We allocate arrays ([[base_init]]) and adjust the +phase-space volume. The two-particle phase space volume is +\begin{equation} + \Phi_2 = \frac{1}{4(2\pi)^5} = 2.55294034614 \times 10^{-5} +\end{equation} +independent of the particle masses. +<>= + procedure :: init => phs_wood_init +<>= + module subroutine phs_wood_init (phs, phs_config) + class(phs_wood_t), intent(out) :: phs + class(phs_config_t), intent(in), target :: phs_config + end subroutine phs_wood_init +<>= + module subroutine phs_wood_init (phs, phs_config) + class(phs_wood_t), intent(out) :: phs + class(phs_config_t), intent(in), target :: phs_config + call phs%base_init (phs_config) + select type(phs_config) + type is (phs_wood_config_t) + phs%forest = phs_config%forest + if (phs_config%is_combined_integration) then + phs%n_r_born = phs_config%n_par - 3 + end if + end select + end subroutine phs_wood_init -@ %def clean_resonance_histories +@ %def phs_wood_init @ -<>= - subroutine get_filtered_resonance_histories (phs_config, n_in, flv_state, model, & - excluded_resonances, resonance_histories_filtered, success) - type(phs_fks_config_t), intent(inout) :: phs_config - integer, intent(in) :: n_in - integer, intent(in), dimension(:,:), allocatable :: flv_state - type(model_t), intent(in) :: model - type(string_t), intent(in), dimension(:), allocatable :: excluded_resonances - type(resonance_history_t), intent(out), dimension(:), & - allocatable :: resonance_histories_filtered - logical, intent(out) :: success - type(resonance_history_t), dimension(:), allocatable :: resonance_histories - type(resonance_history_t), dimension(:), allocatable :: & - resonance_histories_clean!, resonance_histories_filtered - allocate (resonance_histories (size (phs_config%get_resonance_histories ()))) - resonance_histories = phs_config%get_resonance_histories () - call clean_resonance_histories (resonance_histories, & - n_in, flv_state (:,1), resonance_histories_clean, success) - if (success .and. allocated (excluded_resonances)) then - call filter_particles_from_resonances (resonance_histories_clean, & - excluded_resonances, model, resonance_histories_filtered) - else - allocate (resonance_histories_filtered (size (resonance_histories_clean))) - resonance_histories_filtered = resonance_histories_clean +\subsection{Evaluation} +We compute the outgoing momenta from the incoming momenta and +the input parameter set [[r_in]] in channel [[r_in]]. We also compute the +[[r]] parameters and Jacobians [[f]] for all other channels. + +We do \emph{not} need to a apply a transformation from/to the c.m.\ frame, +because in [[phs_base]] the momenta are already boosted to the c.m.\ frame +before assigning them in the [[phs]] object, and inversely boosted when +extracting them. +<>= + procedure :: evaluate_selected_channel => phs_wood_evaluate_selected_channel + procedure :: evaluate_other_channels => phs_wood_evaluate_other_channels +<>= + module subroutine phs_wood_evaluate_selected_channel (phs, c_in, r_in) + class(phs_wood_t), intent(inout) :: phs + real(default), intent(in), dimension(:) :: r_in + integer, intent(in) :: c_in + end subroutine phs_wood_evaluate_selected_channel + module subroutine phs_wood_evaluate_other_channels (phs, c_in) + class(phs_wood_t), intent(inout) :: phs + integer, intent(in) :: c_in + end subroutine phs_wood_evaluate_other_channels +<>= + module subroutine phs_wood_evaluate_selected_channel (phs, c_in, r_in) + class(phs_wood_t), intent(inout) :: phs + integer, intent(in) :: c_in + real(default), intent(in), dimension(:) :: r_in + logical :: ok + phs%q_defined = .false. + if (phs%p_defined) then + call phs%forest%set_prt_in (phs%p) + phs%r(:,c_in) = r_in + call phs%forest%evaluate_selected_channel (c_in, phs%active_channel, & + phs%sqrts_hat, phs%r, phs%f, phs%volume, ok) + select type (config => phs%config) + type is (phs_wood_config_t) + if (config%is_combined_integration) then + if (phs%n_r_born >= 0) then + phs%r_real = r_in (phs%n_r_born + 1 : phs%n_r_born + 3) + else + call msg_fatal ("n_r_born should be larger than 0!") + end if + end if + end select + if (ok) then + phs%q = phs%forest%get_momenta_out () + phs%q_defined = .true. + end if end if - end subroutine get_filtered_resonance_histories + end subroutine phs_wood_evaluate_selected_channel -@ %def get_filtered_resonance_histories + module subroutine phs_wood_evaluate_other_channels (phs, c_in) + class(phs_wood_t), intent(inout) :: phs + integer, intent(in) :: c_in + integer :: c + if (phs%q_defined) then + call phs%forest%evaluate_other_channels (c_in, phs%active_channel, & + phs%sqrts_hat, phs%r, phs%f, combine=.true.) + select type (config => phs%config) + type is (phs_wood_config_t) + if (config%is_combined_integration) then + if (phs%n_r_born >= 0) then + do c = 1, size (phs%r, 2) + phs%r(phs%n_r_born + 1 : phs%n_r_born + 3, c) = phs%r_real + end do + else + phs%r_defined = .false. + end if + end if + end select + phs%r_defined = .true. + end if + end subroutine phs_wood_evaluate_other_channels + +@ %def phs_wood_evaluate_selected_channel +@ %def phs_wood_evaluate_other_channels +@ Inverse evaluation. +<>= + procedure :: inverse => phs_wood_inverse +<>= + module subroutine phs_wood_inverse (phs) + class(phs_wood_t), intent(inout) :: phs + end subroutine phs_wood_inverse +<>= + module subroutine phs_wood_inverse (phs) + class(phs_wood_t), intent(inout) :: phs + if (phs%p_defined .and. phs%q_defined) then + call phs%forest%set_prt_in (phs%p) + call phs%forest%set_prt_out (phs%q) + call phs%forest%recover_channel (1, phs%sqrts_hat, phs%r, & + phs%f, phs%volume) + call phs%forest%evaluate_other_channels (1, phs%active_channel, & + phs%sqrts_hat, phs%r, phs%f, combine=.false.) + phs%r_defined = .true. + end if + end subroutine phs_wood_inverse + +@ %def phs_wood_inverse @ -\clearpage -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Unit tests} -Test module for FKS phase space, followed by the corresponding implementation module. -<<[[phs_fks_ut.f90]]>>= +Test module, followed by the corresponding implementation module. +<<[[phs_wood_ut.f90]]>>= <> -module phs_fks_ut +module phs_wood_ut use unit_tests - use phs_fks_uti + use phs_wood_uti <> -<> +<> + +<> contains -<> +<> -end module phs_fks_ut -@ %def phs_fks_ut +end module phs_wood_ut +@ %def phs_wood_ut @ -<<[[phs_fks_uti.f90]]>>= +<<[[phs_wood_uti.f90]]>>= <> -module phs_fks_uti +module phs_wood_uti <> - use format_utils, only: write_separator, pac_fmt - use format_defs, only: FMT_15, FMT_19 - use numeric_utils, only: nearly_equal - use constants, only: tiny_07, zero, one, two +<> + use io_units + use os_interface use lorentz - use phs_points, only: assignment(=) + use flavors + use model_data + use process_constants + use mappings + use phs_base + use phs_forests - use physics_defs, only: THR_POS_B, THR_POS_BBAR, THR_POS_WP, THR_POS_WM, THR_POS_GLUON - use physics_defs, only: thr_leg + use phs_wood - use resonances, only: resonance_contributors_t - use phs_fks + use phs_base_ut, only: init_test_process_data, init_test_decay_data <> -<> +<> + +<> contains -<> +<> -end module phs_fks_uti -@ %def phs_fks_uti +<> + +end module phs_wood_uti +@ %def phs_wood_ut @ API: driver for the unit tests below. -<>= - public :: phs_fks_generator_test -<>= - subroutine phs_fks_generator_test (u, results) +<>= + public :: phs_wood_test +<>= + subroutine phs_wood_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results - call test(phs_fks_generator_1, "phs_fks_generator_1", & - "Test the generation of FKS phase spaces", u, results) - call test(phs_fks_generator_2, "phs_fks_generator_2", & - "Test the generation of an ISR FKS phase space", u, results) - call test(phs_fks_generator_3, "phs_fks_generator_3", & - "Test the generation of a real phase space for decays", & - u, results) - call test(phs_fks_generator_4, "phs_fks_generator_4", & - "Test the generation of an FSR phase space with "& - &"conserved invariant resonance masses", u, results) - call test(phs_fks_generator_5, "phs_fks_generator_5", & - "Test on-shell projection of a Born phase space and the generation"& - &" of a real phase-space from that", u, results) - call test(phs_fks_generator_6, "phs_fks_generator_6", & - "Test the generation of a real phase space for 1 -> 3 decays", & - u, results) - call test(phs_fks_generator_7, "phs_fks_generator_7", & - "Test the generation of an ISR FKS phase space for fixed beam energy", & - u, results) - end subroutine phs_fks_generator_test + <> + end subroutine phs_wood_test -@ %def phs_fks_generator_test -@ -<>= - public :: phs_fks_generator_1 -<>= - subroutine phs_fks_generator_1 (u) +@ %def phs_wood_test +<>= + public :: phs_wood_vis_test +<>= + subroutine phs_wood_vis_test (u, results) integer, intent(in) :: u - type(phs_fks_generator_t) :: generator - type(vector4_t), dimension(:), allocatable :: p_born - type(vector4_t), dimension(:), allocatable :: p_real - integer :: emitter, i_phs - real(default) :: x1, x2, x3 - real(default), parameter :: sqrts = 250.0_default - type(phs_identifier_t), dimension(2) :: phs_identifiers - write (u, "(A)") "* Test output: phs_fks_generator_1" - write (u, "(A)") "* Purpose: Create massless fsr phase space" - write (u, "(A)") + type(test_results_t), intent(inout) :: results + <> + end subroutine phs_wood_vis_test - allocate (p_born (4)) - p_born(1)%p(0) = 125.0_default - p_born(1)%p(1:2) = 0.0_default - p_born(1)%p(3) = 125.0_default - p_born(2)%p(0) = 125.0_default - p_born(2)%p(1:2) = 0.0_default - p_born(2)%p(3) = -125.0_default - p_born(3)%p(0) = 125.0_default - p_born(3)%p(1) = -39.5618_default - p_born(3)%p(2) = -20.0791_default - p_born(3)%p(3) = -114.6957_default - p_born(4)%p(0) = 125.0_default - p_born(4)%p(1:3) = -p_born(3)%p(1:3) +@ %def phs_wood_vis_test +@ +\subsubsection{Phase-space configuration data} +Construct and display a test phase-space configuration object. Also +check the [[azimuthal_dependence]] flag. - allocate (generator%isr_kinematics) - generator%n_in = 2 - generator%isr_kinematics%isr_mode = SQRTS_FIXED - call generator%set_xi_and_y_bounds () +This auxiliary routine writes a phase-space configuration file to unit +[[u_phs]]. +<>= + public :: write_test_phs_file +<>= + subroutine write_test_phs_file (u_phs, procname) + integer, intent(in) :: u_phs + type(string_t), intent(in), optional :: procname + if (present (procname)) then + write (u_phs, "(A,A)") "process ", char (procname) + else + write (u_phs, "(A)") "process testproc" + end if + write (u_phs, "(A,A)") " md5sum_process = ", '""' + write (u_phs, "(A,A)") " md5sum_model_par = ", '""' + write (u_phs, "(A,A)") " md5sum_phs_config = ", '""' + write (u_phs, "(A)") " sqrts = 1000" + write (u_phs, "(A)") " m_threshold_s = 50" + write (u_phs, "(A)") " m_threshold_t = 100" + write (u_phs, "(A)") " off_shell = 2" + write (u_phs, "(A)") " t_channel = 6" + write (u_phs, "(A)") " keep_nonresonant = T" + write (u_phs, "(A)") " grove #1" + write (u_phs, "(A)") " tree 3" + end subroutine write_test_phs_file - call generator%set_sqrts_hat (sqrts) +@ %def write_test_phs_file +@ +<>= + call test (phs_wood_1, "phs_wood_1", & + "phase-space configuration", & + u, results) +<>= + public :: phs_wood_1 +<>= + subroutine phs_wood_1 (u) + integer, intent(in) :: u + type(model_data_t), target :: model + type(process_constants_t) :: process_data + class(phs_config_t), allocatable :: phs_data + type(mapping_defaults_t) :: mapping_defaults + real(default) :: sqrts + integer :: u_phs, iostat + character(32) :: buffer - write (u, "(A)") "* Use four-particle phase space containing: " - call vector4_write_set (p_born, u, testflag = .true., ultra = .true.) - write (u, "(A)") "***********************" + write (u, "(A)") "* Test output: phs_wood_1" + write (u, "(A)") "* Purpose: initialize and display & + &phase-space configuration data" write (u, "(A)") - x1 = 0.5_default; x2 = 0.25_default; x3 = 0.75_default - write (u, "(A)" ) "* Use random numbers: " - write (u, "(A,F3.2,1X,A,F3.2,1X,A,F3.2)") & - "x1: ", x1, "x2: ", x2, "x3: ", x3 + call model%init_test () - allocate (generator%real_kinematics) - call generator%real_kinematics%init (4, 2, 2, 1) + call syntax_phs_forest_init () - allocate (generator%emitters (2)) - generator%emitters(1) = 3; generator%emitters(2) = 4 - allocate (generator%m2 (4)) - generator%m2 = zero - allocate (generator%is_massive (4)) - generator%is_massive(1:2) = .false. - generator%is_massive(3:4) = .true. - phs_identifiers(1)%emitter = 3 - phs_identifiers(2)%emitter = 4 - call generator%compute_xi_ref_momenta (p_born) - call generator%generate_radiation_variables ([x1,x2,x3], p_born, phs_identifiers) - do i_phs = 1, 2 - emitter = phs_identifiers(i_phs)%emitter - call generator%compute_xi_max (emitter, i_phs, p_born, & - generator%real_kinematics%xi_max(i_phs)) - end do - write (u, "(A)") & - "* With these, the following radiation variables have been produced:" - associate (rad_var => generator%real_kinematics) - write (u, "(A,F3.2)") "xi_tilde: ", rad_var%xi_tilde - write (u, "(A,F3.2)") "y: " , rad_var%y(1) - write (u, "(A,F3.2)") "phi: ", rad_var%phi - end associate - call write_separator (u) - write (u, "(A)") "Produce real momenta: " - i_phs = 1; emitter = phs_identifiers(i_phs)%emitter - write (u, "(A,I1)") "emitter: ", emitter + write (u, "(A)") "* Initialize a process" + write (u, "(A)") - allocate (p_real (5)) - call generator%generate_fsr (emitter, i_phs, p_born, p_real) - call vector4_write_set (p_real, u, testflag = .true., ultra = .true.) - call write_separator (u) + call init_test_process_data (var_str ("phs_wood_1"), process_data) + + write (u, "(A)") "* Create a scratch phase-space file" write (u, "(A)") - write (u, "(A)") "* Test output end: phs_fks_generator_1" - end subroutine phs_fks_generator_1 + u_phs = free_unit () + open (u_phs, status = "scratch", action = "readwrite") + call write_test_phs_file (u_phs, var_str ("phs_wood_1")) + rewind (u_phs) + do + read (u_phs, "(A)", iostat = iostat) buffer + if (iostat /= 0) exit + write (u, "(A)") trim (buffer) + end do -@ %def phs_fks_generator_1 -@ -<>= - public :: phs_fks_generator_2 -<>= - subroutine phs_fks_generator_2 (u) - integer, intent(in) :: u - type(phs_fks_generator_t) :: generator - type(vector4_t), dimension(:), allocatable :: p_born - type(vector4_t), dimension(:), allocatable :: p_real - integer :: emitter, i_phs - real(default) :: x1, x2, x3 - real(default), parameter :: sqrts_hadronic = 250.0_default - type(phs_identifier_t), dimension(2) :: phs_identifiers - write (u, "(A)") "* Test output: phs_fks_generator_2" - write (u, "(A)") "* Purpose: Create massless ISR phase space" + write (u, "(A)") + write (u, "(A)") "* Setup phase-space configuration object" write (u, "(A)") + mapping_defaults%step_mapping = .false. - allocate (p_born (4)) - p_born(1)%p(0) = 114.661_default - p_born(1)%p(1:2) = 0.0_default - p_born(1)%p(3) = 114.661_default - p_born(2)%p(0) = 121.784_default - p_born(2)%p(1:2) = 0.0_default - p_born(2)%p(3) = -121.784_default - p_born(3)%p(0) = 115.148_default - p_born(3)%p(1) = -46.250_default - p_born(3)%p(2) = -37.711_default - p_born(3)%p(3) = 98.478_default - p_born(4)%p(0) = 121.296_default - p_born(4)%p(1:2) = -p_born(3)%p(1:2) - p_born(4)%p(3) = -105.601_default + allocate (phs_wood_config_t :: phs_data) + call phs_data%init (process_data, model) + select type (phs_data) + type is (phs_wood_config_t) + call phs_data%set_input (u_phs) + call phs_data%set_mapping_defaults (mapping_defaults) + end select - phs_identifiers(1)%emitter = 1 - phs_identifiers(2)%emitter = 2 + sqrts = 1000._default + call phs_data%configure (sqrts) - allocate (generator%emitters (2)) - allocate (generator%isr_kinematics) - generator%emitters(1) = 1; generator%emitters(2) = 2 - generator%sqrts = sqrts_hadronic - allocate (generator%isr_kinematics%beam_energy(2)) - generator%isr_kinematics%beam_energy = sqrts_hadronic / two - call generator%set_sqrts_hat (sqrts_hadronic) - call generator%set_isr_kinematics (p_born) - generator%n_in = 2 - generator%isr_kinematics%isr_mode = SQRTS_VAR - call generator%set_xi_and_y_bounds () - write (u, "(A)") "* Use four-particle phase space containing: " - call vector4_write_set (p_born, u, testflag = .true., ultra = .true.) - write (u, "(A)") "***********************" + call phs_data%write (u) write (u, "(A)") - x1=0.5_default; x2=0.25_default; x3=0.65_default - write (u, "(A)" ) "* Use random numbers: " - write (u, "(A,F3.2,1X,A,F3.2,1X,A,F3.2)") & - "x1: ", x1, "x2: ", x2, "x3: ", x3 + select type (phs_data) + type is (phs_wood_config_t) + call phs_data%write_forest (u) + end select - allocate (generator%real_kinematics) - call generator%real_kinematics%init (4, 2, 2, 1) - call generator%real_kinematics%p_born_lab%set_momenta (1, p_born) + write (u, "(A)") + write (u, "(A)") "* Cleanup" + + close (u_phs) + call phs_data%final () + call model%final () - allocate (generator%m2 (2)) - generator%m2(1) = 0._default; generator%m2(2) = 0._default - allocate (generator%is_massive (4)) - generator%is_massive = .false. - call generator%generate_radiation_variables ([x1,x2,x3], p_born, phs_identifiers) - call generator%compute_xi_ref_momenta (p_born) - do i_phs = 1, 2 - emitter = phs_identifiers(i_phs)%emitter - call generator%compute_xi_max (emitter, i_phs, p_born, & - generator%real_kinematics%xi_max(i_phs)) - end do - write (u, "(A)") & - "* With these, the following radiation variables have been produced:" - associate (rad_var => generator%real_kinematics) - write (u, "(A,F3.2)") "xi_tilde: ", rad_var%xi_tilde - write (u, "(A,F3.2)") "y: " , rad_var%y(1) - write (u, "(A,F3.2)") "phi: ", rad_var%phi - end associate - write (u, "(A)") "Initial-state momentum fractions: " - associate (xb => generator%isr_kinematics%x) - write (u, "(A,F3.2)") "x_born_plus: ", xb(1) - write (u, "(A,F3.2)") "x_born_minus: ", xb(2) - end associate - call write_separator (u) - write (u, "(A)") "Produce real momenta: " - i_phs = 1; emitter = phs_identifiers(i_phs)%emitter - write (u, "(A,I1)") "emitter: ", emitter - allocate (p_real(5)) - call generator%generate_isr (i_phs, p_born, p_real) - call vector4_write_set (p_real, u, testflag = .true., ultra = .true.) - call write_separator (u) write (u, "(A)") - write (u, "(A)") "* Test output end: phs_fks_generator_2" + write (u, "(A)") "* Test output end: phs_wood_1" - end subroutine phs_fks_generator_2 + end subroutine phs_wood_1 -@ %def phs_fks_generator_2 +@ %def phs_wood_1 @ -<>= - public :: phs_fks_generator_3 -<>= - subroutine phs_fks_generator_3 (u) +\subsubsection{Phase space evaluation} +Compute kinematics for given parameters, also invert the calculation. +<>= + call test (phs_wood_2, "phs_wood_2", & + "phase-space evaluation", & + u, results) +<>= + public :: phs_wood_2 +<>= + subroutine phs_wood_2 (u) integer, intent(in) :: u - type(phs_fks_generator_t) :: generator - type(vector4_t), dimension(:), allocatable :: p_born - type(vector4_t), dimension(:), allocatable :: p_real - real(default) :: x1, x2, x3 - real(default) :: mB, mW, mT - integer :: i, emitter, i_phs - type(phs_identifier_t), dimension(2) :: phs_identifiers + type(model_data_t), target :: model + type(flavor_t) :: flv + type(process_constants_t) :: process_data + real(default) :: sqrts, E + class(phs_config_t), allocatable, target :: phs_data + class(phs_t), pointer :: phs => null () + type(vector4_t), dimension(2) :: p, q + integer :: u_phs - write (u, "(A)") "* Test output: phs_fks_generator_3" - write (u, "(A)") "* Puropse: Create real phase space for particle decays" + write (u, "(A)") "* Test output: phs_wood_2" + write (u, "(A)") "* Purpose: test simple single-channel phase space" write (u, "(A)") - allocate (p_born(3)) - p_born(1)%p(0) = 172._default - p_born(1)%p(1) = 0._default - p_born(1)%p(2) = 0._default - p_born(1)%p(3) = 0._default - p_born(2)%p(0) = 104.72866679_default - p_born(2)%p(1) = 45.028053213_default - p_born(2)%p(2) = 29.450337581_default - p_born(2)%p(3) = -5.910229156_default - p_born(3)%p(0) = 67.271333209_default - p_born(3)%p(1:3) = -p_born(2)%p(1:3) - - generator%n_in = 1 - allocate (generator%isr_kinematics) - generator%isr_kinematics%isr_mode = SQRTS_FIXED - call generator%set_xi_and_y_bounds () + call model%init_test () + call flv%init (25, model) - mB = 4.2_default - mW = 80.376_default - mT = 172._default + write (u, "(A)") "* Initialize a process and a matching & + &phase-space configuration" + write (u, "(A)") - generator%sqrts = mT + call init_test_process_data (var_str ("phs_wood_2"), process_data) + u_phs = free_unit () + open (u_phs, status = "scratch", action = "readwrite") + call write_test_phs_file (u_phs, var_str ("phs_wood_2")) + rewind (u_phs) - write (u, "(A)") "* Use three-particle phase space containing: " - call vector4_write_set (p_born, u, testflag = .true., ultra = .true.) - write (u, "(A)") "**********************" - write (u, "(A)") + allocate (phs_wood_config_t :: phs_data) + call phs_data%init (process_data, model) + select type (phs_data) + type is (phs_wood_config_t) + call phs_data%set_input (u_phs) + end select - x1 = 0.5_default; x2 = 0.25_default; x3 = 0.6_default - write (u, "(A)") "* Use random numbers: " - write (u, "(A,F3.2,1X,A,F3.2,A,1X,F3.2)") & - "x1: ", x1, "x2: ", x2, "x3: ", x3 + sqrts = 1000._default + call phs_data%configure (sqrts) - allocate (generator%real_kinematics) - call generator%real_kinematics%init (3, 2, 2, 1) - call generator%real_kinematics%p_born_lab%set_momenta (1, p_born) + call phs_data%write (u) - allocate (generator%emitters(2)) - generator%emitters(1) = 1 - generator%emitters(2) = 3 - allocate (generator%m2 (3), generator%is_massive(3)) - generator%m2(1) = mT**2 - generator%m2(2) = mW**2 - generator%m2(3) = mB**2 - generator%is_massive = .true. - phs_identifiers(1)%emitter = 1 - phs_identifiers(2)%emitter = 3 + write (u, "(A)") + write (u, "(A)") "* Initialize the phase-space instance" + write (u, "(A)") - call generator%generate_radiation_variables ([x1,x2,x3], p_born, phs_identifiers) - call generator%compute_xi_ref_momenta (p_born) - do i_phs = 1, 2 - emitter = phs_identifiers(i_phs)%emitter - call generator%compute_xi_max (emitter, i_phs, p_born, & - generator%real_kinematics%xi_max(i_phs)) - end do + call phs_data%allocate_instance (phs) + call phs%init (phs_data) - write (u, "(A)") & - "* With these, the following radiation variables have been produced: " - associate (rad_var => generator%real_kinematics) - write (u, "(A,F4.2)") "xi_tilde: ", rad_var%xi_tilde - do i = 1, 2 - write (u, "(A,I1,A,F5.2)") "i: ", i, "y: " , rad_var%y(i) - end do - write (u, "(A,F4.2)") "phi: ", rad_var%phi - end associate + call phs%write (u, verbose=.true.) - call write_separator (u) - write (u, "(A)") "Produce real momenta via initial-state emission: " - i_phs = 1; emitter = phs_identifiers(i_phs)%emitter - write (u, "(A,I1)") "emitter: ", emitter - allocate (p_real (4)) - call generator%generate_isr_fixed_beam_energy (i_phs, p_born, p_real) - call pacify (p_real, 1E-6_default) - call vector4_write_set (p_real, u, testflag = .true., ultra = .true.) - call write_separator(u) - write (u, "(A)") "Produce real momenta via final-state emisson: " - i_phs = 2; emitter = phs_identifiers(i_phs)%emitter - write (u, "(A,I1)") "emitter: ", emitter - call generator%generate_fsr (emitter, i_phs, p_born, p_real) - call pacify (p_real, 1E-6_default) - call vector4_write_set (p_real, u, testflag = .true., ultra = .true.) write (u, "(A)") - write (u, "(A)") "* Test output end: phs_fks_generator_3" - - end subroutine phs_fks_generator_3 + write (u, "(A)") "* Set incoming momenta" + write (u, "(A)") -@ %def phs_fks_generator_3 -@ -<>= - public :: phs_fks_generator_4 -<>= - subroutine phs_fks_generator_4 (u) - integer, intent(in) :: u - type(phs_fks_generator_t) :: generator - type(vector4_t), dimension(:), allocatable :: p_born - type(vector4_t), dimension(:), allocatable :: p_real - integer, dimension(:), allocatable :: emitters - integer, dimension(:,:), allocatable :: resonance_lists - type(resonance_contributors_t), dimension(2) :: alr_contributors - real(default) :: x1, x2, x3 - real(default), parameter :: sqrts = 250.0_default - integer, parameter :: nlegborn = 6 - integer :: i_phs, i_con, emitter - real(default) :: m_inv_born, m_inv_real - character(len=7) :: fmt - type(phs_identifier_t), dimension(2) :: phs_identifiers + E = sqrts / 2 + p(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) + p(2) = vector4_moving (E,-sqrt (E**2 - flv%get_mass ()**2), 3) - call pac_fmt (fmt, FMT_19, FMT_15, .true.) + call phs%set_incoming_momenta (p) + call phs%compute_flux () + call phs%write (u) - write (u, "(A)") "* Test output: phs_fks_generator_4" - write (u, "(A)") "* Purpose: Create FSR phase space with fixed resonances" + write (u, "(A)") + write (u, "(A)") "* Compute phase-space point & + &for x = 0.125, 0.5" write (u, "(A)") - allocate (p_born (nlegborn)) - p_born(1)%p(0) = 250._default - p_born(1)%p(1) = 0._default - p_born(1)%p(2) = 0._default - p_born(1)%p(3) = 250._default - p_born(2)%p(0) = 250._default - p_born(2)%p(1) = 0._default - p_born(2)%p(2) = 0._default - p_born(2)%p(3) = -250._default - p_born(3)%p(0) = 145.91184486_default - p_born(3)%p(1) = 50.39727589_default - p_born(3)%p(2) = 86.74156041_default - p_born(3)%p(3) = -69.03608748_default - p_born(4)%p(0) = 208.1064784_default - p_born(4)%p(1) = -44.07610020_default - p_born(4)%p(2) = -186.34264578_default - p_born(4)%p(3) = 13.48038407_default - p_born(5)%p(0) = 26.25614471_default - p_born(5)%p(1) = -25.12258068_default - p_born(5)%p(2) = -1.09540228_default - p_born(5)%p(3) = -6.27703505_default - p_born(6)%p(0) = 119.72553196_default - p_born(6)%p(1) = 18.80140499_default - p_born(6)%p(2) = 100.69648766_default - p_born(6)%p(3) = 61.83273846_default + call phs%evaluate_selected_channel (1, [0.125_default, 0.5_default]) + call phs%evaluate_other_channels (1) + call phs%write (u) + write (u, "(A)") + select type (phs) + type is (phs_wood_t) + call phs%write_forest (u) + end select - allocate (generator%isr_kinematics) - generator%n_in = 2 - generator%isr_kinematics%isr_mode = SQRTS_FIXED - call generator%set_xi_and_y_bounds () + write (u, "(A)") + write (u, "(A)") "* Inverse kinematics" + write (u, "(A)") - call generator%set_sqrts_hat (sqrts) + call phs%get_outgoing_momenta (q) + call phs%final () + deallocate (phs) - write (u, "(A)") "* Test process: e+ e- -> W+ W- b b~" - write (u, "(A)") "* Resonance pairs: (3,5) and (4,6)" - write (u, "(A)") "* Use four-particle phase space containing: " - call vector4_write_set (p_born, u, testflag = .true., ultra = .true.) - write (u, "(A)") "******************************" - write (u, "(A)") + call phs_data%allocate_instance (phs) + call phs%init (phs_data) - x1 = 0.5_default; x2 = 0.25_default; x3 = 0.75_default - write (u, "(A)") "* Use random numbers: " - write (u, "(A,F3.2,1X,A,F3.2,1X,A,F3.2)") & - "x1: ", x1, "x2: ", x2, "x3: ", x3 + call phs%set_incoming_momenta (p) + call phs%compute_flux () + call phs%set_outgoing_momenta (q) - allocate (generator%real_kinematics) - call generator%real_kinematics%init (nlegborn, 2, 2, 2) + call phs%inverse () + call phs%write (u) + write (u, "(A)") + select type (phs) + type is (phs_wood_t) + call phs%write_forest (u) + end select - allocate (generator%emitters (2)) - generator%emitters(1) = 5; generator%emitters(2) = 6 - allocate (generator%m2 (nlegborn)) - generator%m2 = p_born**2 - allocate (generator%is_massive (nlegborn)) - generator%is_massive (1:2) = .false. - generator%is_massive (3:6) = .true. + call phs%final () + deallocate (phs) - phs_identifiers(1)%emitter = 5 - phs_identifiers(2)%emitter = 6 - do i_phs = 1, 2 - allocate (phs_identifiers(i_phs)%contributors (2)) - end do - allocate (resonance_lists (2, 2)) - resonance_lists (1,:) = [3,5] - resonance_lists (2,:) = [4,6] - !!! Here is obviously some redundance. Surely we can improve on this. - do i_phs = 1, 2 - phs_identifiers(i_phs)%contributors = resonance_lists(i_phs,:) - end do - do i_con = 1, 2 - allocate (alr_contributors(i_con)%c (size (resonance_lists(i_con,:)))) - alr_contributors(i_con)%c = resonance_lists(i_con,:) - end do - call generator%generate_radiation_variables & - ([x1, x2, x3], p_born, phs_identifiers) + close (u_phs) + call phs_data%final () + call model%final () - allocate (p_real(nlegborn + 1)) - call generator%compute_xi_ref_momenta (p_born, alr_contributors) - !!! Keep the distinction between i_phs and i_con because in general, - !!! they are not the same. - do i_phs = 1, 2 - i_con = i_phs - emitter = phs_identifiers(i_phs)%emitter - write (u, "(A,I1,1X,A,I1,A,I1,A)") & - "* Generate FSR phase space for emitter ", emitter, & - "and resonance pair (", resonance_lists (i_con, 1), ",", & - resonance_lists (i_con, 2), ")" - call generator%compute_xi_max (emitter, i_phs, p_born, & - generator%real_kinematics%xi_max(i_phs), i_con = i_con) - call generator%generate_fsr (emitter, i_phs, i_con, p_born, p_real) - call vector4_write_set (p_real, u, testflag = .true., ultra = .true.) - call write_separator(u) - write (u, "(A)") "* Check if resonance masses are conserved: " - m_inv_born = compute_resonance_mass (p_born, resonance_lists (i_con,:)) - m_inv_real = compute_resonance_mass (p_real, resonance_lists (i_con,:), 7) - write (u, "(A,1X, " // fmt // ")") "m_inv_born = ", m_inv_born - write (u, "(A,1X, " // fmt // ")") "m_inv_real = ", m_inv_real - if (abs (m_inv_born - m_inv_real) < tiny_07) then - write (u, "(A)") " Success! " - else - write (u, "(A)") " Failure! " - end if - call write_separator(u) - call write_separator(u) - end do - deallocate (p_real) write (u, "(A)") - write (u, "(A)") "* Test output end: phs_fks_generator_4" - end subroutine phs_fks_generator_4 + write (u, "(A)") "* Test output end: phs_wood_2" -@ %def phs_fks_generator_4 + end subroutine phs_wood_2 + +@ %def phs_wood_2 @ -<>= - public :: phs_fks_generator_5 -<>= - subroutine phs_fks_generator_5 (u) - use ttv_formfactors, only: init_parameters +\subsubsection{Phase-space generation} +Generate phase space for a simple process. +<>= + call test (phs_wood_3, "phs_wood_3", & + "phase-space generation", & + u, results) +<>= + public :: phs_wood_3 +<>= + subroutine phs_wood_3 (u) integer, intent(in) :: u - type(phs_fks_generator_t) :: generator - type(vector4_t), dimension(:), allocatable :: p_born, pb1 - type(vector4_t), dimension(:), allocatable :: p_born_onshell, pb1_os - type(vector4_t), dimension(:), allocatable :: p_real - real(default) :: x1, x2, x3 - real(default) :: mB, mW, mtop, mcheck - integer :: i, emitter, i_phs - type(phs_identifier_t), dimension(2) :: phs_identifiers - type(lorentz_transformation_t) :: L_to_cms - real(default), parameter :: sqrts = 360._default - real(default), parameter :: momentum_tolerance = 1E-10_default - real(default) :: mpole, gam_out + type(model_data_t), target :: model + type(process_constants_t) :: process_data + type(phs_parameters_t) :: phs_par + class(phs_config_t), allocatable :: phs_data + integer :: iostat + character(80) :: buffer - write (u, "(A)") "* Test output: phs_fks_generator_5" - write (u, "(A)") "* Puropse: Perform threshold on-shell projection of " - write (u, "(A)") "* Born momenta and create a real phase-space " - write (u, "(A)") "* point from those. " + write (u, "(A)") "* Test output: phs_wood_3" + write (u, "(A)") "* Purpose: generate a phase-space configuration" write (u, "(A)") - allocate (p_born(6), p_born_onshell(6)) - p_born(1)%p(0) = sqrts / two - p_born(1)%p(1:2) = zero - p_born(1)%p(3) = sqrts / two - p_born(2)%p(0) = sqrts / two - p_born(2)%p(1:2) = zero - p_born(2)%p(3) = -sqrts / two - p_born(3)%p(0) = 117.1179139230_default - p_born(3)%p(1) = 56.91215483880_default - p_born(3)%p(2) = -40.02386013017_default - p_born(3)%p(3) = -49.07634310496_default - p_born(4)%p(0) = 98.91904548743_default - p_born(4)%p(1) = 56.02241403836_default - p_born(4)%p(2) = -8.302977504723_default - p_born(4)%p(3) = -10.50293716131_default - p_born(5)%p(0) = 62.25884689208_default - p_born(5)%p(1) = -60.00786540278_default - p_born(5)%p(2) = 4.753602375910_default - p_born(5)%p(3) = 15.32916731546_default - p_born(6)%p(0) = 81.70419369751_default - p_born(6)%p(1) = -52.92670347439_default - p_born(6)%p(2) = 43.57323525898_default - p_born(6)%p(3) = 44.25011295081_default + call model%init_test () - generator%n_in = 2 - allocate (generator%isr_kinematics) - generator%isr_kinematics%isr_mode = SQRTS_FIXED - call generator%set_xi_and_y_bounds () + call syntax_phs_forest_init () - mB = 4.2_default - mW = 80.376_default - mtop = 172._default + write (u, "(A)") "* Initialize a process and phase-space parameters" + write (u, "(A)") - generator%sqrts = sqrts + call init_test_process_data (var_str ("phs_wood_3"), process_data) + allocate (phs_wood_config_t :: phs_data) + call phs_data%init (process_data, model) - !!! Dummy-initialization of the threshold model because generate_fsr_threshold - !!! uses m1s_to_mpole to determine if it is above or below threshold. - call init_parameters (mpole, gam_out, mtop, one, one / 1.5_default, 125._default, & - 0.47_default, 0.118_default, 91._default, 80._default, 4.2_default, & - one, one, one, one, zero, zero, zero, zero, zero, zero, .false., zero) + phs_par%sqrts = 1000 + select type (phs_data) + type is (phs_wood_config_t) + call phs_data%set_parameters (phs_par) + phs_data%io_unit_keep_open = .true. + end select - write (u, "(A)") "* Use four-particle phase space containing: " - call vector4_write_set (p_born, u, testflag = .true., ultra = .true.) - call vector4_check_momentum_conservation & - (p_born, 2, unit = u, abs_smallness = momentum_tolerance, verbose = .true.) - write (u, "(A)") "**********************" + write (u, "(A)") + write (u, "(A)") "* Generate a scratch phase-space file" write (u, "(A)") - allocate (generator%real_kinematics) - call generator%real_kinematics%init (7, 2, 2, 2) - call generator%real_kinematics%init_onshell (7, 2) - generator%real_kinematics%p_born_cms%phs_point(1) = p_born + call phs_data%configure (phs_par%sqrts) + + select type (phs_data) + type is (phs_wood_config_t) + rewind (phs_data%io_unit) + do + read (phs_data%io_unit, "(A)", iostat = iostat) buffer + if (iostat /= 0) exit + write (u, "(A)") trim (buffer) + end do + end select - write (u, "(A)") "Get boost projection system -> CMS: " - L_to_cms = get_boost_for_threshold_projection (p_born, sqrts, mtop) - call L_to_cms%write (u, testflag = .true., ultra = .true.) - write (u, "(A)") "**********************" write (u, "(A)") + write (u, "(A)") "* Cleanup" - write (u, "(A)") "* Perform onshell-projection:" - pb1 = generator%real_kinematics%p_born_cms%phs_point(1) - call threshold_projection_born (mtop, L_to_cms, pb1, p_born_onshell) - generator%real_kinematics%p_born_onshell%phs_point(1) = p_born_onshell - - call generator%real_kinematics%p_born_onshell%write & - (1, unit = u, testflag = .true., ultra = .true.) + call phs_data%final () + call model%final () - pb1_os = generator%real_kinematics%p_born_onshell%phs_point(1) - call check_phsp (pb1_os, 0) + write (u, "(A)") + write (u, "(A)") "* Test output end: phs_wood_3" - allocate (generator%emitters (2)) - generator%emitters(1) = THR_POS_B; generator%emitters(2) = THR_POS_BBAR + end subroutine phs_wood_3 - allocate (generator%m2 (6), generator%is_massive(6)) - generator%m2 = p_born**2 - generator%is_massive (1:2) = .false. - generator%is_massive (3:6) = .true. +@ %def phs_wood_3 +@ +\subsubsection{Nontrivial process} +Generate phase space for a $2\to 3$ process. +<>= + call test (phs_wood_4, "phs_wood_4", & + "nontrivial process", & + u, results) +<>= + public :: phs_wood_4 +<>= + subroutine phs_wood_4 (u) + integer, intent(in) :: u + type(model_data_t), target :: model + type(process_constants_t) :: process_data + type(phs_parameters_t) :: phs_par + class(phs_config_t), allocatable, target :: phs_data + integer :: iostat + character(80) :: buffer + class(phs_t), pointer :: phs => null () + real(default) :: E, pL + type(vector4_t), dimension(2) :: p + type(vector4_t), dimension(3) :: q - phs_identifiers(1)%emitter = THR_POS_B - phs_identifiers(2)%emitter = THR_POS_BBAR + write (u, "(A)") "* Test output: phs_wood_4" + write (u, "(A)") "* Purpose: generate a phase-space configuration" + write (u, "(A)") - x1 = 0.5_default; x2 = 0.25_default; x3 = 0.6_default - write (u, "(A)") "* Use random numbers: " - write (u, "(A,F3.2,1X,A,F3.2,A,1X,F3.2)") & - "x1: ", x1, "x2: ", x2, "x3: ", x3 + call model%init_test () + call syntax_phs_forest_init () - call generator%generate_radiation_variables ([x1,x2,x3], p_born_onshell, phs_identifiers) - do i_phs = 1, 2 - emitter = phs_identifiers(i_phs)%emitter - call generator%compute_xi_ref_momenta_threshold (p_born_onshell) - call generator%compute_xi_max (emitter, i_phs, p_born_onshell, & - generator%real_kinematics%xi_max(i_phs), i_con = thr_leg(emitter)) - end do - write (u, "(A)") & - "* With these, the following radiation variables have been produced: " - associate (rad_var => generator%real_kinematics) - write (u, "(A,F4.2)") "xi_tilde: ", rad_var%xi_tilde - write (u, "(A)") "xi_max: " - write (u, "(2F5.2)") rad_var%xi_max(1), rad_var%xi_max(2) - write (u, "(A)") "y: " - write (u, "(2F5.2)") rad_var%y(1), rad_var%y(2) - write (u, "(A,F4.2)") "phi: ", rad_var%phi - end associate + write (u, "(A)") "* Initialize a process and phase-space parameters" + write (u, "(A)") - call write_separator (u) - write (u, "(A)") "* Produce real momenta from on-shell phase space: " - allocate (p_real(7)) - do i_phs = 1, 2 - emitter = phs_identifiers(i_phs)%emitter - write (u, "(A,I1)") "emitter: ", emitter - call generator%generate_fsr_threshold (emitter, i_phs, p_born_onshell, p_real) - call check_phsp (p_real, emitter) - end do + process_data%id = "phs_wood_4" + process_data%model_name = "Test" + process_data%n_in = 2 + process_data%n_out = 3 + process_data%n_flv = 1 + allocate (process_data%flv_state (process_data%n_in + process_data%n_out, & + process_data%n_flv)) + process_data%flv_state(:,1) = [25, 25, 25, 6, -6] + + allocate (phs_wood_config_t :: phs_data) + call phs_data%init (process_data, model) + + phs_par%sqrts = 1000 + select type (phs_data) + type is (phs_wood_config_t) + call phs_data%set_parameters (phs_par) + phs_data%io_unit_keep_open = .true. + end select - call write_separator(u) write (u, "(A)") - write (u, "(A)") "* Test output end: phs_fks_generator_5" + write (u, "(A)") "* Generate a scratch phase-space file" + write (u, "(A)") - contains - subroutine check_phsp (p, emitter) - type(vector4_t), intent(inout), dimension(:) :: p - integer, intent(in) :: emitter - type(vector4_t) :: pp - real(default) :: E_tot - logical :: check - write (u, "(A)") "* Check momentum conservation: " - call vector4_check_momentum_conservation & - (p, 2, unit = u, abs_smallness = momentum_tolerance, verbose = .true.) - write (u, "(A)") "* Check invariant masses: " - write (u, "(A)", advance = "no") "inv(W+, b, gl): " - pp = p(THR_POS_WP) + p(THR_POS_B) - if (emitter == THR_POS_B) pp = pp + p(THR_POS_GLUON) - if (nearly_equal (pp**1, mtop)) then - write (u, "(A)") "CHECK" - else - write (u, "(A,F7.3)") "FAIL: ", pp**1 - end if - write (u, "(A)", advance = "no") "inv(W-, bbar): " - pp = p(THR_POS_WM) + p(THR_POS_BBAR) - if (emitter == THR_POS_BBAR) pp = pp + p(THR_POS_GLUON) - if (nearly_equal (pp**1, mtop)) then - write (u, "(A)") "CHECK" - else - write (u, "(A,F7.3)") "FAIL: ", pp**1 - end if - write (u, "(A)") "* Sum of energies equal to sqrts?" - E_tot = sum(p(1:2)%p(0)); check = nearly_equal (E_tot, sqrts) - write (u, "(A,L1)") "Initial state: ", check - if (.not. check) write (u, "(A,F7.3)") "E_tot: ", E_tot - if (emitter > 0) then - E_tot = sum(p(3:7)%p(0)) - else - E_tot = sum(p(3:6)%p(0)) - end if - check = nearly_equal (E_tot, sqrts) - write (u, "(A,L1)") "Final state : ", check - if (.not. check) write (u, "(A,F7.3)") "E_tot: ", E_tot - call pacify (p, 1E-6_default) - call vector4_write_set (p, u, testflag = .true., ultra = .true.) + call phs_data%configure (phs_par%sqrts) - end subroutine check_phsp - end subroutine phs_fks_generator_5 + select type (phs_data) + type is (phs_wood_config_t) + rewind (phs_data%io_unit) + do + read (phs_data%io_unit, "(A)", iostat = iostat) buffer + if (iostat /= 0) exit + write (u, "(A)") trim (buffer) + end do + end select -@ %def phs_fks_generator_5 -@ + write (u, "(A)") + write (u, "(A)") "* Initialize the phase-space instance" + write (u, "(A)") -<>= - public :: phs_fks_generator_6 -<>= - subroutine phs_fks_generator_6 (u) - integer, intent(in) :: u - type(phs_fks_generator_t) :: generator - type(vector4_t), dimension(:), allocatable :: p_born - type(vector4_t), dimension(:), allocatable :: p_real - real(default) :: x1, x2, x3 - real(default) :: mB, mW, mT - integer :: i, emitter, i_phs - type(phs_identifier_t), dimension(2) :: phs_identifiers + call phs_data%allocate_instance (phs) + call phs%init (phs_data) - write (u, "(A)") "* Test output: phs_fks_generator_6" - write (u, "(A)") "* Puropse: Create real phase space for particle decays" + write (u, "(A)") "* Set incoming momenta" write (u, "(A)") - allocate (p_born(4)) - p_born(1)%p(0) = 173.1_default - p_born(1)%p(1) = zero - p_born(1)%p(2) = zero - p_born(1)%p(3) = zero - p_born(2)%p(0) = 68.17074462929_default - p_born(2)%p(1) = -37.32578717617_default - p_born(2)%p(2) = 30.99675959336_default - p_born(2)%p(3) = -47.70321718398_default - p_born(3)%p(0) = 65.26639312326_default - p_born(3)%p(1) = -1.362927648502_default - p_born(3)%p(2) = -33.25327150840_default - p_born(3)%p(3) = 56.14324922494_default - p_born(4)%p(0) = 39.66286224745_default - p_born(4)%p(1) = 38.68871482467_default - p_born(4)%p(2) = 2.256511915049_default - p_born(4)%p(3) = -8.440032040958_default + select type (phs_data) + type is (phs_wood_config_t) + E = phs_data%sqrts / 2 + pL = sqrt (E**2 - phs_data%flv(1,1)%get_mass ()**2) + end select + p(1) = vector4_moving (E, pL, 3) + p(2) = vector4_moving (E, -pL, 3) - generator%n_in = 1 - allocate (generator%isr_kinematics) - generator%isr_kinematics%isr_mode = SQRTS_FIXED - call generator%set_xi_and_y_bounds () + call phs%set_incoming_momenta (p) + call phs%compute_flux () - mB = 4.2_default - mW = 80.376_default - mT = 173.1_default + write (u, "(A)") "* Compute phase-space point & + &for x = 0.1, 0.2, 0.3, 0.4, 0.5" + write (u, "(A)") - generator%sqrts = mT + call phs%evaluate_selected_channel (1, & + [0.1_default, 0.2_default, 0.3_default, 0.4_default, 0.5_default]) + call phs%evaluate_other_channels (1) + call phs%write (u) - write (u, "(A)") "* Use four-particle phase space containing: " - call vector4_write_set (p_born, u, testflag = .true., ultra = .true.) - write (u, "(A)") "**********************" + write (u, "(A)") + write (u, "(A)") "* Inverse kinematics" write (u, "(A)") - x1=0.5_default; x2=0.25_default; x3=0.6_default - write (u, "(A)") "* Use random numbers: " - write (u, "(A,F3.2,1X,A,F3.2,A,1X,F3.2)") & - "x1: ", x1, "x2: ", x2, "x3: ", x3 + call phs%get_outgoing_momenta (q) + call phs%final () + deallocate (phs) - allocate (generator%real_kinematics) - call generator%real_kinematics%init (3, 2, 2, 1) - call generator%real_kinematics%p_born_lab%set_momenta (1, p_born) + call phs_data%allocate_instance (phs) + call phs%init (phs_data) - allocate (generator%emitters(2)) - generator%emitters(1) = 1 - generator%emitters(2) = 2 - allocate (generator%m2 (4), generator%is_massive(4)) - generator%m2(1) = mT**2 - generator%m2(2) = mB**2 - generator%m2(3) = zero - generator%m2(4) = zero - generator%is_massive(1:2) = .true. - generator%is_massive(3:4) = .false. - phs_identifiers(1)%emitter = 1 - phs_identifiers(2)%emitter = 2 + call phs%set_incoming_momenta (p) + call phs%compute_flux () + call phs%set_outgoing_momenta (q) - call generator%generate_radiation_variables ([x1,x2,x3], p_born, phs_identifiers) - call generator%compute_xi_ref_momenta (p_born) - do i_phs = 1, 2 - emitter = phs_identifiers(i_phs)%emitter - call generator%compute_xi_max (emitter, i_phs, p_born, & - generator%real_kinematics%xi_max(i_phs)) - end do + call phs%inverse () + call phs%write (u) - write (u, "(A)") & - "* With these, the following radiation variables have been produced: " - associate (rad_var => generator%real_kinematics) - write (u, "(A,F4.2)") "xi_tilde: ", rad_var%xi_tilde - do i = 1, 2 - write (u, "(A,I1,A,F5.2)") "i: ", i, "y: " , rad_var%y(i) - end do - write (u, "(A,F4.2)") "phi: ", rad_var%phi - end associate + write (u, "(A)") + write (u, "(A)") "* Cleanup" + + call phs%final () + deallocate (phs) + + call phs_data%final () + call model%final () - call write_separator (u) - write (u, "(A)") "Produce real momenta via initial-state emission: " - i_phs = 1; emitter = phs_identifiers(i_phs)%emitter - write (u, "(A,I1)") "emitter: ", emitter - allocate (p_real(5)) - call generator%generate_isr_fixed_beam_energy (i_phs, p_born, p_real) - call pacify (p_real, 1E-6_default) - call vector4_write_set (p_real, u, testflag = .true., ultra = .true.) - call write_separator(u) - write (u, "(A)") "Produce real momenta via final-state emisson: " - i_phs = 2; emitter = phs_identifiers(i_phs)%emitter - write (u, "(A,I1)") "emitter: ", emitter - call generator%generate_fsr (emitter, i_phs, p_born, p_real) - call pacify (p_real, 1E-6_default) - call vector4_write_set (p_real, u, testflag = .true., ultra = .true.) write (u, "(A)") - write (u, "(A)") "* Test output end: phs_fks_generator_6" + write (u, "(A)") "* Test output end: phs_wood_4" - end subroutine phs_fks_generator_6 + end subroutine phs_wood_4 -@ %def phs_fks_generator_6 +@ %def phs_wood_4 @ -<>= - public :: phs_fks_generator_7 -<>= - subroutine phs_fks_generator_7 (u) +\subsubsection{Equivalences} +Generate phase space for a simple process, including channel equivalences. +<>= + call test (phs_wood_5, "phs_wood_5", & + "equivalences", & + u, results) +<>= + public :: phs_wood_5 +<>= + subroutine phs_wood_5 (u) integer, intent(in) :: u - type(phs_fks_generator_t) :: generator - type(vector4_t), dimension(:), allocatable :: p_born - type(vector4_t), dimension(:), allocatable :: p_real - real(default) :: x1, x2, x3 - integer :: i, emitter, i_phs - type(phs_identifier_t), dimension(2) :: phs_identifiers - real(default), parameter :: sqrts = 1000.0_default + type(model_data_t), target :: model + type(process_constants_t) :: process_data + type(phs_parameters_t) :: phs_par + class(phs_config_t), allocatable :: phs_data - write (u, "(A)") "* Test output: phs_fks_generator_7" - write (u, "(A)") "* Puropse: Create real phase space for scattering ISR" - write (u, "(A)") "* keeping the beam energy fixed." + write (u, "(A)") "* Test output: phs_wood_5" + write (u, "(A)") "* Purpose: generate a phase-space configuration" write (u, "(A)") - allocate (p_born(4)) - p_born(1)%p(0) = 500._default - p_born(1)%p(1) = 0._default - p_born(1)%p(2) = 0._default - p_born(1)%p(3) = 500._default - p_born(2)%p(0) = 500._default - p_born(2)%p(1) = 0._default - p_born(2)%p(2) = 0._default - p_born(2)%p(3) = -500._default - p_born(3)%p(0) = 500._default - p_born(3)%p(1) = 11.275563070_default - p_born(3)%p(2) = -13.588797663_default - p_born(3)%p(3) = 486.93070588_default - p_born(4)%p(0) = 500._default - p_born(4)%p(1:3) = -p_born(3)%p(1:3) - - phs_identifiers(1)%emitter = 1 - phs_identifiers(2)%emitter = 2 + call model%init_test () - allocate (generator%emitters(2)) - generator%n_in = 2 - allocate (generator%isr_kinematics) - generator%isr_kinematics%isr_mode = SQRTS_FIXED - call generator%set_xi_and_y_bounds () - generator%emitters(1) = 1; generator%emitters(2) = 2 - generator%sqrts = sqrts + call syntax_phs_forest_init () - write (u, "(A)") "* Use 2 -> 2 phase space containing: " - call vector4_write_set (p_born, u, testflag = .true., ultra = .true.) - write (u, "(A)") "**********************" + write (u, "(A)") "* Initialize a process and phase-space parameters" write (u, "(A)") - x1 = 0.5_default; x2 = 0.25_default; x3 = 0.6_default - write (u, "(A)") "* Use random numbers: " - write (u, "(A,F3.2,1X,A,F3.2,A,1X,F3.2)") & - "x1: ", x1, "x2: ", x2, "x3: ", x3 - - allocate (generator%real_kinematics) - call generator%real_kinematics%init (4, 2, 2, 1) - call generator%real_kinematics%p_born_lab%set_momenta (1, p_born) + call init_test_process_data (var_str ("phs_wood_5"), process_data) + allocate (phs_wood_config_t :: phs_data) + call phs_data%init (process_data, model) - allocate (generator%m2 (4)) - generator%m2 = 0._default - allocate (generator%is_massive(4)) - generator%is_massive = .false. - call generator%generate_radiation_variables ([x1,x2,x3], p_born, phs_identifiers) - call generator%compute_xi_ref_momenta (p_born) - do i_phs = 1, 2 - emitter = phs_identifiers(i_phs)%emitter - call generator%compute_xi_max (emitter, i_phs, p_born, & - generator%real_kinematics%xi_max(i_phs)) - end do + phs_par%sqrts = 1000 + select type (phs_data) + type is (phs_wood_config_t) + call phs_data%set_parameters (phs_par) + call phs_data%enable_equivalences () + end select - write (u, "(A)") & - "* With these, the following radiation variables have been produced: " - associate (rad_var => generator%real_kinematics) - write (u, "(A,F4.2)") "xi_tilde: ", rad_var%xi_tilde - do i = 1, 2 - write (u, "(A,I1,A,F5.2)") "i: ", i, "y: " , rad_var%y(i) - end do - write (u, "(A,F4.2)") "phi: ", rad_var%phi - end associate + write (u, "(A)") + write (u, "(A)") "* Generate a scratch phase-space file" + write (u, "(A)") - call write_separator (u) - write (u, "(A)") "Produce real momenta via initial-state emission: " - i_phs = 1; emitter = phs_identifiers(i_phs)%emitter - write (u, "(A,I1)") "emitter: ", emitter - allocate (p_real(5)) - call generator%generate_isr_fixed_beam_energy (i_phs, p_born, p_real) - call pacify (p_real, 1E-6_default) - call vector4_write_set (p_real, u, testflag = .true., ultra = .true.) - call write_separator(u) - i_phs = 2; emitter = phs_identifiers(i_phs)%emitter - write (u, "(A,I1)") "emitter: ", emitter - call generator%generate_isr_fixed_beam_energy (i_phs, p_born, p_real) - call pacify (p_real, 1E-6_default) - call vector4_write_set (p_real, u, testflag = .true., ultra = .true.) + call phs_data%configure (phs_par%sqrts) + call phs_data%write (u) write (u, "(A)") - write (u, "(A)") "* Test output end: phs_fks_generator_7" - end subroutine phs_fks_generator_7 + select type (phs_data) + type is (phs_wood_config_t) + call phs_data%write_forest (u) + end select -@ %def phs_fks_generator_3 -@ -\section{Dispatch} -<<[[dispatch_phase_space.f90]]>>= -<> + write (u, "(A)") + write (u, "(A)") "* Cleanup" -module dispatch_phase_space + call phs_data%final () + call model%final () -<> -<> - use io_units, only: free_unit - use variables, only: var_list_t - use os_interface, only: os_data_t - use diagnostics + write (u, "(A)") + write (u, "(A)") "* Test output end: phs_wood_5" - use sf_mappings, only: sf_channel_t - use beam_structures, only: beam_structure_t - use dispatch_beams, only: sf_prop_t, strfun_mode + end subroutine phs_wood_5 - use mappings - use phs_forests, only: phs_parameters_t - use phs_base - use phs_none - use phs_single - use phs_rambo - use phs_wood - use phs_fks +@ %def phs_wood_5 +@ +\subsubsection{MD5 sum checks} +Generate phase space for a simple process. Repeat this with and without +parameter change. +<>= + call test (phs_wood_6, "phs_wood_6", & + "phase-space generation", & + u, results) +<>= + public :: phs_wood_6 +<>= + subroutine phs_wood_6 (u) + integer, intent(in) :: u + type(model_data_t), target :: model + type(process_constants_t) :: process_data + type(phs_parameters_t) :: phs_par + class(phs_config_t), allocatable :: phs_data + logical :: exist, found, match + integer :: u_phs + character(*), parameter :: filename = "phs_wood_6_p.phs" -<> + write (u, "(A)") "* Test output: phs_wood_6" + write (u, "(A)") "* Purpose: generate and check phase-space file" + write (u, "(A)") -<> + call model%init_test () -contains + call syntax_phs_forest_init () -<> + write (u, "(A)") "* Initialize a process and phase-space parameters" + write (u, "(A)") -end module dispatch_phase_space -@ %def dispatch_phase_space -Allocate a phase-space object according to the variable [[$phs_method]]. -<>= - public :: dispatch_phs -<>= - subroutine dispatch_phs (phs, var_list, os_data, process_id, & - mapping_defaults, phs_par, phs_method_in) - class(phs_config_t), allocatable, intent(inout) :: phs - type(var_list_t), intent(in) :: var_list - type(os_data_t), intent(in) :: os_data - type(string_t), intent(in) :: process_id - type(mapping_defaults_t), intent(in), optional :: mapping_defaults - type(phs_parameters_t), intent(in), optional :: phs_par - type(string_t), intent(in), optional :: phs_method_in - type(string_t) :: phs_method, phs_file, run_id - logical :: use_equivalences, vis_channels, fatal_beam_decay - integer :: u_phs - logical :: exist - if (present (phs_method_in)) then - phs_method = phs_method_in - else - phs_method = & - var_list%get_sval (var_str ("$phs_method")) - end if - phs_file = & - var_list%get_sval (var_str ("$phs_file")) - use_equivalences = & - var_list%get_lval (var_str ("?use_vamp_equivalences")) - vis_channels = & - var_list%get_lval (var_str ("?vis_channels")) - fatal_beam_decay = & - var_list%get_lval (var_str ("?fatal_beam_decay")) - run_id = & - var_list%get_sval (var_str ("$run_id")) - select case (char (phs_method)) - case ("none") - allocate (phs_none_config_t :: phs) - case ("single") - allocate (phs_single_config_t :: phs) - if (vis_channels) then - call msg_warning ("Visualizing phase space channels not " // & - "available for method 'single'.") - end if - case ("rambo") - allocate (phs_rambo_config_t :: phs) - if (vis_channels) & - call msg_warning ("Visualizing phase space channels not " // & - "available for method 'rambo'.") - case ("fks") - allocate (phs_fks_config_t :: phs) - if (use_equivalences) then - select type (phs) - type is (phs_fks_config_t) - call phs%enable_equivalences () - end select - end if - case ("wood", "default", "fast_wood") - call dispatch_wood () - case default - call msg_fatal ("Phase space: parameterization method '" & - // char (phs_method) // "' not implemented") - end select - contains - <> - end subroutine dispatch_phs + call init_test_process_data (var_str ("phs_wood_6"), process_data) + process_data%id = "phs_wood_6_p" + process_data%md5sum = "1234567890abcdef1234567890abcdef" + allocate (phs_wood_config_t :: phs_data) + call phs_data%init (process_data, model) -@ %def dispatch_phs -@ -<>= - subroutine dispatch_wood () - allocate (phs_wood_config_t :: phs) - select type (phs) + phs_par%sqrts = 1000 + select type (phs_data) type is (phs_wood_config_t) - if (phs_file /= "") then - inquire (file = char (phs_file), exist = exist) - if (exist) then - call msg_message ("Phase space: reading configuration from '" & - // char (phs_file) // "'") - u_phs = free_unit () - open (u_phs, file = char (phs_file), & - action = "read", status = "old") - call phs%set_input (u_phs) - else - call msg_fatal ("Phase space: configuration file '" & - // char (phs_file) // "' not found") - end if - end if - if (present (phs_par)) & - call phs%set_parameters (phs_par) - if (use_equivalences) & - call phs%enable_equivalences () - if (present (mapping_defaults)) & - call phs%set_mapping_defaults (mapping_defaults) - if (phs_method == "fast_wood") phs%use_cascades2 = .true. - phs%vis_channels = vis_channels - phs%fatal_beam_decay = fatal_beam_decay - phs%os_data = os_data - phs%run_id = run_id - end select - end subroutine dispatch_wood - -@ -@ Configure channel mappings, using some conditions -from the phase space configuration. If there are no structure -functions, we enable a default setup with a single (dummy) -structure-function channel. Otherwise, we look at the channel -collection that we got from the phase-space configuration step. Each -entry should be translated into an independent structure-function -channel, where typically there is one default entry, which could be -mapped using a standard s-channel mapping if the structure function -setup recommends this, and other entries with s-channel resonances. -The latter need to be translated into global mappings from the -structure-function chain. -<>= - public :: dispatch_sf_channels -<>= - subroutine dispatch_sf_channels (sf_channel, sf_string, sf_prop, coll, & - var_list, sqrts, beam_structure) - type(sf_channel_t), dimension(:), allocatable, intent(out) :: sf_channel - type(string_t), intent(out) :: sf_string - type(sf_prop_t), intent(in) :: sf_prop - type(phs_channel_collection_t), intent(in) :: coll - type(var_list_t), intent(in) :: var_list - real(default), intent(in) :: sqrts - type(beam_structure_t), intent(in) :: beam_structure - type(beam_structure_t) :: beam_structure_tmp - class(channel_prop_t), allocatable :: prop - integer :: n_strfun, n_sf_channel, i - logical :: sf_allow_s_mapping, circe1_map, circe1_generate - logical :: s_mapping_enable, endpoint_mapping, power_mapping - logical :: single_parameter - integer, dimension(:), allocatable :: s_mapping, single_mapping - real(default) :: s_mapping_power - real(default) :: circe1_mapping_slope, endpoint_mapping_slope - real(default) :: power_mapping_eps - beam_structure_tmp = beam_structure - call beam_structure_tmp%expand (strfun_mode) - n_strfun = beam_structure_tmp%get_n_record () - sf_string = beam_structure_tmp%to_string (sf_only = .true.) - sf_allow_s_mapping = & - var_list%get_lval (var_str ("?sf_allow_s_mapping")) - circe1_generate = & - var_list%get_lval (var_str ("?circe1_generate")) - circe1_map = & - var_list%get_lval (var_str ("?circe1_map")) - circe1_mapping_slope = & - var_list%get_rval (var_str ("circe1_mapping_slope")) - s_mapping_enable = .false. - s_mapping_power = 1 - endpoint_mapping = .false. - endpoint_mapping_slope = 1 - power_mapping = .false. - single_parameter = .false. - select case (char (sf_string)) - case ("", "[any particles]") - case ("pdf_builtin, none", & - "pdf_builtin_photon, none", & - "none, pdf_builtin", & - "none, pdf_builtin_photon", & - "lhapdf, none", & - "lhapdf_photon, none", & - "none, lhapdf", & - "none, lhapdf_photon") - single_parameter = .true. - case ("pdf_builtin, none => none, pdf_builtin", & - "pdf_builtin, none => none, pdf_builtin_photon", & - "pdf_builtin_photon, none => none, pdf_builtin", & - "pdf_builtin_photon, none => none, pdf_builtin_photon", & - "lhapdf, none => none, lhapdf", & - "lhapdf, none => none, lhapdf_photon", & - "lhapdf_photon, none => none, lhapdf", & - "lhapdf_photon, none => none, lhapdf_photon") - allocate (s_mapping (2), source = [1, 2]) - s_mapping_enable = .true. - s_mapping_power = 2 - case ("pdf_builtin, none => none, pdf_builtin => epa, none => none, epa", & - "pdf_builtin, none => none, pdf_builtin => ewa, none => none, ewa", & - "pdf_builtin, none => none, pdf_builtin => ewa, none => none, epa", & - "pdf_builtin, none => none, pdf_builtin => epa, none => none, ewa") - allocate (s_mapping (2), source = [1, 2]) - s_mapping_enable = .true. - s_mapping_power = 2 - case ("isr, none", & - "none, isr") - allocate (single_mapping (1), source = [1]) - single_parameter = .true. - case ("isr, none => none, isr") - allocate (s_mapping (2), source = [1, 2]) - power_mapping = .true. - power_mapping_eps = minval (sf_prop%isr_eps) - case ("isr, none => none, isr => epa, none => none, epa", & - "isr, none => none, isr => ewa, none => none, ewa", & - "isr, none => none, isr => ewa, none => none, epa", & - "isr, none => none, isr => epa, none => none, ewa") - allocate (s_mapping (2), source = [1, 2]) - power_mapping = .true. - power_mapping_eps = minval (sf_prop%isr_eps) - case ("circe1 => isr, none => none, isr => epa, none => none, epa", & - "circe1 => isr, none => none, isr => ewa, none => none, ewa", & - "circe1 => isr, none => none, isr => ewa, none => none, epa", & - "circe1 => isr, none => none, isr => epa, none => none, ewa") - if (circe1_generate) then - allocate (s_mapping (2), source = [2, 3]) - else - allocate (s_mapping (3), source = [1, 2, 3]) - endpoint_mapping = .true. - endpoint_mapping_slope = circe1_mapping_slope - end if - power_mapping = .true. - power_mapping_eps = minval (sf_prop%isr_eps) - case ("pdf_builtin, none => none, isr", & - "pdf_builtin_photon, none => none, isr", & - "lhapdf, none => none, isr", & - "lhapdf_photon, none => none, isr") - allocate (single_mapping (1), source = [2]) - case ("isr, none => none, pdf_builtin", & - "isr, none => none, pdf_builtin_photon", & - "isr, none => none, lhapdf", & - "isr, none => none, lhapdf_photon") - allocate (single_mapping (1), source = [1]) - case ("epa, none", & - "none, epa") - allocate (single_mapping (1), source = [1]) - single_parameter = .true. - case ("epa, none => none, epa") - allocate (single_mapping (2), source = [1, 2]) - case ("epa, none => none, isr", & - "isr, none => none, epa", & - "ewa, none => none, isr", & - "isr, none => none, ewa") - allocate (single_mapping (2), source = [1, 2]) - case ("pdf_builtin, none => none, epa", & - "pdf_builtin_photon, none => none, epa", & - "lhapdf, none => none, epa", & - "lhapdf_photon, none => none, epa") - allocate (single_mapping (1), source = [2]) - case ("pdf_builtin, none => none, ewa", & - "pdf_builtin_photon, none => none, ewa", & - "lhapdf, none => none, ewa", & - "lhapdf_photon, none => none, ewa") - allocate (single_mapping (1), source = [2]) - case ("epa, none => none, pdf_builtin", & - "epa, none => none, pdf_builtin_photon", & - "epa, none => none, lhapdf", & - "epa, none => none, lhapdf_photon") - allocate (single_mapping (1), source = [1]) - case ("ewa, none => none, pdf_builtin", & - "ewa, none => none, pdf_builtin_photon", & - "ewa, none => none, lhapdf", & - "ewa, none => none, lhapdf_photon") - allocate (single_mapping (1), source = [1]) - case ("ewa, none", & - "none, ewa") - allocate (single_mapping (1), source = [1]) - single_parameter = .true. - case ("ewa, none => none, ewa") - allocate (single_mapping (2), source = [1, 2]) - case ("energy_scan, none => none, energy_scan") - allocate (s_mapping (2), source = [1, 2]) - case ("sf_test_1, none => none, sf_test_1") - allocate (s_mapping (2), source = [1, 2]) - case ("circe1") - if (circe1_generate) then - !!! no mapping - else if (circe1_map) then - allocate (s_mapping (1), source = [1]) - endpoint_mapping = .true. - endpoint_mapping_slope = circe1_mapping_slope - else - allocate (s_mapping (1), source = [1]) - s_mapping_enable = .true. - end if - case ("circe1 => isr, none => none, isr") - if (circe1_generate) then - allocate (s_mapping (2), source = [2, 3]) - else - allocate (s_mapping (3), source = [1, 2, 3]) - endpoint_mapping = .true. - endpoint_mapping_slope = circe1_mapping_slope - end if - power_mapping = .true. - power_mapping_eps = minval (sf_prop%isr_eps) - case ("circe1 => isr, none", & - "circe1 => none, isr") - allocate (single_mapping (1), source = [2]) - case ("circe1 => epa, none => none, epa") - if (circe1_generate) then - allocate (single_mapping (2), source = [2, 3]) - else - call msg_fatal ("CIRCE/EPA: supported with ?circe1_generate=true & - &only") - end if - case ("circe1 => ewa, none => none, ewa") - if (circe1_generate) then - allocate (single_mapping (2), source = [2, 3]) - else - call msg_fatal ("CIRCE/EWA: supported with ?circe1_generate=true & - &only") - end if - case ("circe1 => epa, none", & - "circe1 => none, epa") - if (circe1_generate) then - allocate (single_mapping (1), source = [2]) - else - call msg_fatal ("CIRCE/EPA: supported with ?circe1_generate=true & - &only") - end if - case ("circe1 => epa, none => none, isr", & - "circe1 => isr, none => none, epa", & - "circe1 => ewa, none => none, isr", & - "circe1 => isr, none => none, ewa") - if (circe1_generate) then - allocate (single_mapping (2), source = [2, 3]) - else - call msg_fatal ("CIRCE/EPA: supported with ?circe1_generate=true & - &only") - end if - case ("circe2", & - "gaussian", & - "beam_events") - !!! no mapping - case ("circe2 => isr, none => none, isr", & - "gaussian => isr, none => none, isr", & - "beam_events => isr, none => none, isr") - allocate (s_mapping (2), source = [2, 3]) - power_mapping = .true. - power_mapping_eps = minval (sf_prop%isr_eps) - case ("circe2 => isr, none", & - "circe2 => none, isr", & - "gaussian => isr, none", & - "gaussian => none, isr", & - "beam_events => isr, none", & - "beam_events => none, isr") - allocate (single_mapping (1), source = [2]) - case ("circe2 => epa, none => none, epa", & - "gaussian => epa, none => none, epa", & - "beam_events => epa, none => none, epa") - allocate (single_mapping (2), source = [2, 3]) - case ("circe2 => epa, none", & - "circe2 => none, epa", & - "circe2 => ewa, none", & - "circe2 => none, ewa", & - "gaussian => epa, none", & - "gaussian => none, epa", & - "gaussian => ewa, none", & - "gaussian => none, ewa", & - "beam_events => epa, none", & - "beam_events => none, epa", & - "beam_events => ewa, none", & - "beam_events => none, ewa") - allocate (single_mapping (1), source = [2]) - case ("circe2 => epa, none => none, isr", & - "circe2 => isr, none => none, epa", & - "circe2 => ewa, none => none, isr", & - "circe2 => isr, none => none, ewa", & - "gaussian => epa, none => none, isr", & - "gaussian => isr, none => none, epa", & - "gaussian => ewa, none => none, isr", & - "gaussian => isr, none => none, ewa", & - "beam_events => epa, none => none, isr", & - "beam_events => isr, none => none, epa", & - "beam_events => ewa, none => none, isr", & - "beam_events => isr, none => none, ewa") - allocate (single_mapping (2), source = [2, 3]) - case ("energy_scan") - case default - call msg_fatal ("Beam structure: " & - // char (sf_string) // " not supported") + call phs_data%set_parameters (phs_par) end select - if (sf_allow_s_mapping .and. coll%n > 0) then - n_sf_channel = coll%n - allocate (sf_channel (n_sf_channel)) - do i = 1, n_sf_channel - call sf_channel(i)%init (n_strfun) - if (allocated (single_mapping)) then - call sf_channel(i)%activate_mapping (single_mapping) - end if - if (allocated (prop)) deallocate (prop) - call coll%get_entry (i, prop) - if (allocated (prop)) then - if (endpoint_mapping .and. power_mapping) then - select type (prop) - type is (resonance_t) - call sf_channel(i)%set_eir_mapping (s_mapping, & - a = endpoint_mapping_slope, eps = power_mapping_eps, & - m = prop%mass / sqrts, w = prop%width / sqrts) - type is (on_shell_t) - call sf_channel(i)%set_eio_mapping (s_mapping, & - a = endpoint_mapping_slope, eps = power_mapping_eps, & - m = prop%mass / sqrts) - end select - else if (endpoint_mapping) then - select type (prop) - type is (resonance_t) - call sf_channel(i)%set_epr_mapping (s_mapping, & - a = endpoint_mapping_slope, & - m = prop%mass / sqrts, w = prop%width / sqrts) - type is (on_shell_t) - call sf_channel(i)%set_epo_mapping (s_mapping, & - a = endpoint_mapping_slope, & - m = prop%mass / sqrts) - end select - else if (power_mapping) then - select type (prop) - type is (resonance_t) - call sf_channel(i)%set_ipr_mapping (s_mapping, & - eps = power_mapping_eps, & - m = prop%mass / sqrts, w = prop%width / sqrts) - type is (on_shell_t) - call sf_channel(i)%set_ipo_mapping (s_mapping, & - eps = power_mapping_eps, & - m = prop%mass / sqrts) - end select - else if (allocated (s_mapping)) then - select type (prop) - type is (resonance_t) - call sf_channel(i)%set_res_mapping (s_mapping, & - m = prop%mass / sqrts, w = prop%width / sqrts, & - single = single_parameter) - type is (on_shell_t) - call sf_channel(i)%set_os_mapping (s_mapping, & - m = prop%mass / sqrts, & - single = single_parameter) - end select - else if (allocated (single_mapping)) then - select type (prop) - type is (resonance_t) - call sf_channel(i)%set_res_mapping (single_mapping, & - m = prop%mass / sqrts, w = prop%width / sqrts, & - single = single_parameter) - type is (on_shell_t) - call sf_channel(i)%set_os_mapping (single_mapping, & - m = prop%mass / sqrts, & - single = single_parameter) - end select - end if - else if (endpoint_mapping .and. power_mapping) then - call sf_channel(i)%set_ei_mapping (s_mapping, & - a = endpoint_mapping_slope, eps = power_mapping_eps) - else if (endpoint_mapping .and. .not. allocated (single_mapping)) then - call sf_channel(i)%set_ep_mapping (s_mapping, & - a = endpoint_mapping_slope) - else if (power_mapping .and. .not. allocated (single_mapping)) then - call sf_channel(i)%set_ip_mapping (s_mapping, & - eps = power_mapping_eps) - else if (s_mapping_enable .and. .not. allocated (single_mapping)) then - call sf_channel(i)%set_s_mapping (s_mapping, & - power = s_mapping_power) - end if - end do - else if (sf_allow_s_mapping) then - allocate (sf_channel (1)) - call sf_channel(1)%init (n_strfun) - if (allocated (single_mapping)) then - call sf_channel(1)%activate_mapping (single_mapping) - else if (endpoint_mapping .and. power_mapping) then - call sf_channel(i)%set_ei_mapping (s_mapping, & - a = endpoint_mapping_slope, eps = power_mapping_eps) - else if (endpoint_mapping) then - call sf_channel(1)%set_ep_mapping (s_mapping, & - a = endpoint_mapping_slope) - else if (power_mapping) then - call sf_channel(1)%set_ip_mapping (s_mapping, & - eps = power_mapping_eps) - else if (s_mapping_enable) then - call sf_channel(1)%set_s_mapping (s_mapping, & - power = s_mapping_power) - end if - else - allocate (sf_channel (1)) - call sf_channel(1)%init (n_strfun) - if (allocated (single_mapping)) then - call sf_channel(1)%activate_mapping (single_mapping) - end if - end if - end subroutine dispatch_sf_channels -@ %def dispatch_sf_channels -@ -@ -\subsection{Unit tests} -Test module, followed by the corresponding implementation module. -<<[[dispatch_phs_ut.f90]]>>= -<> + write (u, "(A)") "* Remove previous phs file, if any" + write (u, "(A)") -module dispatch_phs_ut - use unit_tests - use dispatch_phs_uti + inquire (file = filename, exist = exist) + if (exist) then + u_phs = free_unit () + open (u_phs, file = filename, action = "write") + close (u_phs, status = "delete") + end if -<> + write (u, "(A)") "* Check phase-space file (should fail)" + write (u, "(A)") -<> + select type (phs_data) + type is (phs_wood_config_t) + call phs_data%read_phs_file (exist, found, match) + write (u, "(1x,A,L1)") "exist = ", exist + write (u, "(1x,A,L1)") "found = ", found + write (u, "(1x,A,L1)") "match = ", match + end select -contains + write (u, "(A)") + write (u, "(A)") "* Generate a phase-space file" + write (u, "(A)") -<> + call phs_data%configure (phs_par%sqrts) -end module dispatch_phs_ut -@ %def dispatch_phs_ut -@ -<<[[dispatch_phs_uti.f90]]>>= -<> + write (u, "(1x,A,A,A)") "MD5 sum (process) = '", & + phs_data%md5sum_process, "'" + write (u, "(1x,A,A,A)") "MD5 sum (model par) = '", & + phs_data%md5sum_model_par, "'" + write (u, "(1x,A,A,A)") "MD5 sum (phs config) = '", & + phs_data%md5sum_phs_config, "'" -module dispatch_phs_uti + write (u, "(A)") + write (u, "(A)") "* Check MD5 sum" + write (u, "(A)") -<> -<> - use variables - use io_units, only: free_unit - use os_interface, only: os_data_t - use process_constants - use model_data - use models - use phs_base - use phs_none - use phs_forests - use phs_wood - use mappings - use dispatch_phase_space + call phs_data%final () + deallocate (phs_data) + allocate (phs_wood_config_t :: phs_data) + call phs_data%init (process_data, model) + phs_par%sqrts = 1000 + select type (phs_data) + type is (phs_wood_config_t) + call phs_data%set_parameters (phs_par) + phs_data%sqrts = phs_par%sqrts + phs_data%par%sqrts = phs_par%sqrts + end select + call phs_data%compute_md5sum () -<> + write (u, "(1x,A,A,A)") "MD5 sum (process) = '", & + phs_data%md5sum_process, "'" + write (u, "(1x,A,A,A)") "MD5 sum (model par) = '", & + phs_data%md5sum_model_par, "'" + write (u, "(1x,A,A,A)") "MD5 sum (phs config) = '", & + phs_data%md5sum_phs_config, "'" -<> + select type (phs_data) + type is (phs_wood_config_t) + call phs_data%read_phs_file (exist, found, match) + write (u, "(1x,A,L1)") "exist = ", exist + write (u, "(1x,A,L1)") "found = ", found + write (u, "(1x,A,L1)") "match = ", match + end select -contains + write (u, "(A)") + write (u, "(A)") "* Modify sqrts and check MD5 sum" + write (u, "(A)") -<> + call phs_data%final () + deallocate (phs_data) + allocate (phs_wood_config_t :: phs_data) + call phs_data%init (process_data, model) + phs_par%sqrts = 500 + select type (phs_data) + type is (phs_wood_config_t) + call phs_data%set_parameters (phs_par) + phs_data%sqrts = phs_par%sqrts + phs_data%par%sqrts = phs_par%sqrts + end select + call phs_data%compute_md5sum () -end module dispatch_phs_uti -@ %def dispatch_phs_ut -@ API: driver for the unit tests below. -<>= - public ::dispatch_phs_test -<>= - subroutine dispatch_phs_test (u, results) - integer, intent(in) :: u - type(test_results_t), intent(inout) :: results - <> - end subroutine dispatch_phs_test + write (u, "(1x,A,A,A)") "MD5 sum (process) = '", & + phs_data%md5sum_process, "'" + write (u, "(1x,A,A,A)") "MD5 sum (model par) = '", & + phs_data%md5sum_model_par, "'" + write (u, "(1x,A,A,A)") "MD5 sum (phs config) = '", & + phs_data%md5sum_phs_config, "'" -@ %def dispatch_phs_test -@ -\subsubsection{Select type: phase-space configuration object} -<>= - call test (dispatch_phs_1, "dispatch_phs_1", & - "phase-space configuration", & - u, results) -<>= - public :: dispatch_phs_1 -<>= - subroutine dispatch_phs_1 (u) - integer, intent(in) :: u - type(var_list_t) :: var_list - class(phs_config_t), allocatable :: phs - type(phs_parameters_t) :: phs_par - type(os_data_t) :: os_data - type(mapping_defaults_t) :: mapping_defs + select type (phs_data) + type is (phs_wood_config_t) + call phs_data%read_phs_file (exist, found, match) + write (u, "(1x,A,L1)") "exist = ", exist + write (u, "(1x,A,L1)") "found = ", found + write (u, "(1x,A,L1)") "match = ", match + end select - write (u, "(A)") "* Test output: dispatch_phs_1" - write (u, "(A)") "* Purpose: select phase-space configuration method" write (u, "(A)") - - call var_list%init_defaults (0) - - write (u, "(A)") "* Allocate PHS as phs_none_t" + write (u, "(A)") "* Modify process and check MD5 sum" write (u, "(A)") - call var_list%set_string (& - var_str ("$phs_method"), & - var_str ("none"), is_known = .true.) - call dispatch_phs (phs, var_list, os_data, var_str ("dispatch_phs_1")) - call phs%write (u) + call phs_data%final () + deallocate (phs_data) + process_data%md5sum = "77777777777777777777777777777777" + allocate (phs_wood_config_t :: phs_data) + call phs_data%init (process_data, model) + phs_par%sqrts = 1000 + select type (phs_data) + type is (phs_wood_config_t) + call phs_data%set_parameters (phs_par) + phs_data%sqrts = phs_par%sqrts + phs_data%par%sqrts = phs_par%sqrts + end select + call phs_data%compute_md5sum () - call phs%final () - deallocate (phs) + write (u, "(1x,A,A,A)") "MD5 sum (process) = '", & + phs_data%md5sum_process, "'" + write (u, "(1x,A,A,A)") "MD5 sum (model par) = '", & + phs_data%md5sum_model_par, "'" + write (u, "(1x,A,A,A)") "MD5 sum (phs config) = '", & + phs_data%md5sum_phs_config, "'" + + select type (phs_data) + type is (phs_wood_config_t) + call phs_data%read_phs_file (exist, found, match) + write (u, "(1x,A,L1)") "exist = ", exist + write (u, "(1x,A,L1)") "found = ", found + write (u, "(1x,A,L1)") "match = ", match + end select write (u, "(A)") - write (u, "(A)") "* Allocate PHS as phs_single_t" + write (u, "(A)") "* Modify phs parameter and check MD5 sum" write (u, "(A)") - call var_list%set_string (& - var_str ("$phs_method"), & - var_str ("single"), is_known = .true.) - call dispatch_phs (phs, var_list, os_data, var_str ("dispatch_phs_1")) - call phs%write (u) + call phs_data%final () + deallocate (phs_data) + allocate (phs_wood_config_t :: phs_data) + process_data%md5sum = "1234567890abcdef1234567890abcdef" + call phs_data%init (process_data, model) + phs_par%sqrts = 1000 + phs_par%off_shell = 17 + select type (phs_data) + type is (phs_wood_config_t) + call phs_data%set_parameters (phs_par) + phs_data%sqrts = phs_par%sqrts + phs_data%par%sqrts = phs_par%sqrts + end select + call phs_data%compute_md5sum () - call phs%final () - deallocate (phs) + write (u, "(1x,A,A,A)") "MD5 sum (process) = '", & + phs_data%md5sum_process, "'" + write (u, "(1x,A,A,A)") "MD5 sum (model par) = '", & + phs_data%md5sum_model_par, "'" + write (u, "(1x,A,A,A)") "MD5 sum (phs config) = '", & + phs_data%md5sum_phs_config, "'" + + select type (phs_data) + type is (phs_wood_config_t) + call phs_data%read_phs_file (exist, found, match) + write (u, "(1x,A,L1)") "exist = ", exist + write (u, "(1x,A,L1)") "found = ", found + write (u, "(1x,A,L1)") "match = ", match + end select write (u, "(A)") - write (u, "(A)") "* Allocate PHS as phs_wood_t" + write (u, "(A)") "* Modify model parameter and check MD5 sum" write (u, "(A)") - call var_list%set_string (& - var_str ("$phs_method"), & - var_str ("wood"), is_known = .true.) - call dispatch_phs (phs, var_list, os_data, var_str ("dispatch_phs_1")) - call phs%write (u) - - call phs%final () - deallocate (phs) + call phs_data%final () + deallocate (phs_data) + allocate (phs_wood_config_t :: phs_data) + call model%set_par (var_str ("ms"), 100._default) + call phs_data%init (process_data, model) + phs_par%sqrts = 1000 + phs_par%off_shell = 1 + select type (phs_data) + type is (phs_wood_config_t) + call phs_data%set_parameters (phs_par) + phs_data%sqrts = phs_par%sqrts + phs_data%par%sqrts = phs_par%sqrts + end select + call phs_data%compute_md5sum () - write (u, "(A)") - write (u, "(A)") "* Setting parameters for phs_wood_t" - write (u, "(A)") + write (u, "(1x,A,A,A)") "MD5 sum (process) = '", & + phs_data%md5sum_process, "'" + write (u, "(1x,A,A,A)") "MD5 sum (model par) = '", & + phs_data%md5sum_model_par, "'" + write (u, "(1x,A,A,A)") "MD5 sum (phs config) = '", & + phs_data%md5sum_phs_config, "'" - phs_par%m_threshold_s = 123 - phs_par%m_threshold_t = 456 - phs_par%t_channel = 42 - phs_par%off_shell = 17 - phs_par%keep_nonresonant = .false. - mapping_defs%energy_scale = 987 - mapping_defs%invariant_mass_scale = 654 - mapping_defs%momentum_transfer_scale = 321 - mapping_defs%step_mapping = .false. - mapping_defs%step_mapping_exp = .false. - mapping_defs%enable_s_mapping = .true. - call dispatch_phs (phs, var_list, os_data, var_str ("dispatch_phs_1"), & - mapping_defs, phs_par) - call phs%write (u) + select type (phs_data) + type is (phs_wood_config_t) + call phs_data%read_phs_file (exist, found, match) + write (u, "(1x,A,L1)") "exist = ", exist + write (u, "(1x,A,L1)") "found = ", found + write (u, "(1x,A,L1)") "match = ", match + end select - call phs%final () + write (u, "(A)") + write (u, "(A)") "* Cleanup" - call var_list%final () + call phs_data%final () + call model%final () write (u, "(A)") - write (u, "(A)") "* Test output end: dispatch_phs_1" + write (u, "(A)") "* Test output end: phs_wood_6" - end subroutine dispatch_phs_1 + end subroutine phs_wood_6 -@ %def dispatch_phs_1 +@ %def phs_wood_6 @ -\subsubsection{Phase-space configuration with file} -<>= - call test (dispatch_phs_2, "dispatch_phs_2", & - "configure phase space using file", & +<>= + call test (phs_wood_vis_1, "phs_wood_vis_1", & + "visualizing phase space channels", & u, results) -<>= - public :: dispatch_phs_2 -<>= - subroutine dispatch_phs_2 (u) - use phs_base_ut, only: init_test_process_data - use phs_wood_ut, only: write_test_phs_file - use phs_forests +<>= + public :: phs_wood_vis_1 +<>= + subroutine phs_wood_vis_1 (u) integer, intent(in) :: u - type(var_list_t) :: var_list type(os_data_t) :: os_data + type(model_data_t), target :: model type(process_constants_t) :: process_data - type(model_list_t) :: model_list - type(model_t), pointer :: model - class(phs_config_t), allocatable :: phs - integer :: u_phs - - write (u, "(A)") "* Test output: dispatch_phs_2" - write (u, "(A)") "* Purpose: select 'wood' phase-space & - &for a test process" - write (u, "(A)") "* and read phs configuration from file" - write (u, "(A)") + class(phs_config_t), allocatable :: phs_data + type(mapping_defaults_t) :: mapping_defaults + type(string_t) :: vis_file, pdf_file, ps_file + real(default) :: sqrts + logical :: exist, exist_pdf, exist_ps + integer :: u_phs, iostat, u_vis + character(95) :: buffer - write (u, "(A)") "* Initialize a process" + write (u, "(A)") "* Test output: phs_wood_vis_1" + write (u, "(A)") "* Purpose: visualizing the & + &phase-space configuration" write (u, "(A)") - call var_list%init_defaults (0) call os_data%init () - call syntax_model_file_init () - call model_list%read_model & - (var_str ("Test"), var_str ("Test.mdl"), os_data, model) + call model%init_test () call syntax_phs_forest_init () - call init_test_process_data (var_str ("dispatch_phs_2"), process_data) + write (u, "(A)") "* Initialize a process" + write (u, "(A)") - write (u, "(A)") "* Write phase-space file" + call init_test_process_data (var_str ("phs_wood_vis_1"), process_data) + + write (u, "(A)") "* Create a scratch phase-space file" + write (u, "(A)") u_phs = free_unit () - open (u_phs, file = "dispatch_phs_2.phs", action = "write", status = "replace") - call write_test_phs_file (u_phs, var_str ("dispatch_phs_2")) - close (u_phs) + open (u_phs, status = "scratch", action = "readwrite") + call write_test_phs_file (u_phs, var_str ("phs_wood_vis_1")) + rewind (u_phs) + do + read (u_phs, "(A)", iostat = iostat) buffer + if (iostat /= 0) exit + write (u, "(A)") trim (buffer) + end do write (u, "(A)") - write (u, "(A)") "* Allocate PHS as phs_wood_t" + write (u, "(A)") "* Setup phase-space configuration object" write (u, "(A)") - call var_list%set_string (& - var_str ("$phs_method"), & - var_str ("wood"), is_known = .true.) - call var_list%set_string (& - var_str ("$phs_file"), & - var_str ("dispatch_phs_2.phs"), is_known = .true.) - call dispatch_phs (phs, var_list, os_data, var_str ("dispatch_phs_2")) + mapping_defaults%step_mapping = .false. - call phs%init (process_data, model) - call phs%configure (sqrts = 1000._default) + allocate (phs_wood_config_t :: phs_data) + call phs_data%init (process_data, model) + select type (phs_data) + type is (phs_wood_config_t) + call phs_data%set_input (u_phs) + call phs_data%set_mapping_defaults (mapping_defaults) + phs_data%os_data = os_data + phs_data%io_unit = 0 + phs_data%io_unit_keep_open = .true. + phs_data%vis_channels = .true. + end select - call phs%write (u) + sqrts = 1000._default + call phs_data%configure (sqrts) + + call phs_data%write (u) write (u, "(A)") - select type (phs) + + select type (phs_data) type is (phs_wood_config_t) - call phs%write_forest (u) + call phs_data%write_forest (u) end select - call phs%final () + vis_file = "phs_wood_vis_1.phs-vis.tex" + ps_file = "phs_wood_vis_1.phs-vis.ps" + pdf_file = "phs_wood_vis_1.phs-vis.pdf" + inquire (file = char (vis_file), exist = exist) + if (exist) then + u_vis = free_unit () + open (u_vis, file = char (vis_file), action = "read", status = "old") + iostat = 0 + do while (iostat == 0) + read (u_vis, "(A)", iostat = iostat) buffer + if (iostat == 0) write (u, "(A)") trim (buffer) + end do + close (u_vis) + else + write (u, "(A)") "[Visualize LaTeX file is missing]" + end if + inquire (file = char (ps_file), exist = exist_ps) + if (exist_ps) then + write (u, "(A)") "[Visualize Postscript file exists and is nonempty]" + else + write (u, "(A)") "[Visualize Postscript file is missing/non-regular]" + end if + inquire (file = char (pdf_file), exist = exist_pdf) + if (exist_pdf) then + write (u, "(A)") "[Visualize PDF file exists and is nonempty]" + else + write (u, "(A)") "[Visualize PDF file is missing/non-regular]" + end if - call var_list%final () - call syntax_model_file_final () + write (u, "(A)") + write (u, "(A)") "* Cleanup" + + close (u_phs) + call phs_data%final () + call model%final () write (u, "(A)") - write (u, "(A)") "* Test output end: dispatch_phs_2" + write (u, "(A)") "* Test output end: phs_wood_vis_1" - end subroutine dispatch_phs_2 + end subroutine phs_wood_vis_1 -@ %def dispatch_phs_2 -@%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{A lexer for O'Mega's phase-space output} -This module provides three data types. One of them is the type -[[dag_string_t]] which should contain the information of all Feynman -diagrams in the factorized form which is provided by O'Mega in its -phase-space outout. This output is translated into a string of tokens (in -the form of an a array of the type [[dag_token_t]]) which have a certain -meaning. The purpose of this module is only to identify these tokens -correctly and to provide some procedures and interfaces which allow us to -use these strings in a similar way as variables of the basic character -type or the type [[iso_varying_string]]. Both [[character]] and -[[iso_varying_string]] have some disadvantages at least if one wants to -keep support for some older compiler versions. These can be circumvented -by the [[dag_string_t]] type. Finally the [[dag_chain_t]] type is used -to create a larger string in several steps without always recreating the -string, which is done in the form of a simple linked list. In the end -one can create a single [[dag_string]] out of this list, which is more -useful. -<<[[cascades2_lexer.f90]]>>= +@ %def phs_wood_vis_1 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{The FKS phase space} +<<[[phs_fks.f90]]>>= <> -module cascades2_lexer +module phs_fks <> - use kinds, only: TC, i8 +<> + use constants + use lorentz + use phs_points + use models, only: model_t + use phs_base + use resonances, only: resonance_contributors_t, resonance_history_t + use phs_wood <> -<> +<> -<> +<> -<> +<> -<> + interface +<> + end interface contains -<> +<> -end module cascades2_lexer +end module phs_fks -@ %def cascades2_lexer -@ This is the token type. By default the variable [[type]] is [[EMPTY_TK]] -but can obtain other values corresponding to the parameters defined below. -The type of the token corresponds to a particular sequence of characters. -When the token corresponds to a node of a tree, i.e. some particle in the -Feynman diagram, the type is [[NODE_TK]] and the [[particle_name]] variable -is holding the name of the particle. O'Megas output contains in -addition to the particle name some numbers which indicate the external -momenta that are flowing through this line. These numbers are translated -into a binary code and saved in the variable [[bincode]]. In this case -the number 1 corresponds to a bit set at position 0, 2 corresponds to a -bit set at position 1, etc. Instead of numbers which are composed out of -several digits, letters are used, i.e. A instead of 10 (bit at position 9), -B instead of 11 (bit at position 10), etc.\\ -When the DAG is reconstructed from a [[dag_string]] which was built from -O'Mega's output, this string is modified such that a substring (a set of -tokens) is replaced by a single token where the type variable is one of -the three parameters [[DAG_NODE_TK]], [[DAG_OPTIONS_TK]] and -[[DAG_COMBINATION_TK]]. These parameters correspond to the three types -[[dag_node_t]], [[dag_options_t]] and [[dag_combination_t]] (see [[cascades2]] -for more information. In this case, since these objects are organized -in arrays, the [[index]] variable holds the corresponding position in -the array.\\ -In any case, we want to be able to reproduce the character string from -which a token (or a string) has been created. The variable [[char_len]] -is the length of this string. For tokens with the type [[DAG_NODE_TK]], -[[DAG_OPTIONS_TK]] and [[DAG_COMBINATION_TK]] we use output of the form -[[]], [[]] or [[]] which is useful for debugging the parser. -Here 23 is the [[index]] and [[N]], [[O]] or [[C]] obviously corresponds -to the [[type]]. -<>= - integer, parameter :: PRT_NAME_LEN = 20 -@ %def PRT_NAME_LEN -<>= - public :: dag_token_t -<>= - type :: dag_token_t - integer :: type = EMPTY_TK - integer :: char_len = 0 - integer(TC) :: bincode = 0 - character (PRT_NAME_LEN) :: particle_name="" - integer :: index = 0 - contains - <> - end type dag_token_t +@ %def phs_fks +@ +<<[[phs_fks_sub.f90]]>>= +<> -@ %def dag_token_t -@ This is the string type. It also holds the number of characters in the -corresponding character string. It contains an array of tokens. If the -[[dag_string]] is constructed using the type [[dag_chain_t]], which creates -a linked list, we also need the pointer [[next]]. -<>= - public :: dag_string_t -<>= - type :: dag_string_t - integer :: char_len = 0 - type (dag_token_t), dimension(:), allocatable :: t - type (dag_string_t), pointer :: next => null () - contains - <> - end type dag_string_t +submodule (phs_fks) phs_fks_s -@ %def dag_string_t -@ This is the chain of [[dag_strings]]. It allows us to construct a large -string by appending new strings to the linked list, which can later be -merged to a single string. This is very useful because the file written -by O'Mega contains large strings where each string contains all Feynman -diagrams in a factorized form, but these large strings are cut into -several pieces and distributed over many lines. As the file can become -large, rewriting a new [[dag_string]] (or [[iso_varying_string]]) would -consume more and more time with each additional line. For recreating a -single [[dag_string]] out of this chain, we need the total character -length and the sum of all sizes of the [[dag_token]] arrays [[t]]. -<>= - public :: dag_chain_t -<>= - type :: dag_chain_t - integer :: char_len = 0 - integer :: t_size = 0 - type (dag_string_t), pointer :: first => null () - type (dag_string_t), pointer :: last => null () - contains - <> - end type dag_chain_t +<> + use diagnostics + use io_units, only: given_output_unit, free_unit + use format_defs, only: FMT_17 + use format_utils, only: write_separator + use physics_defs + use flavors + use pdg_arrays, only: is_colored + use cascades + use cascades2 + use ttv_formfactors, only: generate_on_shell_decay_threshold, m1s_to_mpole -@ %def dag_chain_t -@ We define two parameters holding the characters corresponding to a -backslash and a blanc space. -<>= - character(len=1), parameter, public :: BACKSLASH_CHAR = "\\" - character(len=1), parameter :: BLANC_CHAR = " " -@ %def BACKSLASH_CHAR BLANC_CHAR -@ These are the parameters which correspond to meaningful types -of [[token]]. -<>= - integer, parameter, public :: NEW_LINE_TK = -2 - integer, parameter :: BLANC_SPACE_TK = -1 - integer, parameter :: EMPTY_TK = 0 - integer, parameter, public :: NODE_TK = 1 - integer, parameter, public :: DAG_NODE_TK = 2 - integer, parameter, public :: DAG_OPTIONS_TK = 3 - integer, parameter, public :: DAG_COMBINATION_TK = 4 - integer, parameter, public :: COLON_TK = 11 - integer, parameter, public :: COMMA_TK = 12 - integer, parameter, public :: VERTICAL_BAR_TK = 13 - integer, parameter, public :: OPEN_PAR_TK = 21 - integer, parameter, public :: CLOSED_PAR_TK = 22 - integer, parameter, public :: OPEN_CURLY_TK = 31 - integer, parameter, public :: CLOSED_CURLY_TK = 32 + implicit none -@ %def NEW_LINE_TK BLANC_SPACE_TK EMPTY_TK NODE_TK -@ %def COLON_TK COMMA_TK VERTICAL_LINE_TK OPEN_PAR_TK -@ %def CLOSED_PAR_TK OPEN_CURLY_TK CLOSED_CURLY_TK -@ Different sorts of assignment. This contains the conversion -of a [[character]] variable into a [[dag_token]] or [[dag_string]]. -<>= - public :: assignment (=) -<>= - interface assignment (=) - module procedure dag_token_assign_from_char_string - module procedure dag_token_assign_from_dag_token - module procedure dag_string_assign_from_dag_token - module procedure dag_string_assign_from_char_string - module procedure dag_string_assign_from_dag_string - module procedure dag_string_assign_from_dag_token_array - end interface assignment (=) +<> -@ %def interfaces -<>= - procedure :: init_dag_object_token => dag_token_init_dag_object_token -<>= - subroutine dag_token_init_dag_object_token (dag_token, type, index) - class (dag_token_t), intent (out) :: dag_token - integer, intent (in) :: index - integer :: type - dag_token%type = type - dag_token%char_len = integer_n_dec_digits (index) + 3 - dag_token%index = index +contains + +<> + +end submodule phs_fks_s + +@ %def phs_fks_s +@ A container for the $x_\oplus$- and $x_\ominus$-values for initial-state +phase spaces. +<>= + public :: isr_kinematics_t +<>= + type :: isr_kinematics_t + integer :: n_in + real(default), dimension(2) :: x = one + real(default), dimension(2) :: z = zero + real(default) :: sqrts_born = zero + real(default), dimension(:), allocatable :: beam_energy + real(default) :: fac_scale = zero + real(default), dimension(2) :: jacobian = one + integer :: isr_mode = SQRTS_FIXED contains - function integer_n_dec_digits (number) result (n_digits) - integer, intent (in) :: number - integer :: n_digits - integer :: div_number - n_digits = 0 - div_number = number - do - div_number = div_number / 10 - n_digits = n_digits + 1 - if (div_number == 0) exit - enddo - end function integer_n_dec_digits - end subroutine dag_token_init_dag_object_token + <> + end type isr_kinematics_t -@ %def dag_token_init_dag_object_token -<>= - elemental subroutine dag_token_assign_from_char_string (dag_token, char_string) - type (dag_token_t), intent (out) :: dag_token - character (len=*), intent (in) :: char_string - integer :: i, j - logical :: set_bincode - integer :: bit_pos - character (len=10) :: index_char - dag_token%char_len = len (char_string) - if (dag_token%char_len == 1) then - select case (char_string(1:1)) - case (BACKSLASH_CHAR) - dag_token%type = NEW_LINE_TK - case (" ") - dag_token%type = BLANC_SPACE_TK - case (":") - dag_token%type = COLON_TK - case (",") - dag_token%type = COMMA_TK - case ("|") - dag_token%type = VERTICAL_BAR_TK - case ("(") - dag_token%type = OPEN_PAR_TK - case (")") - dag_token%type = CLOSED_PAR_TK - case ("{") - dag_token%type = OPEN_CURLY_TK - case ("}") - dag_token%type = CLOSED_CURLY_TK - end select - else if (char_string(1:1) == "<") then - select case (char_string(2:2)) - case ("N") - dag_token%type = DAG_NODE_TK - case ("O") - dag_token%type = DAG_OPTIONS_TK - case ("C") - dag_token%type = DAG_COMBINATION_TK - end select - read(char_string(3:dag_token%char_len-1), fmt="(I10)") dag_token%index - else - dag_token%bincode = 0 - set_bincode = .false. - do i=1, dag_token%char_len - select case (char_string(i:i)) - case ("[") - dag_token%type = NODE_TK - if (i > 1) then - do j = 1, i - 1 - dag_token%particle_name(j:j) = char_string(j:j) - enddo - end if - set_bincode = .true. - case ("]") - set_bincode = .false. - case default - dag_token%type = NODE_TK - if (set_bincode) then - select case (char_string(i:i)) - case ("1", "2", "3", "4", "5", "6", "7", "8", "9") - read (char_string(i:i), fmt="(I1)") bit_pos - case ("A") - bit_pos = 10 - case ("B") - bit_pos = 11 - case ("C") - bit_pos = 12 - end select - dag_token%bincode = ibset(dag_token%bincode, bit_pos - 1) - end if - end select - if (dag_token%type /= NODE_TK) exit - enddo +@ %def type isr_kinematics_t +@ +<>= + procedure :: write => isr_kinematics_write +<>= + module subroutine isr_kinematics_write (isr, unit) + class(isr_kinematics_t), intent(in) :: isr + integer, intent(in), optional :: unit + end subroutine isr_kinematics_write +<>= + module subroutine isr_kinematics_write (isr, unit) + class(isr_kinematics_t), intent(in) :: isr + integer, intent(in), optional :: unit + integer :: u, i + u = given_output_unit (unit); if (u < 0) return + write (u,"(A)") "ISR kinematics: " + write (u,"(A," // FMT_17 // ",1X)") "x(+): ", isr%x(1) + write (u,"(A," // FMT_17 // ",1X)") "x(-): ", isr%x(2) + write (u,"(A," // FMT_17 // ",1X)") "z(+): ", isr%z(1) + write (u,"(A," // FMT_17 // ",1X)") "z(-): ", isr%z(2) + write (u,"(A," // FMT_17 // ",1X)") "sqrts (Born): ", isr%sqrts_born + if (allocated (isr%beam_energy)) then + do i = 1, size (isr%beam_energy) + write (u,"(A," // FMT_17 // ",1X)") "Beam energy: ", & + isr%beam_energy(i) + end do end if - end subroutine dag_token_assign_from_char_string - -@ %def dag_token_assign_from_char_string -<>= - elemental subroutine dag_token_assign_from_dag_token (token_out, token_in) - type (dag_token_t), intent (out) :: token_out - type (dag_token_t), intent (in) :: token_in - token_out%type = token_in%type - token_out%char_len = token_in%char_len - token_out%bincode = token_in%bincode - token_out%particle_name = token_in%particle_name - token_out%index = token_in%index - end subroutine dag_token_assign_from_dag_token + write (u,"(A," // FMT_17 // ",1X)") "Fac. scale: ", isr%fac_scale + do i = 1, 2 + write (u,"(A," // FMT_17 // ",1X)") "Jacobian: ", isr%jacobian(i) + end do + write (u,"(A,I0,1X)") "ISR mode: ", isr%isr_mode + end subroutine isr_kinematics_write -@ %def dag_token_assign_from_dag_token -<>= - elemental subroutine dag_string_assign_from_dag_token (dag_string, dag_token) - type (dag_string_t), intent (out) :: dag_string - type (dag_token_t), intent (in) :: dag_token - allocate (dag_string%t(1)) - dag_string%t(1) = dag_token - dag_string%char_len = dag_token%char_len - end subroutine dag_string_assign_from_dag_token +@ %def isr_kinematics_write +@ +<>= + public :: phs_point_set_t +<>= + type :: phs_point_set_t + type(phs_point_t), dimension(:), allocatable :: phs_point + logical :: initialized = .false. + contains + <> + end type phs_point_set_t -@ %def dag_string_assign_from_dag_token -<>= - subroutine dag_string_assign_from_dag_token_array (dag_string, dag_token) - type (dag_string_t), intent (out) :: dag_string - type (dag_token_t), dimension(:), intent (in) :: dag_token - allocate (dag_string%t(size(dag_token))) - dag_string%t = dag_token - dag_string%char_len = sum(dag_token%char_len) - end subroutine dag_string_assign_from_dag_token_array +@ %def phs_point_set_t +@ +<>= + procedure :: init => phs_point_set_init +<>= + module subroutine phs_point_set_init (phs_point_set, n_particles, n_phs) + class(phs_point_set_t), intent(out) :: phs_point_set + integer, intent(in) :: n_particles, n_phs + end subroutine phs_point_set_init +<>= + module subroutine phs_point_set_init (phs_point_set, n_particles, n_phs) + class(phs_point_set_t), intent(out) :: phs_point_set + integer, intent(in) :: n_particles, n_phs + integer :: i_phs + allocate (phs_point_set%phs_point (n_phs)) + do i_phs = 1, n_phs + phs_point_set%phs_point(i_phs) = n_particles + end do + phs_point_set%initialized = .true. + end subroutine phs_point_set_init -@ %def dag_string_assign_from_dag_token_array -<>= - elemental subroutine dag_string_assign_from_char_string (dag_string, char_string) - type (dag_string_t), intent (out) :: dag_string - character (len=*), intent (in) :: char_string - type (dag_token_t), dimension(:), allocatable :: token - integer :: token_pos - integer :: i - character (len=len(char_string)) :: node_char - integer :: node_char_len - node_char = "" - dag_string%char_len = len (char_string) - if (dag_string%char_len > 0) then - allocate (token(dag_string%char_len)) - token_pos = 0 - node_char_len = 0 - do i=1, dag_string%char_len - select case (char_string(i:i)) - case (BACKSLASH_CHAR, " ", ":", ",", "|", "(", ")", "{", "}") - if (node_char_len > 0) then - token_pos = token_pos + 1 - token(token_pos) = node_char(:node_char_len) - node_char_len = 0 - end if - token_pos = token_pos + 1 - token(token_pos) = char_string(i:i) - case default - node_char_len = node_char_len + 1 - node_char(node_char_len:node_char_len) = char_string(i:i) - end select - enddo - if (node_char_len > 0) then - token_pos = token_pos + 1 - token(token_pos) = node_char(:node_char_len) - end if - if (token_pos > 0) then - allocate (dag_string%t(token_pos)) - dag_string%t = token(:token_pos) - deallocate (token) - end if +@ %def phs_point_set_init +@ +<>= + procedure :: write => phs_point_set_write +<>= + module subroutine phs_point_set_write (phs_point_set, i_phs, contributors, & + unit, show_mass, testflag, check_conservation, ultra, n_in) + class(phs_point_set_t), intent(in) :: phs_point_set + integer, intent(in), optional :: i_phs + integer, intent(in), dimension(:), optional :: contributors + integer, intent(in), optional :: unit + logical, intent(in), optional :: show_mass + logical, intent(in), optional :: testflag, ultra + logical, intent(in), optional :: check_conservation + integer, intent(in), optional :: n_in + end subroutine phs_point_set_write +<>= + module subroutine phs_point_set_write (phs_point_set, i_phs, contributors, & + unit, show_mass, testflag, check_conservation, ultra, n_in) + class(phs_point_set_t), intent(in) :: phs_point_set + integer, intent(in), optional :: i_phs + integer, intent(in), dimension(:), optional :: contributors + integer, intent(in), optional :: unit + logical, intent(in), optional :: show_mass + logical, intent(in), optional :: testflag, ultra + logical, intent(in), optional :: check_conservation + integer, intent(in), optional :: n_in + integer :: i, u + type(vector4_t) :: p_sum + u = given_output_unit (unit); if (u < 0) return + if (present (i_phs)) then + call phs_point_set%phs_point(i_phs)%write & + (unit = u, show_mass = show_mass, testflag = testflag, & + check_conservation = check_conservation, ultra = ultra, n_in = n_in) + else + do i = 1, size(phs_point_set%phs_point) + call phs_point_set%phs_point(i)%write & + (unit = u, show_mass = show_mass, testflag = testflag, & + check_conservation = check_conservation, ultra = ultra,& + n_in = n_in) + end do end if - end subroutine dag_string_assign_from_char_string - -@ %def dag_string_assign_from_char_string -<>= - elemental subroutine dag_string_assign_from_dag_string (string_out, string_in) - type (dag_string_t), intent (out) :: string_out - type (dag_string_t), intent (in) :: string_in - if (allocated (string_in%t)) then - allocate (string_out%t (size(string_in%t))) - string_out%t = string_in%t + if (present (contributors)) then + if (debug_on) call msg_debug & + (D_SUBTRACTION, "Invariant masses for real emission: ") + associate (pp => phs_point_set%phs_point(i_phs)) + p_sum = sum (pp, [contributors, size (pp)]) + end associate + if (debug_active (D_SUBTRACTION)) & + call vector4_write (p_sum, unit = unit, show_mass = show_mass, & + testflag = testflag, ultra = ultra) end if - string_out%char_len = string_in%char_len - end subroutine dag_string_assign_from_dag_string + end subroutine phs_point_set_write -@ %def dag_string_assign_from_dag_string -@ Concatenate strings/tokens. The result is always a [[dag_string]]. -<>= - public :: operator (//) -<>= - interface operator (//) - module procedure concat_dag_token_dag_token - module procedure concat_dag_string_dag_token - module procedure concat_dag_token_dag_string - module procedure concat_dag_string_dag_string - end interface operator (//) +@ %def phs_point_set_write +@ +<>= + procedure :: get_n_momenta => phs_point_set_get_n_momenta +<>= + elemental module function phs_point_set_get_n_momenta & + (phs_point_set, i_res) result (n) + integer :: n + class(phs_point_set_t), intent(in) :: phs_point_set + integer, intent(in) :: i_res + end function phs_point_set_get_n_momenta +<>= + elemental module function phs_point_set_get_n_momenta & + (phs_point_set, i_res) result (n) + integer :: n + class(phs_point_set_t), intent(in) :: phs_point_set + integer, intent(in) :: i_res + n = size (phs_point_set%phs_point(i_res)) + end function phs_point_set_get_n_momenta -@ %def interfaces -<>= - function concat_dag_token_dag_token (token1, token2) result (res_string) - type (dag_token_t), intent (in) :: token1, token2 - type (dag_string_t) :: res_string - if (token1%type == EMPTY_TK) then - res_string = token2 - else if (token2%type == EMPTY_TK) then - res_string = token1 +@ %def phs_point_set_get_n_momenta +@ +<>= + procedure :: get_momenta => phs_point_set_get_momenta +<>= + pure module function phs_point_set_get_momenta & + (phs_point_set, i_phs, n_in) result (p) + type(vector4_t), dimension(:), allocatable :: p + class(phs_point_set_t), intent(in) :: phs_point_set + integer, intent(in) :: i_phs + integer, intent(in), optional :: n_in + end function phs_point_set_get_momenta +<>= + pure module function phs_point_set_get_momenta & + (phs_point_set, i_phs, n_in) result (p) + type(vector4_t), dimension(:), allocatable :: p + class(phs_point_set_t), intent(in) :: phs_point_set + integer, intent(in) :: i_phs + integer, intent(in), optional :: n_in + integer :: i + if (present (n_in)) then + p = phs_point_set%phs_point(i_phs)%select ([(i, i=1, n_in)]) else - allocate (res_string%t(2)) - res_string%t(1) = token1 - res_string%t(2) = token2 - res_string%char_len = token1%char_len + token2%char_len + p = phs_point_set%phs_point(i_phs) end if - end function concat_dag_token_dag_token + end function phs_point_set_get_momenta -@ %def concat_dag_token_dag_token -<>= - function concat_dag_string_dag_token (dag_string, dag_token) result (res_string) - type (dag_string_t), intent (in) :: dag_string - type (dag_token_t), intent (in) :: dag_token - type (dag_string_t) :: res_string - integer :: t_size - if (dag_string%char_len == 0) then - res_string = dag_token - else if (dag_token%type == EMPTY_TK) then - res_string = dag_string +@ %def phs_point_set_get_momenta +@ +<>= + procedure :: get_momentum => phs_point_set_get_momentum +<>= + pure module function phs_point_set_get_momentum & + (phs_point_set, i_phs, i_mom) result (p) + type(vector4_t) :: p + class(phs_point_set_t), intent(in) :: phs_point_set + integer, intent(in) :: i_phs, i_mom + end function phs_point_set_get_momentum +<>= + pure module function phs_point_set_get_momentum & + (phs_point_set, i_phs, i_mom) result (p) + type(vector4_t) :: p + class(phs_point_set_t), intent(in) :: phs_point_set + integer, intent(in) :: i_phs, i_mom + p = phs_point_set%phs_point(i_phs)%select (i_mom) + end function phs_point_set_get_momentum + +@ %def phs_point_set_get_momentum +@ +<>= + procedure :: get_energy => phs_point_set_get_energy +<>= + pure module function phs_point_set_get_energy & + (phs_point_set, i_phs, i_mom) result (E) + real(default) :: E + class(phs_point_set_t), intent(in) :: phs_point_set + integer, intent(in) :: i_phs, i_mom + end function phs_point_set_get_energy +<>= + pure module function phs_point_set_get_energy & + (phs_point_set, i_phs, i_mom) result (E) + real(default) :: E + class(phs_point_set_t), intent(in) :: phs_point_set + integer, intent(in) :: i_phs, i_mom + E = energy (phs_point_set%phs_point(i_phs)%select (i_mom)) + end function phs_point_set_get_energy + +@ %def phs_point_set_get_energy +@ +<>= + procedure :: get_sqrts => phs_point_set_get_sqrts +<>= + module function phs_point_set_get_sqrts & + (phs_point_set, i_phs) result (sqrts) + real(default) :: sqrts + class(phs_point_set_t), intent(in) :: phs_point_set + integer, intent(in) :: i_phs + end function phs_point_set_get_sqrts +<>= + module function phs_point_set_get_sqrts & + (phs_point_set, i_phs) result (sqrts) + real(default) :: sqrts + class(phs_point_set_t), intent(in) :: phs_point_set + integer, intent(in) :: i_phs + sqrts = sqrt (phs_point_set%phs_point(i_phs)%get_msq ([1,2])) + end function phs_point_set_get_sqrts + +@ %def phs_point_set_get_sqrts +@ +<>= + generic :: set_momenta => set_momenta_p, set_momenta_phs_point + procedure :: set_momenta_p => phs_point_set_set_momenta_p +<>= + module subroutine phs_point_set_set_momenta_p (phs_point_set, i_phs, p) + class(phs_point_set_t), intent(inout) :: phs_point_set + integer, intent(in) :: i_phs + type(vector4_t), intent(in), dimension(:) :: p + end subroutine phs_point_set_set_momenta_p +<>= + module subroutine phs_point_set_set_momenta_p (phs_point_set, i_phs, p) + class(phs_point_set_t), intent(inout) :: phs_point_set + integer, intent(in) :: i_phs + type(vector4_t), intent(in), dimension(:) :: p + phs_point_set%phs_point(i_phs) = p + end subroutine phs_point_set_set_momenta_p + +@ %def phs_point_set_set_momenta_p +@ +<>= + procedure :: set_momenta_phs_point => phs_point_set_set_momenta_phs_point +<>= + module subroutine phs_point_set_set_momenta_phs_point & + (phs_point_set, i_phs, p) + class(phs_point_set_t), intent(inout) :: phs_point_set + integer, intent(in) :: i_phs + type(phs_point_t), intent(in) :: p + end subroutine phs_point_set_set_momenta_phs_point +<>= + module subroutine phs_point_set_set_momenta_phs_point & + (phs_point_set, i_phs, p) + class(phs_point_set_t), intent(inout) :: phs_point_set + integer, intent(in) :: i_phs + type(phs_point_t), intent(in) :: p + phs_point_set%phs_point(i_phs) = p + end subroutine phs_point_set_set_momenta_phs_point + +@ %def phs_point_set_set_momenta_phs_point +@ +<>= + procedure :: get_n_particles => phs_point_set_get_n_particles +<>= + module function phs_point_set_get_n_particles & + (phs_point_set, i) result (n_particles) + integer :: n_particles + class(phs_point_set_t), intent(in) :: phs_point_set + integer, intent(in), optional :: i + end function phs_point_set_get_n_particles +<>= + module function phs_point_set_get_n_particles & + (phs_point_set, i) result (n_particles) + integer :: n_particles + class(phs_point_set_t), intent(in) :: phs_point_set + integer, intent(in), optional :: i + integer :: j + j = 1; if (present (i)) j = i + n_particles = size (phs_point_set%phs_point(j)) + end function phs_point_set_get_n_particles + +@ %def phs_point_set_get_n_particles +@ +<>= + procedure :: get_n_phs => phs_point_set_get_n_phs +<>= + module function phs_point_set_get_n_phs (phs_point_set) result (n_phs) + integer :: n_phs + class(phs_point_set_t), intent(in) :: phs_point_set + end function phs_point_set_get_n_phs +<>= + module function phs_point_set_get_n_phs (phs_point_set) result (n_phs) + integer :: n_phs + class(phs_point_set_t), intent(in) :: phs_point_set + n_phs = size (phs_point_set%phs_point) + end function phs_point_set_get_n_phs + +@ %def phs_point_set_get_n_phs +@ +<>= + procedure :: get_invariant_mass => phs_point_set_get_invariant_mass +<>= + module function phs_point_set_get_invariant_mass & + (phs_point_set, i_phs, i_part) result (m2) + real(default) :: m2 + class(phs_point_set_t), intent(in) :: phs_point_set + integer, intent(in) :: i_phs + integer, intent(in), dimension(:) :: i_part + end function phs_point_set_get_invariant_mass +<>= + module function phs_point_set_get_invariant_mass & + (phs_point_set, i_phs, i_part) result (m2) + real(default) :: m2 + class(phs_point_set_t), intent(in) :: phs_point_set + integer, intent(in) :: i_phs + integer, intent(in), dimension(:) :: i_part + m2 = phs_point_set%phs_point(i_phs)%get_msq (i_part) + end function phs_point_set_get_invariant_mass + +@ %def phs_point_set_get_invariant_mass +@ +<>= + procedure :: write_phs_point => phs_point_set_write_phs_point +<>= + module subroutine phs_point_set_write_phs_point (phs_point_set, i_phs, & + unit, show_mass, testflag, check_conservation, ultra, n_in) + class(phs_point_set_t), intent(in) :: phs_point_set + integer, intent(in) :: i_phs + integer, intent(in), optional :: unit + logical, intent(in), optional :: show_mass + logical, intent(in), optional :: testflag, ultra + logical, intent(in), optional :: check_conservation + integer, intent(in), optional :: n_in + end subroutine phs_point_set_write_phs_point +<>= + module subroutine phs_point_set_write_phs_point (phs_point_set, i_phs, & + unit, show_mass, testflag, check_conservation, ultra, n_in) + class(phs_point_set_t), intent(in) :: phs_point_set + integer, intent(in) :: i_phs + integer, intent(in), optional :: unit + logical, intent(in), optional :: show_mass + logical, intent(in), optional :: testflag, ultra + logical, intent(in), optional :: check_conservation + integer, intent(in), optional :: n_in + call phs_point_set%phs_point(i_phs)%write (unit, show_mass, testflag, & + check_conservation, ultra, n_in) + end subroutine phs_point_set_write_phs_point + +@ %def phs_point_set_write_phs_point +@ +<>= + procedure :: final => phs_point_set_final +<>= + module subroutine phs_point_set_final (phs_point_set) + class(phs_point_set_t), intent(inout) :: phs_point_set + end subroutine phs_point_set_final +<>= + module subroutine phs_point_set_final (phs_point_set) + class(phs_point_set_t), intent(inout) :: phs_point_set + integer :: i + deallocate (phs_point_set%phs_point) + phs_point_set%initialized = .false. + end subroutine phs_point_set_final + +@ %def phs_point_set_final +@ +<>= + public :: real_jacobian_t +<>= + type :: real_jacobian_t + real(default), dimension(4) :: jac = 1._default + end type real_jacobian_t + +@ %def real_jacobian_t +@ +<>= + public :: real_kinematics_t +<>= + type :: real_kinematics_t + logical :: supply_xi_max = .true. + real(default) :: xi_tilde + real(default) :: phi + real(default), dimension(:), allocatable :: xi_max, y + real(default) :: xi_mismatch, y_mismatch + type(real_jacobian_t), dimension(:), allocatable :: jac + real(default) :: jac_mismatch + type(phs_point_set_t) :: p_born_cms + type(phs_point_set_t) :: p_born_lab + type(phs_point_set_t) :: p_real_cms + type(phs_point_set_t) :: p_real_lab + type(phs_point_set_t) :: p_born_onshell + type(phs_point_set_t), dimension(2) :: p_real_onshell + integer, dimension(:), allocatable :: alr_to_i_phs + real(default), dimension(3) :: x_rad + real(default), dimension(:), allocatable :: jac_rand + real(default), dimension(:), allocatable :: y_soft + real(default) :: cms_energy2 + type(vector4_t), dimension(:), allocatable :: xi_ref_momenta + contains + <> + end type real_kinematics_t + +@ %def real_kinematics_t +@ +<>= + procedure :: init => real_kinematics_init +<>= + module subroutine real_kinematics_init (r, n_tot, n_phs, n_alr, n_contr) + class(real_kinematics_t), intent(inout) :: r + integer, intent(in) :: n_tot, n_phs, n_alr, n_contr + end subroutine real_kinematics_init +<>= + module subroutine real_kinematics_init (r, n_tot, n_phs, n_alr, n_contr) + class(real_kinematics_t), intent(inout) :: r + integer, intent(in) :: n_tot, n_phs, n_alr, n_contr + allocate (r%xi_max (n_phs)) + allocate (r%y (n_phs)) + allocate (r%y_soft (n_phs)) + call r%p_born_cms%init (n_tot - 1, 1) + call r%p_born_lab%init (n_tot - 1, 1) + call r%p_real_cms%init (n_tot, n_phs) + call r%p_real_lab%init (n_tot, n_phs) + allocate (r%jac (n_phs), r%jac_rand (n_phs)) + allocate (r%alr_to_i_phs (n_alr)) + allocate (r%xi_ref_momenta (n_contr)) + r%alr_to_i_phs = 0 + r%xi_tilde = zero; r%xi_mismatch = zero + r%xi_max = zero + r%y = zero; r%y_mismatch = zero + r%y_soft = zero + r%phi = zero + r%cms_energy2 = zero + r%xi_ref_momenta = vector4_null + r%jac_mismatch = one + r%jac_rand = one + end subroutine real_kinematics_init + +@ %def real_kinematics_init +@ +<>= + procedure :: init_onshell => real_kinematics_init_onshell +<>= + module subroutine real_kinematics_init_onshell (r, n_tot, n_phs) + class(real_kinematics_t), intent(inout) :: r + integer, intent(in) :: n_tot, n_phs + end subroutine real_kinematics_init_onshell +<>= + module subroutine real_kinematics_init_onshell (r, n_tot, n_phs) + class(real_kinematics_t), intent(inout) :: r + integer, intent(in) :: n_tot, n_phs + call r%p_born_onshell%init (n_tot - 1, 1) + call r%p_real_onshell(1)%init (n_tot, n_phs) + call r%p_real_onshell(2)%init (n_tot, n_phs) + end subroutine real_kinematics_init_onshell + +@ %def real_kinematics_init_onshell +@ +<>= + procedure :: write => real_kinematics_write +<>= + module subroutine real_kinematics_write (r, unit) + class(real_kinematics_t), intent(in) :: r + integer, intent(in), optional :: unit + end subroutine real_kinematics_write +<>= + module subroutine real_kinematics_write (r, unit) + class(real_kinematics_t), intent(in) :: r + integer, intent(in), optional :: unit + integer :: u, i + u = given_output_unit (unit); if (u < 0) return + write (u,"(A)") "Real kinematics: " + write (u,"(A," // FMT_17 // ",1X)") "xi_tilde: ", r%xi_tilde + write (u,"(A," // FMT_17 // ",1X)") "phi: ", r%phi + do i = 1, size (r%xi_max) + write (u,"(A,I1,1X)") "i_phs: ", i + write (u,"(A," // FMT_17 // ",1X)") "xi_max: ", r%xi_max(i) + write (u,"(A," // FMT_17 // ",1X)") "y: ", r%y(i) + write (u,"(A," // FMT_17 // ",1X)") "jac_rand: ", r%jac_rand(i) + write (u,"(A," // FMT_17 // ",1X)") "y_soft: ", r%y_soft(i) + end do + write (u, "(A)") "Born Momenta: " + write (u, "(A)") "CMS: " + call r%p_born_cms%write (unit = u) + write (u, "(A)") "Lab: " + call r%p_born_lab%write (unit = u) + write (u, "(A)") "Real Momenta: " + write (u, "(A)") "CMS: " + call r%p_real_cms%write (unit = u) + write (u, "(A)") "Lab: " + call r%p_real_lab%write (unit = u) + end subroutine real_kinematics_write + +@ %def real_kinematics_write +@ The boost to the center-of-mass system only has a reasonable meaning +above the threshold. Below the threshold, we do not apply boost at all, so +that the top quarks stay in the rest frame. However, with top quarks exactly +at rest, problems arise in the matrix elements (e.g. in the computation +of angles). Therefore, we apply a boost which is not exactly 1, but has a +tiny value differing from that. +<>= + public :: get_boost_for_threshold_projection +<>= + module function get_boost_for_threshold_projection & + (p, sqrts, mtop) result (L) + type(lorentz_transformation_t) :: L + type(vector4_t), intent(in), dimension(:) :: p + real(default), intent(in) :: sqrts, mtop + end function get_boost_for_threshold_projection +<>= + module function get_boost_for_threshold_projection & + (p, sqrts, mtop) result (L) + type(lorentz_transformation_t) :: L + type(vector4_t), intent(in), dimension(:) :: p + real(default), intent(in) :: sqrts, mtop + type(vector4_t) :: p_tmp + type(vector3_t) :: dir + real(default) :: scale_factor, arg + p_tmp = p(THR_POS_WP) + p(THR_POS_B) + arg = sqrts**2 - four * mtop**2 + if (arg > zero) then + scale_factor = sqrt (arg) / two else - t_size = size (dag_string%t) - allocate (res_string%t(t_size+1)) - res_string%t(:t_size) = dag_string%t - res_string%t(t_size+1) = dag_token - res_string%char_len = dag_string%char_len + dag_token%char_len + scale_factor = tiny_07*1000 end if - end function concat_dag_string_dag_token + dir = scale_factor * create_unit_vector (p_tmp) + p_tmp = [sqrts / two, dir%p] + L = boost (p_tmp, mtop) + end function get_boost_for_threshold_projection -@ %def concat_dag_string_dag_token -<>= - function concat_dag_token_dag_string (dag_token, dag_string) result (res_string) - type (dag_token_t), intent (in) :: dag_token - type (dag_string_t), intent (in) :: dag_string - type (dag_string_t) :: res_string - integer :: t_size - if (dag_token%type == EMPTY_TK) then - res_string = dag_string - else if (dag_string%char_len == 0) then - res_string = dag_token +@ %def get_boost_for_threshold_projection +@ This routine recomputes the value of $\phi$ used to generate the real phase space. +<>= + function get_generation_phi (p_born, p_real, emitter, i_gluon) result (phi) + real(default) :: phi + type(vector4_t), intent(in), dimension(:) :: p_born, p_real + integer, intent(in) :: emitter, i_gluon + type(vector4_t) :: p1, p2, pp + type(lorentz_transformation_t) :: rot_to_gluon, rot_to_z + type(vector3_t) :: dir, z + real(default) :: cpsi + pp = p_real(emitter) + p_real(i_gluon) + cpsi = (space_part_norm (pp)**2 - space_part_norm (p_real(emitter))**2 & + + space_part_norm (p_real(i_gluon))**2) / & + (two * space_part_norm (pp) * space_part_norm (p_real(i_gluon))) + dir = create_orthogonal (space_part (p_born(emitter))) + rot_to_gluon = rotation (cpsi, sqrt (one - cpsi**2), dir) + pp = rot_to_gluon * p_born(emitter) + z%p = [0._default, 0._default, 1._default] + rot_to_z = rotation_to_2nd & + (space_part (p_born(emitter)) / space_part_norm (p_born(emitter)), z) + p1 = rot_to_z * pp / space_part_norm (pp) + p2 = rot_to_z * p_real(i_gluon) + phi = azimuthal_distance (p1, p2) + if (phi < zero) phi = twopi - abs(phi) + end function get_generation_phi + +@ %def get_generation_phi +@ +<>= + procedure :: apply_threshold_projection_real => & + real_kinematics_apply_threshold_projection_real +<>= + module subroutine real_kinematics_apply_threshold_projection_real & + (r, i_phs, mtop, L_to_cms, invert) + class(real_kinematics_t), intent(inout) :: r + integer, intent(in) :: i_phs + real(default), intent(in) :: mtop + type(lorentz_transformation_t), intent(in), dimension(:) :: L_to_cms + logical, intent(in) :: invert + end subroutine real_kinematics_apply_threshold_projection_real +<>= + module subroutine real_kinematics_apply_threshold_projection_real & + (r, i_phs, mtop, L_to_cms, invert) + class(real_kinematics_t), intent(inout) :: r + integer, intent(in) :: i_phs + real(default), intent(in) :: mtop + type(lorentz_transformation_t), intent(in), dimension(:) :: L_to_cms + logical, intent(in) :: invert + integer :: leg, other_leg + type(vector4_t), dimension(:), allocatable :: p_real + type(vector4_t), dimension(:), allocatable :: p_real_onshell + type(vector4_t), dimension(4) :: k_tmp + type(vector4_t), dimension(4) :: k_decay_onshell_real + type(vector4_t), dimension(3) :: k_decay_onshell_born + do leg = 1, 2 + other_leg = 3 - leg + p_real = r%p_real_cms%phs_point(i_phs) + allocate (p_real_onshell (size (p_real))) + p_real_onshell(1:2) = p_real(1:2) + k_tmp(1) = p_real(7) + k_tmp(2) = p_real(ass_quark(leg)) + k_tmp(3) = p_real(ass_boson(leg)) + k_tmp(4) = [mtop, zero, zero, zero] + call generate_on_shell_decay_threshold (k_tmp(1:3), & + k_tmp(4), k_decay_onshell_real (2:4)) + k_decay_onshell_real (1) = k_tmp(4) + k_tmp(1) = p_real(ass_quark(other_leg)) + k_tmp(2) = p_real(ass_boson(other_leg)) + k_decay_onshell_born = create_two_particle_decay (mtop**2, k_tmp(1), k_tmp(2)) + p_real_onshell(THR_POS_GLUON) = L_to_cms(leg) * k_decay_onshell_real (2) + p_real_onshell(ass_quark(leg)) = L_to_cms(leg) * k_decay_onshell_real(3) + p_real_onshell(ass_boson(leg)) = L_to_cms(leg) * k_decay_onshell_real(4) + p_real_onshell(ass_quark(other_leg)) = L_to_cms(leg) * k_decay_onshell_born (2) + p_real_onshell(ass_boson(other_leg)) = L_to_cms(leg) * k_decay_onshell_born (3) + if (invert) then + call vector4_invert_direction (p_real_onshell (ass_quark(other_leg))) + call vector4_invert_direction (p_real_onshell (ass_boson(other_leg))) + end if + r%p_real_onshell(leg)%phs_point(i_phs) = p_real_onshell + deallocate (p_real_onshell) + end do + end subroutine real_kinematics_apply_threshold_projection_real + +@ %def real_kinematics_apply_threshold_projection_real +@ +<>= + public :: threshold_projection_born +<>= + module subroutine threshold_projection_born & + (mtop, L_to_cms, p_in, p_onshell) + real(default), intent(in) :: mtop + type(lorentz_transformation_t), intent(in) :: L_to_cms + type(vector4_t), intent(in), dimension(:) :: p_in + type(vector4_t), intent(out), dimension(:) :: p_onshell + end subroutine threshold_projection_born +<>= + module subroutine threshold_projection_born & + (mtop, L_to_cms, p_in, p_onshell) + real(default), intent(in) :: mtop + type(lorentz_transformation_t), intent(in) :: L_to_cms + type(vector4_t), intent(in), dimension(:) :: p_in + type(vector4_t), intent(out), dimension(:) :: p_onshell + type(vector4_t), dimension(3) :: k_decay_onshell + type(vector4_t) :: p_tmp_1, p_tmp_2 + type(lorentz_transformation_t) :: L_to_cms_inv + p_onshell(1:2) = p_in(1:2) + L_to_cms_inv = inverse (L_to_cms) + p_tmp_1 = L_to_cms_inv * p_in(THR_POS_B) + p_tmp_2 = L_to_cms_inv * p_in(THR_POS_WP) + k_decay_onshell = create_two_particle_decay (mtop**2, & + p_tmp_1, p_tmp_2) + p_onshell([THR_POS_B, THR_POS_WP]) = k_decay_onshell([2, 3]) + p_tmp_1 = L_to_cms * p_in(THR_POS_BBAR) + p_tmp_2 = L_to_cms * p_in(THR_POS_WM) + k_decay_onshell = create_two_particle_decay (mtop**2, & + p_tmp_1, p_tmp_2) + p_onshell([THR_POS_BBAR, THR_POS_WM]) = k_decay_onshell([2, 3]) + p_onshell([THR_POS_WP, THR_POS_B]) = L_to_cms * p_onshell([THR_POS_WP, THR_POS_B]) + p_onshell([THR_POS_WM, THR_POS_BBAR]) = L_to_cms_inv * p_onshell([THR_POS_WM, THR_POS_BBAR]) + end subroutine threshold_projection_born + +@ %def threshold_projection_born +@ This routine computes the bounds of the Dalitz region for massive emitters. +The corresponding derivation can be found in [[1202.0465]], App. A. +It is also used for the POWHEG matching so the routine is public. +The input parameter [[m2]] corresponds to the squared mass of the emitter. +<>= + public :: compute_dalitz_bounds +<>= + pure module subroutine compute_dalitz_bounds & + (q0, m2, mrec2, z1, z2, k0_rec_max) + real(default), intent(in) :: q0, m2, mrec2 + real(default), intent(out) :: z1, z2, k0_rec_max + end subroutine compute_dalitz_bounds +<>= + pure module subroutine compute_dalitz_bounds & + (q0, m2, mrec2, z1, z2, k0_rec_max) + real(default), intent(in) :: q0, m2, mrec2 + real(default), intent(out) :: z1, z2, k0_rec_max + k0_rec_max = (q0**2 - m2 + mrec2) / (two * q0) + z1 = (k0_rec_max + sqrt(k0_rec_max**2 - mrec2)) / q0 + z2 = (k0_rec_max - sqrt(k0_rec_max**2 - mrec2)) / q0 + end subroutine compute_dalitz_bounds + +@ %def compute_dalitz_bounds +@ Compute the [[kt2]] of a given emitter +<>= + procedure :: kt2 => real_kinematics_kt2 +<>= + module function real_kinematics_kt2 & + (real_kinematics, i_phs, emitter, kt2_type, xi, y) result (kt2) + real(default) :: kt2 + class(real_kinematics_t), intent(in) :: real_kinematics + integer, intent(in) :: emitter, i_phs, kt2_type + real(default), intent(in), optional :: xi, y + end function real_kinematics_kt2 +<>= + module function real_kinematics_kt2 & + (real_kinematics, i_phs, emitter, kt2_type, xi, y) result (kt2) + real(default) :: kt2 + class(real_kinematics_t), intent(in) :: real_kinematics + integer, intent(in) :: emitter, i_phs, kt2_type + real(default), intent(in), optional :: xi, y + real(default) :: xii, yy + real(default) :: q, E_em, z, z1, z2, m2, mrec2, k0_rec_max + type(vector4_t) :: p_emitter + if (present (y)) then + yy = y else - t_size = size (dag_string%t) - allocate (res_string%t(t_size+1)) - res_string%t(2:t_size+1) = dag_string%t - res_string%t(1) = dag_token - res_string%char_len = dag_token%char_len + dag_string%char_len + yy = real_kinematics%y (i_phs) end if - end function concat_dag_token_dag_string - -@ %def concat_dag_token_dag_string -<>= - function concat_dag_string_dag_string (string1, string2) result (res_string) - type (dag_string_t), intent (in) :: string1, string2 - type (dag_string_t) :: res_string - integer :: t1_size, t2_size, t_size - if (string1%char_len == 0) then - res_string = string2 - else if (string2%char_len == 0) then - res_string = string1 + if (present (xi)) then + xii = xi else - t1_size = size (string1%t) - t2_size = size (string2%t) - t_size = t1_size + t2_size - if (t_size > 0) then - allocate (res_string%t(t_size)) - res_string%t(:t1_size) = string1%t - res_string%t(t1_size+1:) = string2%t - res_string%char_len = string1%char_len + string2%char_len - end if + xii = real_kinematics%xi_tilde * real_kinematics%xi_max (i_phs) end if - end function concat_dag_string_dag_string + select case (kt2_type) + case (UBF_FSR_SIMPLE) + kt2 = real_kinematics%cms_energy2 / two * xii**2 * (1 - yy) + case (UBF_FSR_MASSIVE) + q = sqrt (real_kinematics%cms_energy2) + p_emitter = real_kinematics%p_born_cms%phs_point(1)%select (emitter) + mrec2 = (q - p_emitter%p(0))**2 - sum (p_emitter%p(1:3)**2) + m2 = p_emitter**2 + E_em = energy (p_emitter) + call compute_dalitz_bounds (q, m2, mrec2, z1, z2, k0_rec_max) + z = z2 - (z2 - z1) * (one + yy) / two + kt2 = xii**2 * q**3 * (one - z) / & + (two * E_em - z * xii * q) + case (UBF_FSR_MASSLESS_RECOIL) + kt2 = real_kinematics%cms_energy2 / two * xii**2 * (1 - yy**2) / two + case default + kt2 = zero + call msg_bug ("kt2_type must be set to a known value") + end select + end function real_kinematics_kt2 -@ %def concat_dag_string_dag_string -@ Compare strings/tokens/characters. Each character is relevant, including -all blanc spaces. An exception is the [[newline]] character which is not -treated by the types used in this module (not to confused with the type -parameter [[NEW_LINE_TK]] which corresponds to the backslash character -and simply tells us that the string continues on the next line in the file). -<>= - public :: operator (==) -<>= - interface operator (==) - module procedure dag_token_eq_dag_token - module procedure dag_string_eq_dag_string - module procedure dag_token_eq_dag_string - module procedure dag_string_eq_dag_token - module procedure dag_token_eq_char_string - module procedure char_string_eq_dag_token - module procedure dag_string_eq_char_string - module procedure char_string_eq_dag_string - end interface operator (==) +@ %def real_kinematics_kt2 +@ These are the possible values for [[upper_bound_func_type]] and will be +used to decide which UBF object is allocated and which $K_T$ scale for the +matching is computed. +<>= + integer, parameter, public :: UBF_FSR_SIMPLE = 1 + integer, parameter, public :: UBF_FSR_MASSIVE = 2 + integer, parameter, public :: UBF_FSR_MASSLESS_RECOIL = 3 +@ %def UBF_FSR_SIMPLE UBF_FSR_MASSIVE UBF_FSR_MASSLESS_RECOIL +@ +<>= + procedure :: final => real_kinematics_final +<>= + module subroutine real_kinematics_final (real_kin) + class(real_kinematics_t), intent(inout) :: real_kin + end subroutine real_kinematics_final +<>= + module subroutine real_kinematics_final (real_kin) + class(real_kinematics_t), intent(inout) :: real_kin + if (allocated (real_kin%xi_max)) deallocate (real_kin%xi_max) + if (allocated (real_kin%y)) deallocate (real_kin%y) + if (allocated (real_kin%alr_to_i_phs)) deallocate (real_kin%alr_to_i_phs) + if (allocated (real_kin%jac_rand)) deallocate (real_kin%jac_rand) + if (allocated (real_kin%y_soft)) deallocate (real_kin%y_soft) + if (allocated (real_kin%xi_ref_momenta)) & + deallocate (real_kin%xi_ref_momenta) + call real_kin%p_born_cms%final (); call real_kin%p_born_lab%final () + call real_kin%p_real_cms%final (); call real_kin%p_real_lab%final () + end subroutine real_kinematics_final -@ %def interfaces -<>= - elemental function dag_token_eq_dag_token (token1, token2) result (flag) - type (dag_token_t), intent (in) :: token1, token2 - logical :: flag - flag = (token1%type == token2%type) .and. & - (token1%char_len == token2%char_len) .and. & - (token1%bincode == token2%bincode) .and. & - (token1%index == token2%index) .and. & - (token1%particle_name == token2%particle_name) - end function dag_token_eq_dag_token +@ %def real_kinematics_final +@ +<>= + integer, parameter, public :: I_XI = 1 + integer, parameter, public :: I_Y = 2 + integer, parameter, public :: I_PHI = 3 -@ %def dag_token_eq_dag_token -<>= - elemental function dag_string_eq_dag_string (string1, string2) result (flag) - type (dag_string_t), intent (in) :: string1, string2 - logical :: flag - flag = (string1%char_len == string2%char_len) .and. & - (allocated (string1%t) .eqv. allocated (string2%t)) - if (flag) then - if (allocated (string1%t)) flag = all (string1%t == string2%t) - end if - end function dag_string_eq_dag_string + integer, parameter, public :: PHS_MODE_UNDEFINED = 0 + integer, parameter, public :: PHS_MODE_ADDITIONAL_PARTICLE = 1 + integer, parameter, public :: PHS_MODE_COLLINEAR_REMNANT = 2 -@ %def dag_string_eq_dag_string -<>= - elemental function dag_token_eq_dag_string (dag_token, dag_string) result (flag) - type (dag_token_t), intent (in) :: dag_token - type (dag_string_t), intent (in) :: dag_string - logical :: flag - flag = size (dag_string%t) == 1 .and. & - dag_string%char_len == dag_token%char_len - if (flag) flag = (dag_string%t(1) == dag_token) - end function dag_token_eq_dag_string +@ %def parameters +@ +<>= + public :: phs_fks_config_t +<>= + type, extends (phs_wood_config_t) :: phs_fks_config_t + integer :: mode = PHS_MODE_UNDEFINED + character(32) :: md5sum_born_config + logical :: born_2_to_1 = .false. + logical :: make_dalitz_plot = .false. + contains + <> + end type phs_fks_config_t -@ %def dag_token_eq_dag_string -<>= - elemental function dag_string_eq_dag_token (dag_string, dag_token) result (flag) - type (dag_token_t), intent (in) :: dag_token - type (dag_string_t), intent (in) :: dag_string - logical :: flag - flag = (dag_token == dag_string) - end function dag_string_eq_dag_token +@ %def phs_fks_config_t +@ +<>= + procedure :: clear_phase_space => fks_config_clear_phase_space +<>= + module subroutine fks_config_clear_phase_space (phs_config) + class(phs_fks_config_t), intent(inout) :: phs_config + end subroutine fks_config_clear_phase_space +<>= + module subroutine fks_config_clear_phase_space (phs_config) + class(phs_fks_config_t), intent(inout) :: phs_config + end subroutine fks_config_clear_phase_space -@ %def dag_string_eq_dag_token -<>= - elemental function dag_token_eq_char_string (dag_token, char_string) result (flag) - type (dag_token_t), intent (in) :: dag_token - character (len=*), intent (in) :: char_string - logical :: flag - flag = (char (dag_token) == char_string) - end function dag_token_eq_char_string +@ %def fks_config_clear_phase_space +@ +<>= + procedure :: write => phs_fks_config_write +<>= + module subroutine phs_fks_config_write (object, unit, include_id) + class(phs_fks_config_t), intent(in) :: object + integer, intent(in), optional :: unit + logical, intent(in), optional :: include_id + end subroutine phs_fks_config_write +<>= + module subroutine phs_fks_config_write (object, unit, include_id) + class(phs_fks_config_t), intent(in) :: object + integer, intent(in), optional :: unit + logical, intent(in), optional :: include_id + integer :: u + u = given_output_unit (unit) + call object%phs_wood_config_t%write (u) + write (u, "(3x,A,I0)") "NLO mode = ", object%mode + write (u, "(3x,A,L1)") "2->1 proc = ", object%born_2_to_1 + write (u, "(3x,A,L1)") "Dalitz = ", object%make_dalitz_plot + write (u, "(A,A)") "Extra Born md5sum: ", object%md5sum_born_config + end subroutine phs_fks_config_write -@ %def dag_token_eq_char_string -<>= - elemental function char_string_eq_dag_token (char_string, dag_token) result (flag) - type (dag_token_t), intent (in) :: dag_token - character (len=*), intent (in) :: char_string - logical :: flag - flag = (char (dag_token) == char_string) - end function char_string_eq_dag_token +@ %def phs_fks_config_write +@ +<>= + procedure :: set_mode => phs_fks_config_set_mode +<>= + module subroutine phs_fks_config_set_mode (phs_config, mode) + class(phs_fks_config_t), intent(inout) :: phs_config + integer, intent(in) :: mode + end subroutine phs_fks_config_set_mode +<>= + module subroutine phs_fks_config_set_mode (phs_config, mode) + class(phs_fks_config_t), intent(inout) :: phs_config + integer, intent(in) :: mode + select case (mode) + case (NLO_REAL, NLO_MISMATCH) + phs_config%mode = PHS_MODE_ADDITIONAL_PARTICLE + case (NLO_DGLAP) + phs_config%mode = PHS_MODE_COLLINEAR_REMNANT + end select + end subroutine phs_fks_config_set_mode -@ %def char_string_eq_dag_token -<>= - elemental function dag_string_eq_char_string (dag_string, char_string) result (flag) - type (dag_string_t), intent (in) :: dag_string - character (len=*), intent (in) :: char_string - logical :: flag - flag = (char (dag_string) == char_string) - end function dag_string_eq_char_string +@ %def phs_fks_config_set_mod +@ +<>= + procedure :: configure => phs_fks_config_configure +<>= + module subroutine phs_fks_config_configure (phs_config, sqrts, & + sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, & + ignore_mismatch, nlo_type, subdir) + class(phs_fks_config_t), intent(inout) :: phs_config + real(default), intent(in) :: sqrts + logical, intent(in), optional :: sqrts_fixed + logical, intent(in), optional :: lab_is_cm + logical, intent(in), optional :: azimuthal_dependence + logical, intent(in), optional :: rebuild + logical, intent(in), optional :: ignore_mismatch + integer, intent(in), optional :: nlo_type + type(string_t), intent(in), optional :: subdir + end subroutine phs_fks_config_configure +<>= + module subroutine phs_fks_config_configure (phs_config, sqrts, & + sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, & + ignore_mismatch, nlo_type, subdir) + class(phs_fks_config_t), intent(inout) :: phs_config + real(default), intent(in) :: sqrts + logical, intent(in), optional :: sqrts_fixed + logical, intent(in), optional :: lab_is_cm + logical, intent(in), optional :: azimuthal_dependence + logical, intent(in), optional :: rebuild + logical, intent(in), optional :: ignore_mismatch + integer, intent(in), optional :: nlo_type + type(string_t), intent(in), optional :: subdir + if (present (nlo_type)) phs_config%nlo_type = nlo_type + if (.not. phs_config%is_combined_integration) then + select case (phs_config%mode) + case (PHS_MODE_ADDITIONAL_PARTICLE) + phs_config%n_par = phs_config%n_par + 3 + if (phs_config%nlo_type == NLO_REAL .and. phs_config%n_out == 2) then + phs_config%born_2_to_1 = .true. + end if + case (PHS_MODE_COLLINEAR_REMNANT) + phs_config%n_par = phs_config%n_par + 1 + end select + end if + call phs_config%compute_md5sum () + end subroutine phs_fks_config_configure -@ %def dag_string_eq_char_string -<>= - elemental function char_string_eq_dag_string (char_string, dag_string) result (flag) - type (dag_string_t), intent (in) :: dag_string - character (len=*), intent (in) :: char_string - logical :: flag - flag = (char (dag_string) == char_string) - end function char_string_eq_dag_string +@ %def phs_fks_config_configure +@ +<>= + procedure :: startup_message => phs_fks_config_startup_message +<>= + module subroutine phs_fks_config_startup_message (phs_config, unit) + class(phs_fks_config_t), intent(in) :: phs_config + integer, intent(in), optional :: unit + end subroutine phs_fks_config_startup_message +<>= + module subroutine phs_fks_config_startup_message (phs_config, unit) + class(phs_fks_config_t), intent(in) :: phs_config + integer, intent(in), optional :: unit + call phs_config%phs_wood_config_t%startup_message (unit) + end subroutine phs_fks_config_startup_message -@ %def char_string_eq_dag_string -<>= - public :: operator (/=) -<>= - interface operator (/=) - module procedure dag_token_ne_dag_token - module procedure dag_string_ne_dag_string - module procedure dag_token_ne_dag_string - module procedure dag_string_ne_dag_token - module procedure dag_token_ne_char_string - module procedure char_string_ne_dag_token - module procedure dag_string_ne_char_string - module procedure char_string_ne_dag_string - end interface operator (/=) +@ %def phs_fks_config_startup_message +@ Gfortran 7/8/9 bug, has to remain in the main module: +<>= + procedure, nopass :: allocate_instance => phs_fks_config_allocate_instance +<>= + subroutine phs_fks_config_allocate_instance (phs) + class(phs_t), intent(inout), pointer :: phs + allocate (phs_fks_t :: phs) + end subroutine phs_fks_config_allocate_instance -@ %def interfaces -<>= - elemental function dag_token_ne_dag_token (token1, token2) result (flag) - type (dag_token_t), intent (in) :: token1, token2 - logical :: flag - flag = .not. (token1 == token2) - end function dag_token_ne_dag_token +@ %def phs_fks_config_allocate_instance +@ If the phase space is generated from file, but we want to have resonance +histories, we must force the cascade sets to be generated. However, it must +be assured that Born flavors are used for this. +<>= + procedure :: generate_phase_space_extra => & + phs_fks_config_generate_phase_space_extra +<>= + module subroutine phs_fks_config_generate_phase_space_extra (phs_config) + class(phs_fks_config_t), intent(inout) :: phs_config + end subroutine phs_fks_config_generate_phase_space_extra +<>= + module subroutine phs_fks_config_generate_phase_space_extra (phs_config) + class(phs_fks_config_t), intent(inout) :: phs_config + integer :: off_shell, extra_off_shell + type(flavor_t), dimension(:,:), allocatable :: flv_born + integer :: i, j + integer :: n_state, n_flv_born + integer :: unit_fds + logical :: valid + type(string_t) :: file_name + logical :: file_exists + if (phs_config%use_cascades2) then + allocate (phs_config%feyngraph_set) + else + allocate (phs_config%cascade_set) + end if + n_flv_born = size (phs_config%flv, 1) - 1 + n_state = size (phs_config%flv, 2) + allocate (flv_born (n_flv_born, n_state)) + do i = 1, n_flv_born + do j = 1, n_state + flv_born(i, j) = phs_config%flv(i, j) + end do + end do + if (phs_config%use_cascades2) then + file_name = char (phs_config%id) // ".fds" + inquire (file=char (file_name), exist=file_exists) + if (.not. file_exists) call msg_fatal & + ("The O'Mega input file " // char (file_name) // & + " does not exist. " // "Please make sure that the " // & + "variable ?omega_write_phs_output has been set correctly.") + unit_fds = free_unit () + open (unit=unit_fds, file=char(file_name), status='old', action='read') + end if + off_shell = phs_config%par%off_shell + do extra_off_shell = 0, max (n_flv_born - 2, 0) + phs_config%par%off_shell = off_shell + extra_off_shell + if (phs_config%use_cascades2) then + call feyngraph_set_generate (phs_config%feyngraph_set, & + phs_config%model, phs_config%n_in, phs_config%n_out - 1, & + flv_born, phs_config%par, phs_config%fatal_beam_decay, unit_fds, & + phs_config%vis_channels) + if (feyngraph_set_is_valid (phs_config%feyngraph_set)) exit + else + call cascade_set_generate (phs_config%cascade_set, & + phs_config%model, phs_config%n_in, phs_config%n_out - 1, & + flv_born, phs_config%par, phs_config%fatal_beam_decay) + if (cascade_set_is_valid (phs_config%cascade_set)) exit + end if + end do + if (phs_config%use_cascades2) then + close (unit_fds) + valid = feyngraph_set_is_valid (phs_config%feyngraph_set) + else + valid = cascade_set_is_valid (phs_config%cascade_set) + end if + if (.not. valid) & + call msg_fatal ("Resonance extraction: Phase space generation failed") + end subroutine phs_fks_config_generate_phase_space_extra -@ %def dag_token_ne_dag_token -<>= - elemental function dag_string_ne_dag_string (string1, string2) result (flag) - type (dag_string_t), intent (in) :: string1, string2 - logical :: flag - flag = .not. (string1 == string2) - end function dag_string_ne_dag_string +@ %def phs_fks_config_generate_phase_space_extra +@ +<>= + procedure :: set_born_config => phs_fks_config_set_born_config +<>= + module subroutine phs_fks_config_set_born_config (phs_config, phs_cfg_born) + class(phs_fks_config_t), intent(inout) :: phs_config + type(phs_wood_config_t), intent(in), target :: phs_cfg_born + end subroutine phs_fks_config_set_born_config +<>= + module subroutine phs_fks_config_set_born_config (phs_config, phs_cfg_born) + class(phs_fks_config_t), intent(inout) :: phs_config + type(phs_wood_config_t), intent(in), target :: phs_cfg_born + if (debug_on) & + call msg_debug (D_PHASESPACE, "phs_fks_config_set_born_config") + phs_config%forest = phs_cfg_born%forest + phs_config%n_channel = phs_cfg_born%n_channel + allocate (phs_config%channel (phs_config%n_channel)) + phs_config%channel = phs_cfg_born%channel + phs_config%n_par = phs_cfg_born%n_par + phs_config%n_state = phs_cfg_born%n_state + phs_config%sqrts = phs_cfg_born%sqrts + phs_config%par = phs_cfg_born%par + phs_config%sqrts_fixed = phs_cfg_born%sqrts_fixed + phs_config%azimuthal_dependence = phs_cfg_born%azimuthal_dependence + phs_config%provides_chains = phs_cfg_born%provides_chains + phs_config%lab_is_cm = phs_cfg_born%lab_is_cm + phs_config%vis_channels = phs_cfg_born%vis_channels + phs_config%provides_equivalences = phs_cfg_born%provides_equivalences + allocate (phs_config%chain (size (phs_cfg_born%chain))) + phs_config%chain = phs_cfg_born%chain + phs_config%model => phs_cfg_born%model + phs_config%use_cascades2 = phs_cfg_born%use_cascades2 + if (allocated (phs_cfg_born%cascade_set)) then + allocate (phs_config%cascade_set) + phs_config%cascade_set = phs_cfg_born%cascade_set + end if + if (allocated (phs_cfg_born%feyngraph_set)) then + allocate (phs_config%feyngraph_set) + phs_config%feyngraph_set = phs_cfg_born%feyngraph_set + end if + phs_config%md5sum_born_config = phs_cfg_born%md5sum_phs_config + end subroutine phs_fks_config_set_born_config -@ %def dag_string_ne_dag_string -<>= - elemental function dag_token_ne_dag_string (dag_token, dag_string) result (flag) - type (dag_token_t), intent (in) :: dag_token - type (dag_string_t), intent (in) :: dag_string - logical :: flag - flag = .not. (dag_token == dag_string) - end function dag_token_ne_dag_string +@ %def phs_fks_config_set_born_config +@ +<>= + procedure :: get_resonance_histories => & + phs_fks_config_get_resonance_histories +<>= + module function phs_fks_config_get_resonance_histories & + (phs_config) result (resonance_histories) + type(resonance_history_t), dimension(:), allocatable :: & + resonance_histories + class(phs_fks_config_t), intent(inout) :: phs_config + end function phs_fks_config_get_resonance_histories +<>= + module function phs_fks_config_get_resonance_histories & + (phs_config) result (resonance_histories) + type(resonance_history_t), dimension(:), allocatable :: resonance_histories + class(phs_fks_config_t), intent(inout) :: phs_config + if (allocated (phs_config%cascade_set)) then + call cascade_set_get_resonance_histories (phs_config%cascade_set, & + n_filter = 2, res_hists = resonance_histories) + else if (allocated (phs_config%feyngraph_set)) then + call feyngraph_set_get_resonance_histories (phs_config%feyngraph_set, & + n_filter = 2, res_hists = resonance_histories) + else + if (debug_on) call msg_debug (D_PHASESPACE, "Have to rebuild phase space for resonance histories") + call phs_config%generate_phase_space_extra () + if (phs_config%use_cascades2) then + call feyngraph_set_get_resonance_histories & + (phs_config%feyngraph_set, n_filter = 2, res_hists = resonance_histories) + else + call cascade_set_get_resonance_histories & + (phs_config%cascade_set, n_filter = 2, res_hists = resonance_histories) + end if + end if + end function phs_fks_config_get_resonance_histories -@ %def dag_token_ne_dag_string -<>= - elemental function dag_string_ne_dag_token (dag_string, dag_token) result (flag) - type (dag_token_t), intent (in) :: dag_token - type (dag_string_t), intent (in) :: dag_string - logical :: flag - flag = .not. (dag_string == dag_token) - end function dag_string_ne_dag_token +@ %def phs_fks_config_get_resonance_histories +@ +<>= + public :: dalitz_plot_t +<>= + type :: dalitz_plot_t + integer :: unit = -1 + type(string_t) :: filename + logical :: active = .false. + logical :: inverse = .false. + contains + <> + end type dalitz_plot_t -@ %def dag_string_ne_dag_token -<>= - elemental function dag_token_ne_char_string (dag_token, char_string) result (flag) - type (dag_token_t), intent (in) :: dag_token - character (len=*), intent (in) :: char_string - logical :: flag - flag = .not. (dag_token == char_string) - end function dag_token_ne_char_string +@ %def dalitz_plot_t +@ +<>= + procedure :: init => dalitz_plot_init +<>= + module subroutine dalitz_plot_init (plot, unit, filename, inverse) + class(dalitz_plot_t), intent(inout) :: plot + integer, intent(in) :: unit + type(string_t), intent(in) :: filename + logical, intent(in) :: inverse + end subroutine dalitz_plot_init +<>= + module subroutine dalitz_plot_init (plot, unit, filename, inverse) + class(dalitz_plot_t), intent(inout) :: plot + integer, intent(in) :: unit + type(string_t), intent(in) :: filename + logical, intent(in) :: inverse + plot%active = .true. + plot%unit = unit + plot%inverse = inverse + open (plot%unit, file = char (filename), action = "write") + end subroutine dalitz_plot_init -@ %def dag_token_ne_char_string -<>= - elemental function char_string_ne_dag_token (char_string, dag_token) result (flag) - type (dag_token_t), intent (in) :: dag_token - character (len=*), intent (in) :: char_string - logical :: flag - flag = .not. (char_string == dag_token) - end function char_string_ne_dag_token +@ %def daltiz_plot_init +@ +<>= + procedure :: write_header => dalitz_plot_write_header +<>= + module subroutine dalitz_plot_write_header (plot) + class(dalitz_plot_t), intent(in) :: plot + end subroutine dalitz_plot_write_header +<>= + module subroutine dalitz_plot_write_header (plot) + class(dalitz_plot_t), intent(in) :: plot + write (plot%unit, "(A36)") "### Dalitz plot generated by WHIZARD" + if (plot%inverse) then + write (plot%unit, "(A10,1x,A4)") "### k0_n+1", "k0_n" + else + write (plot%unit, "(A8,1x,A6)") "### k0_n", "k0_n+1" + end if + end subroutine dalitz_plot_write_header -@ %def char_string_ne_dag_token -<>= - elemental function dag_string_ne_char_string (dag_string, char_string) result (flag) - type (dag_string_t), intent (in) :: dag_string - character (len=*), intent (in) :: char_string - logical :: flag - flag = .not. (dag_string == char_string) - end function dag_string_ne_char_string +@ %def dalitz_plot_write_header +@ +<>= + procedure :: register => dalitz_plot_register +<>= + module subroutine dalitz_plot_register (plot, k0_n, k0_np1) + class(dalitz_plot_t), intent(in) :: plot + real(default), intent(in) :: k0_n, k0_np1 + end subroutine dalitz_plot_register +<>= + module subroutine dalitz_plot_register (plot, k0_n, k0_np1) + class(dalitz_plot_t), intent(in) :: plot + real(default), intent(in) :: k0_n, k0_np1 + if (plot%inverse) then + write (plot%unit, "(F8.4,1X,F8.4)") k0_np1, k0_n + else + write (plot%unit, "(F8.4,1X,F8.4)") k0_np1, k0_n + end if + end subroutine dalitz_plot_register -@ %def dag_string_ne_char_string -<>= - elemental function char_string_ne_dag_string (char_string, dag_string) result (flag) - type (dag_string_t), intent (in) :: dag_string - character (len=*), intent (in) :: char_string - logical :: flag - flag = .not. (char_string == dag_string) - end function char_string_ne_dag_string +@ %def dalitz_plot_register +@ +<>= + procedure :: final => dalitz_plot_final +<>= + module subroutine dalitz_plot_final (plot) + class(dalitz_plot_t), intent(inout) :: plot + end subroutine dalitz_plot_final +<>= + module subroutine dalitz_plot_final (plot) + class(dalitz_plot_t), intent(inout) :: plot + logical :: opened + plot%active = .false. + plot%inverse = .false. + if (plot%unit >= 0) then + inquire (unit = plot%unit, opened = opened) + if (opened) close (plot%unit) + end if + plot%filename = var_str ('') + plot%unit = -1 + end subroutine dalitz_plot_final -@ %def char_string_ne_dag_string -@ Convert a [[dag_token]] or [[dag_string]] to character. -<>= - public :: char -<>= - interface char - module procedure char_dag_token - module procedure char_dag_string - end interface char +@ %def dalitz_plot_final +@ +<>= + integer, parameter, public :: GEN_REAL_PHASE_SPACE = 1 + integer, parameter, public :: GEN_SOFT_MISMATCH = 2 + integer, parameter, public :: GEN_SOFT_LIMIT_TEST = 3 + integer, parameter, public :: GEN_COLL_LIMIT_TEST = 4 + integer, parameter, public :: GEN_ANTI_COLL_LIMIT_TEST = 5 + integer, parameter, public :: GEN_SOFT_COLL_LIMIT_TEST = 6 + integer, parameter, public :: GEN_SOFT_ANTI_COLL_LIMIT_TEST = 7 -@ %def interfaces -<>= - pure function char_dag_token (dag_token) result (char_string) - type (dag_token_t), intent (in) :: dag_token - character (dag_token%char_len) :: char_string - integer :: i - integer :: name_len - integer :: bc_pos - integer :: n_digits - character (len=9) :: fmt_spec - select case (dag_token%type) - case (EMPTY_TK) - char_string = "" - case (NEW_LINE_TK) - char_string = BACKSLASH_CHAR - case (BLANC_SPACE_TK) - char_string = " " - case (COLON_TK) - char_string = ":" - case (COMMA_TK) - char_string = "," - case (VERTICAL_BAR_TK) - char_string = "|" - case (OPEN_PAR_TK) - char_string = "(" - case (CLOSED_PAR_TK) - char_string = ")" - case (OPEN_CURLY_TK) - char_string = "{" - case (CLOSED_CURLY_TK) - char_string = "}" - case (DAG_NODE_TK, DAG_OPTIONS_TK, DAG_COMBINATION_TK) - n_digits = dag_token%char_len - 3 - fmt_spec = "" - if (n_digits > 9) then - write (fmt_spec, fmt="(A,I2,A)") "(A,I", n_digits, ",A)" - else - write (fmt_spec, fmt="(A,I1,A)") "(A,I", n_digits, ",A)" - end if - select case (dag_token%type) - case (DAG_NODE_TK) - write (char_string, fmt=fmt_spec) "" - case (DAG_OPTIONS_TK) - write (char_string, fmt=fmt_spec) "" - case (DAG_COMBINATION_TK) - write (char_string, fmt=fmt_spec) "" - end select - case (NODE_TK) - name_len = len_trim (dag_token%particle_name) - char_string = dag_token%particle_name - bc_pos = name_len + 1 - char_string(bc_pos:bc_pos) = "[" - do i=0, bit_size (dag_token%bincode) - 1 - if (btest (dag_token%bincode, i)) then - bc_pos = bc_pos + 1 - select case (i) - case (0, 1, 2, 3, 4, 5, 6, 7, 8) - write (char_string(bc_pos:bc_pos), fmt="(I1)") i + 1 - case (9) - write (char_string(bc_pos:bc_pos), fmt="(A1)") "A" - case (10) - write (char_string(bc_pos:bc_pos), fmt="(A1)") "B" - case (11) - write (char_string(bc_pos:bc_pos), fmt="(A1)") "C" - end select - bc_pos = bc_pos + 1 - if (bc_pos == dag_token%char_len) then - write (char_string(bc_pos:bc_pos), fmt="(A1)") "]" - return - else - write (char_string(bc_pos:bc_pos), fmt="(A1)") "/" + integer, parameter, public :: SQRTS_FIXED = 1 + integer, parameter, public :: SQRTS_VAR = 2 + + real(default), parameter :: xi_tilde_test_soft = 0.00001_default + real(default), parameter :: xi_tilde_test_coll = 0.5_default + real(default), parameter :: y_test_soft = 0.5_default + real(default), parameter :: y_test_coll = 0.9999999_default + !!! for testing EW singularities: y_test_coll = 0.99999999_default + +@ +@ Very soft or collinear phase-space points can become a problem for +matrix elements providers, as some scalar products cannot be evaluated +properly. Here, a nonsensical result can spoil the whole integration. +We therefore check the scalar products appearing to be below a certain +tolerance.\\ +Naturally, this happens very rarely but for some processes, +setting [[?test_coll_limit = true]] and/or [[?test_soft_limit = true]] +leads to all phase space points beeing discarded by this routine. +<>= + public :: check_scalar_products +<>= + module function check_scalar_products (p) result (valid) + logical :: valid + type(vector4_t), intent(in), dimension(:) :: p + end function check_scalar_products +<>= + module function check_scalar_products (p) result (valid) + logical :: valid + type(vector4_t), intent(in), dimension(:) :: p + real(default), parameter :: tolerance = 1E-7_default + !!! for testing EW singularities: tolerance = 5E-9_default + integer :: i, j + valid = .true. + do i = 1, size (p) + do j = i, size (p) + if (i /= j) then + if (abs(p(i) * p(j)) < tolerance) then + valid = .false. + exit end if end if - enddo - end select - end function char_dag_token + end do + end do + end function check_scalar_products -@ %def char_dag_token -<>= - pure function char_dag_string (dag_string) result (char_string) - type (dag_string_t), intent (in) :: dag_string - character (dag_string%char_len) :: char_string - integer :: pos - integer :: i - char_string = "" - pos = 0 - do i=1, size(dag_string%t) - char_string(pos+1:pos+dag_string%t(i)%char_len) = char (dag_string%t(i)) - pos = pos + dag_string%t(i)%char_len - enddo - end function char_dag_string +@ %def check_scalar_products +@ [[xi_min]] should be set to a non-zero value in order to avoid +phase-space points with [[p_real(emitter) = 0]]. +<>= + public :: phs_fks_generator_t +<>= + type :: phs_fks_generator_t + integer, dimension(:), allocatable :: emitters + type(real_kinematics_t), pointer :: real_kinematics => null() + type(isr_kinematics_t), pointer :: isr_kinematics => null() + integer :: n_in + real(default) :: xi_min + real(default) :: y_max + real(default) :: sqrts + real(default) :: E_gluon + real(default) :: mrec2 + real(default), dimension(:), allocatable :: m2 + logical :: massive_phsp = .false. + logical, dimension(:), allocatable :: is_massive + logical :: singular_jacobian = .false. + integer :: i_fsr_first = -1 + type(resonance_contributors_t), dimension(:), allocatable :: resonance_contributors !!! Put somewhere else? + integer :: mode = GEN_REAL_PHASE_SPACE + contains + <> + end type phs_fks_generator_t -@ %def char_dag_string -@ Remove all tokens which are irrelevant for parsing. These are of type -[[NEW_LINE_TK]], [[BLANC_SPACE_TK]] and [[EMTPY_TK]]. -<>= - procedure :: clean => dag_string_clean -<>= - subroutine dag_string_clean (dag_string) - class (dag_string_t), intent (inout) :: dag_string - type (dag_token_t), dimension(:), allocatable :: tmp_token - integer :: n_keep - integer :: i - n_keep = 0 - dag_string%char_len = 0 - allocate (tmp_token (size(dag_string%t))) - do i=1, size (dag_string%t) - select case (dag_string%t(i)%type) - case(NEW_LINE_TK, BLANC_SPACE_TK, EMPTY_TK) - case default - n_keep = n_keep + 1 - tmp_token(n_keep) = dag_string%t(i) - dag_string%char_len = dag_string%char_len + dag_string%t(i)%char_len - end select - enddo - deallocate (dag_string%t) - allocate (dag_string%t(n_keep)) - dag_string%t = tmp_token(:n_keep) - end subroutine dag_string_clean +@ %def phs_fks_generator_t +@ +<>= + procedure :: connect_kinematics => phs_fks_generator_connect_kinematics +<>= + module subroutine phs_fks_generator_connect_kinematics & + (generator, isr_kinematics, real_kinematics, massive_phsp) + class(phs_fks_generator_t), intent(inout) :: generator + type(isr_kinematics_t), intent(in), pointer :: isr_kinematics + type(real_kinematics_t), intent(in), pointer :: real_kinematics + logical, intent(in) :: massive_phsp + end subroutine phs_fks_generator_connect_kinematics +<>= + module subroutine phs_fks_generator_connect_kinematics & + (generator, isr_kinematics, real_kinematics, massive_phsp) + class(phs_fks_generator_t), intent(inout) :: generator + type(isr_kinematics_t), intent(in), pointer :: isr_kinematics + type(real_kinematics_t), intent(in), pointer :: real_kinematics + logical, intent(in) :: massive_phsp + generator%real_kinematics => real_kinematics + generator%isr_kinematics => isr_kinematics + generator%massive_phsp = massive_phsp + end subroutine phs_fks_generator_connect_kinematics -@ %def dag_string_clean -@ If we operate explicitly on the [[token]] array [[t]] of a [[dag_string]], -the variable [[char_len]] is not automatically modified. It can however be -determined afterwards using the following subroutine. -<>= - procedure :: update_char_len => dag_string_update_char_len -<>= - subroutine dag_string_update_char_len (dag_string) - class (dag_string_t), intent (inout) :: dag_string - integer :: char_len - integer :: i - char_len = 0 - if (allocated (dag_string%t)) then - do i=1, size (dag_string%t) - char_len = char_len + dag_string%t(i)%char_len - enddo - end if - dag_string%char_len = char_len - end subroutine dag_string_update_char_len +@ %def phs_fks_generator_connect_kinematics +@ +<>= + procedure :: compute_isr_kinematics => & + phs_fks_generator_compute_isr_kinematics +<>= + module subroutine phs_fks_generator_compute_isr_kinematics & + (generator, r, p_in) + class(phs_fks_generator_t), intent(inout) :: generator + real(default), intent(in) :: r + type(vector4_t), dimension(2), intent(in), optional :: p_in + end subroutine phs_fks_generator_compute_isr_kinematics +<>= + module subroutine phs_fks_generator_compute_isr_kinematics & + (generator, r, p_in) + class(phs_fks_generator_t), intent(inout) :: generator + real(default), intent(in) :: r + type(vector4_t), dimension(2), intent(in), optional :: p_in + integer :: em + type(vector4_t), dimension(2) :: p -@ %def dag_string_update_char_len -@ Append a [[dag_string]] to a [[dag_chain]]. The argument [[char_string]] -is of type [[character]] because the subroutine is used for reading from -the file produced by O'Mega which is first read line by line to a character -variable. -<>= - procedure :: append => dag_chain_append_string -<>= - subroutine dag_chain_append_string (dag_chain, char_string) - class (dag_chain_t), intent (inout) :: dag_chain - character (len=*), intent (in) :: char_string - if (.not. associated (dag_chain%first)) then - allocate (dag_chain%first) - dag_chain%last => dag_chain%first + if (present (p_in)) then + p = p_in else - allocate (dag_chain%last%next) - dag_chain%last => dag_chain%last%next + p = generator%real_kinematics%p_born_lab%phs_point(1)%select ([1,2]) end if - dag_chain%last = char_string - dag_chain%char_len = dag_chain%char_len + dag_chain%last%char_len - dag_chain%t_size = dag_chain%t_size + size (dag_chain%last%t) - end subroutine dag_chain_append_string -@ %def dag_chain_append_string -@ Reduce the linked list of [[dag_string]] objects which are attached -to a given [[dag_chain]] object to a single [[dag_string]]. -<>= - procedure :: compress => dag_chain_compress -<>= - subroutine dag_chain_compress (dag_chain) - class (dag_chain_t), intent (inout) :: dag_chain - type (dag_string_t), pointer :: current - type (dag_string_t), pointer :: remove - integer :: filled_t - current => dag_chain%first - dag_chain%first => null () - allocate (dag_chain%first) - dag_chain%last => dag_chain%first - dag_chain%first%char_len = dag_chain%char_len - allocate (dag_chain%first%t (dag_chain%t_size)) - filled_t = 0 - do while (associated (current)) - dag_chain%first%t(filled_t+1:filled_t+size(current%t)) = current%t - filled_t = filled_t + size (current%t) - remove => current - current => current%next - deallocate (remove) - enddo - end subroutine dag_chain_compress + associate (isr_kinematics => generator%isr_kinematics) + do em = 1, 2 + isr_kinematics%x(em) = p(em)%p(0) / isr_kinematics%beam_energy(em) + isr_kinematics%z(em) = one - (one - isr_kinematics%x(em)) * r + isr_kinematics%jacobian(em) = one - isr_kinematics%x(em) + end do + isr_kinematics%sqrts_born = (p(1) + p(2))**1 + end associate + end subroutine phs_fks_generator_compute_isr_kinematics -@ %def dag_chain_compress -@ Finalizer for [[dag_string_t]]. -<>= - procedure :: final => dag_string_final -<>= - subroutine dag_string_final (dag_string) - class (dag_string_t), intent (inout) :: dag_string - if (allocated (dag_string%t)) deallocate (dag_string%t) - dag_string%next => null () - end subroutine dag_string_final +@ %def phs_fks_generator_compute_isr_kinematics +@ +<>= + procedure :: final => phs_fks_generator_final +<>= + module subroutine phs_fks_generator_final (generator) + class(phs_fks_generator_t), intent(inout) :: generator + end subroutine phs_fks_generator_final +<>= + module subroutine phs_fks_generator_final (generator) + class(phs_fks_generator_t), intent(inout) :: generator + if (allocated (generator%emitters)) deallocate (generator%emitters) + if (associated (generator%real_kinematics)) & + nullify (generator%real_kinematics) + if (associated (generator%isr_kinematics)) & + nullify (generator%isr_kinematics) + if (allocated (generator%m2)) deallocate (generator%m2) + generator%massive_phsp = .false. + if (allocated (generator%is_massive)) deallocate (generator%is_massive) + generator%singular_jacobian = .false. + generator%i_fsr_first = -1 + if (allocated (generator%resonance_contributors)) & + deallocate (generator%resonance_contributors) + generator%mode = GEN_REAL_PHASE_SPACE + end subroutine phs_fks_generator_final -@ %def dag_string_final -@ Finalizer for [[dag_chain_t]]. -<>= - procedure :: final => dag_chain_final -<>= - subroutine dag_chain_final (dag_chain) - class (dag_chain_t), intent (inout) :: dag_chain - type (dag_string_t), pointer :: current - current => dag_chain%first - do while (associated (current)) - dag_chain%first => dag_chain%first%next - call current%final () - deallocate (current) - current => dag_chain%first - enddo - dag_chain%last => null () - end subroutine dag_chain_final +@ %def phs_fks_generator_final +@ A resonance phase space is uniquely specified via the resonance contributors and the +corresponding emitters. The [[phs_identifier]] type also checks whether +the given contributor-emitter configuration has already been evaluated to +avoid duplicate computations. +<>= + public :: phs_identifier_t +<>= + type :: phs_identifier_t + integer, dimension(:), allocatable :: contributors + integer :: emitter = -1 + logical :: evaluated = .false. + contains + <> + end type phs_identifier_t -@ %def dag_chain_final -<<[[cascades2_lexer_ut.f90]]>>= -<> +@ %def phs_identifier_t +@ +<>= + generic :: init => init_from_emitter, init_from_emitter_and_contributors + procedure :: init_from_emitter => phs_identifier_init_from_emitter + procedure :: init_from_emitter_and_contributors & + => phs_identifier_init_from_emitter_and_contributors +<>= + module subroutine phs_identifier_init_from_emitter (phs_id, emitter) + class(phs_identifier_t), intent(out) :: phs_id + integer, intent(in) :: emitter + end subroutine phs_identifier_init_from_emitter + module subroutine phs_identifier_init_from_emitter_and_contributors & + (phs_id, emitter, contributors) + class(phs_identifier_t), intent(out) :: phs_id + integer, intent(in) :: emitter + integer, intent(in), dimension(:) :: contributors + end subroutine phs_identifier_init_from_emitter_and_contributors +<>= + module subroutine phs_identifier_init_from_emitter (phs_id, emitter) + class(phs_identifier_t), intent(out) :: phs_id + integer, intent(in) :: emitter + phs_id%emitter = emitter + end subroutine phs_identifier_init_from_emitter -module cascades2_lexer_ut - use unit_tests - use cascades2_lexer_uti + module subroutine phs_identifier_init_from_emitter_and_contributors & + (phs_id, emitter, contributors) + class(phs_identifier_t), intent(out) :: phs_id + integer, intent(in) :: emitter + integer, intent(in), dimension(:) :: contributors + allocate (phs_id%contributors (size (contributors))) + phs_id%contributors = contributors + phs_id%emitter = emitter + end subroutine phs_identifier_init_from_emitter_and_contributors -<> +@ %def phs_identifier_init_from_emitter +@ %def phs_identifier_init_from_emitter_and_contributors +@ +<>= + procedure :: check => phs_identifier_check +<>= + module function phs_identifier_check & + (phs_id, emitter, contributors) result (check) + logical :: check + class(phs_identifier_t), intent(in) :: phs_id + integer, intent(in) :: emitter + integer, intent(in), dimension(:), optional :: contributors + end function phs_identifier_check +<>= + module function phs_identifier_check & + (phs_id, emitter, contributors) result (check) + logical :: check + class(phs_identifier_t), intent(in) :: phs_id + integer, intent(in) :: emitter + integer, intent(in), dimension(:), optional :: contributors + check = phs_id%emitter == emitter + if (present (contributors)) then + if (.not. allocated (phs_id%contributors)) & + call msg_fatal ("Phs identifier: contributors not allocated!") + check = check .and. all (phs_id%contributors == contributors) + end if + end function phs_identifier_check -<> +@ %def phs_identifier_check +@ +<>= + procedure :: write => phs_identifier_write +<>= + module subroutine phs_identifier_write (phs_id, unit) + class(phs_identifier_t), intent(in) :: phs_id + integer, intent(in), optional :: unit + end subroutine phs_identifier_write +<>= + module subroutine phs_identifier_write (phs_id, unit) + class(phs_identifier_t), intent(in) :: phs_id + integer, intent(in), optional :: unit + integer :: u, i + u = given_output_unit (unit); if (u < 0) return + write (u, '(A)') 'phs_identifier: ' + write (u, '(A,1X,I1)') 'Emitter: ', phs_id%emitter + if (allocated (phs_id%contributors)) then + write (u, '(A)', advance = 'no') 'Resonance contributors: ' + do i = 1, size (phs_id%contributors) + write (u, '(I1,1X)', advance = 'no') phs_id%contributors(i) + end do + else + write (u, '(A)') 'No Contributors allocated' + end if + end subroutine phs_identifier_write -contains +@ %def phs_identifier_write +@ +<>= + public :: check_for_phs_identifier +<>= + module subroutine check_for_phs_identifier & + (phs_id, n_in, emitter, contributors, phs_exist, i_phs) + type(phs_identifier_t), intent(in), dimension(:) :: phs_id + integer, intent(in) :: n_in, emitter + integer, intent(in), dimension(:), optional :: contributors + logical, intent(out) :: phs_exist + integer, intent(out) :: i_phs + end subroutine check_for_phs_identifier +<>= + module subroutine check_for_phs_identifier & + (phs_id, n_in, emitter, contributors, phs_exist, i_phs) + type(phs_identifier_t), intent(in), dimension(:) :: phs_id + integer, intent(in) :: n_in, emitter + integer, intent(in), dimension(:), optional :: contributors + logical, intent(out) :: phs_exist + integer, intent(out) :: i_phs + integer :: i + phs_exist = .false. + i_phs = -1 + do i = 1, size (phs_id) + if (phs_id(i)%emitter < 0) then + i_phs = i + exit + end if + phs_exist = phs_id(i)%emitter == emitter + if (present (contributors)) & + phs_exist = phs_exist .and. & + all (phs_id(i)%contributors == contributors) + if (phs_exist) then + i_phs = i + exit + end if + end do + end subroutine check_for_phs_identifier -<> +@ %def check_for_phs_identifier +@ +@ The fks phase space type contains the wood phase space and +separately the in- and outcoming momenta for the real process and the +corresponding Born momenta. Additionally, there are the variables +$\xi$,$\xi_{max}$, $y$ and $\phi$ which are used to create the real +phase space, as well as the jacobian and its corresponding soft and +collinear limit. Lastly, the array \texttt{ch\_to\_em} connects each +channel with an emitter. +<>= + public :: phs_fks_t +<>= + type, extends (phs_wood_t) :: phs_fks_t + integer :: mode = PHS_MODE_UNDEFINED + type(vector4_t), dimension(:), allocatable :: p_born + type(vector4_t), dimension(:), allocatable :: q_born + type(vector4_t), dimension(:), allocatable :: p_real + type(vector4_t), dimension(:), allocatable :: q_real + type(vector4_t), dimension(:), allocatable :: p_born_tot + type(phs_fks_generator_t) :: generator + real(default) :: r_isr + type(phs_identifier_t), dimension(:), allocatable :: phs_identifiers + contains + <> + end type phs_fks_t -end module cascades2_lexer_ut -@ %def cascades2_lexer_ut +@ %def phs_fks_t @ -<<[[cascades2_lexer_uti.f90]]>>= -<> +<>= -module cascades2_lexer_uti + interface compute_beta + module procedure compute_beta_massless + module procedure compute_beta_massive + end interface -<> -<> - use numeric_utils + interface get_xi_max_fsr + module procedure get_xi_max_fsr_massless + module procedure get_xi_max_fsr_massive + end interface - use cascades2_lexer +@ %def interfaces +@ +<>= + procedure :: write => phs_fks_write +<>= + module subroutine phs_fks_write (object, unit, verbose) + class(phs_fks_t), intent(in) :: object + integer, intent(in), optional :: unit + logical, intent(in), optional :: verbose + end subroutine phs_fks_write +<>= + module subroutine phs_fks_write (object, unit, verbose) + class(phs_fks_t), intent(in) :: object + integer, intent(in), optional :: unit + logical, intent(in), optional :: verbose + integer :: u, i, n_id + u = given_output_unit (unit) + call object%base_write () + n_id = size (object%phs_identifiers) + if (n_id == 0) then + write (u, "(A)") "No phs identifiers allocated! " + else + do i = 1, n_id + call object%phs_identifiers(i)%write (u) + end do + end if + end subroutine phs_fks_write -<> +@ %def phs_fks_write +@ Initializer for the phase space. Calls the initialization of the +corresponding Born phase space, sets up the +channel-emitter-association and allocates space for the momenta. +<>= + procedure :: init => phs_fks_init +<>= + module subroutine phs_fks_init (phs, phs_config) + class(phs_fks_t), intent(out) :: phs + class(phs_config_t), intent(in), target :: phs_config + end subroutine phs_fks_init +<>= + module subroutine phs_fks_init (phs, phs_config) + class(phs_fks_t), intent(out) :: phs + class(phs_config_t), intent(in), target :: phs_config -<> + call phs%base_init (phs_config) + select type (phs_config) + type is (phs_fks_config_t) + phs%config => phs_config + phs%forest = phs_config%forest + end select -contains + select type (phs) + type is (phs_fks_t) + select type (phs_config) + type is (phs_fks_config_t) + phs%mode = phs_config%mode + end select -<> + select case (phs%mode) + case (PHS_MODE_ADDITIONAL_PARTICLE) + phs%n_r_born = phs%config%n_par - 3 + case (PHS_MODE_COLLINEAR_REMNANT) + phs%n_r_born = phs%config%n_par - 1 + end select + end select + end subroutine phs_fks_init -end module cascades2_lexer_uti -@ %def cascades2_lexer_uti -@ API: driver for the unit tests below. -<>= - public :: cascades2_lexer_test -<>= - subroutine cascades2_lexer_test (u, results) - integer, intent(in) :: u - type(test_results_t), intent(inout) :: results - <> - end subroutine cascades2_lexer_test +@ %def phs_fks_init +@ For real components of $2\to 1$ NLO processes we have to recompute the +flux factor as this has to be the one of the underlying Born. +<>= + procedure :: compute_flux => phs_fks_compute_flux +<>= + module subroutine phs_fks_compute_flux (phs) + class(phs_fks_t), intent(inout) :: phs + end subroutine phs_fks_compute_flux +<>= + module subroutine phs_fks_compute_flux (phs) + class(phs_fks_t), intent(inout) :: phs + call phs%compute_base_flux () + select type (config => phs%config) + type is (phs_fks_config_t) + if (config%born_2_to_1) then + phs%flux = conv * twopi & + / (2 * config%sqrts ** 2 * phs%m_out(1) ** 2) + end if + end select + end subroutine phs_fks_compute_flux -@ %def cascades2_lexer_test +@ %def phs_fks_compute_flux @ -<>= - call test (cascades2_lexer_1, "cascades2_lexer_1", & - "make phase-space", u, results) -<>= - public :: cascades2_lexer_1 -<>= - subroutine cascades2_lexer_1 (u) - integer, intent(in) :: u - integer :: u_in = 8 - character (len=300) :: line - integer :: stat - logical :: fail - type (dag_string_t) :: dag_string - - write (u, "(A)") "* Test output: cascades2_lexer_1" - write (u, "(A)") "* Purpose: read lines of O'Mega's phase space output, translate" - write (u, "(A)") "* to dag_string, retranslate to character string and" - write (u, "(A)") "* compare" - write (u, "(A)") - - open (unit=u_in, file="cascades2_lexer_1.fds", status='old', action='read') +<>= + procedure :: allocate_momenta => phs_fks_allocate_momenta +<>= + module subroutine phs_fks_allocate_momenta (phs, phs_config, data_is_born) + class(phs_fks_t), intent(inout) :: phs + class(phs_config_t), intent(in) :: phs_config + logical, intent(in) :: data_is_born + end subroutine phs_fks_allocate_momenta +<>= + module subroutine phs_fks_allocate_momenta (phs, phs_config, data_is_born) + class(phs_fks_t), intent(inout) :: phs + class(phs_config_t), intent(in) :: phs_config + logical, intent(in) :: data_is_born + integer :: n_out_born + allocate (phs%p_born (phs_config%n_in)) + allocate (phs%p_real (phs_config%n_in)) + select case (phs%mode) + case (PHS_MODE_ADDITIONAL_PARTICLE) + if (data_is_born) then + n_out_born = phs_config%n_out + else + n_out_born = phs_config%n_out - 1 + end if + allocate (phs%q_born (n_out_born)) + allocate (phs%q_real (n_out_born + 1)) + allocate (phs%p_born_tot (phs_config%n_in + n_out_born)) + end select + end subroutine phs_fks_allocate_momenta - stat = 0 - fail = .false. - read (unit=u_in, fmt="(A)", iostat=stat) line - do while (stat == 0 .and. .not. fail) - read (unit=u_in, fmt="(A)", iostat=stat) line - if (stat /= 0) exit - dag_string = line - fail = (char(dag_string) /= line) - enddo - if (fail) then - write (u, "(A)") "* Test result: Test failed!" - else - write (u, "(A)") "* Test result: Test passed" - end if +@ %def phs_fks_allocate_momenta +@ Evaluate selected channel. First, the subroutine calls the +evaluation procedure of the underlying Born phase space, using $n_r - +3$ random numbers. Then, the remaining three random numbers are used +to create $\xi$, $y$ and $\phi$, from which the real momenta are +calculated from the Born momenta. +<>= + procedure :: evaluate_selected_channel => phs_fks_evaluate_selected_channel +<>= + module subroutine phs_fks_evaluate_selected_channel (phs, c_in, r_in) + class(phs_fks_t), intent(inout) :: phs + integer, intent(in) :: c_in + real(default), intent(in), dimension(:) :: r_in + end subroutine phs_fks_evaluate_selected_channel +<>= + module subroutine phs_fks_evaluate_selected_channel (phs, c_in, r_in) + class(phs_fks_t), intent(inout) :: phs + integer, intent(in) :: c_in + real(default), intent(in), dimension(:) :: r_in + integer :: n_in - close (u_in) - write (u, *) - write (u, "(A)") "* Test output end: cascades2_lexer_1" - end subroutine cascades2_lexer_1 + call phs%phs_wood_t%evaluate_selected_channel (c_in, r_in) + phs%r(:,c_in) = r_in -@ %def cascades2_lexer_1 -@%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{An alternative cascades module} -This module might replace the module [[cascades]], which generates -suitable phase space parametrizations and generates the phase space file. -The mappings, as well as the criteria to determine these, do not change. + phs%q_defined = phs%phs_wood_t%q_defined + if (.not. phs%q_defined) return -The advantage of this module is that it makes use of the [[O'Mega]] matrix -element generator which provides the relevant Feynman diagrams (the ones -which can be constructed only from 3-vertices). In principle, the -construction of these diagrams is also one of the tasks of the existing -[[cascades]] module, in which the diagrams would correspond to a set of -cascades. It starts by creating cascades which correspond to the -outgoing particles. These are combined to a new cascade using the -vertices of the model. In this way, since each cascade knows the -daughter cascades from which it is built, complete Feynman diagrams are -represented by sets of cascades, as soon as the existing cascades can be -recombined with the incoming particle(s). + select case (phs%mode) + case (PHS_MODE_ADDITIONAL_PARTICLE) + n_in = phs%config%n_in + phs%p_born = phs%phs_wood_t%p + phs%q_born = phs%phs_wood_t%q + phs%p_born_tot (1: n_in) = phs%p_born + phs%p_born_tot (n_in + 1 :) = phs%q_born + call phs%set_reference_frames (.true.) + call phs%set_isr_kinematics (.true.) + case (PHS_MODE_COLLINEAR_REMNANT) + call phs%compute_isr_kinematics (r_in(phs%n_r_born + 1)) + phs%r_isr = r_in(phs%n_r_born + 1) + end select + end subroutine phs_fks_evaluate_selected_channel -In this module, the Feynman diagrams are represented by the type -[[feyngraph_t]], which represents the Feynman diagrams as a tree of -nodes. The object which contains the necessary kinematical information -to determine mappings, and hence sensible phase space parametrizations -is of another type, called [[kingraph_t]], which is built from a -corresponding [[feyngraph]] object. +@ %def phs_fks_evaluate_selected_channel +@ +<>= + procedure :: evaluate_other_channels => phs_fks_evaluate_other_channels +<>= + module subroutine phs_fks_evaluate_other_channels (phs, c_in) + class(phs_fks_t), intent(inout) :: phs + integer, intent(in) :: c_in + end subroutine phs_fks_evaluate_other_channels +<>= + module subroutine phs_fks_evaluate_other_channels (phs, c_in) + class(phs_fks_t), intent(inout) :: phs + integer, intent(in) :: c_in + call phs%phs_wood_t%evaluate_other_channels (c_in) + phs%r_defined = .true. + end subroutine phs_fks_evaluate_other_channels -There are two types of output which can be produced by [[O'Mega]] and -are potentially relevant here. The first type contains all tree -diagrams for the process under consideration, where each line of the -output corresponds to one Feynman diagram. This output is easy to read, -but can be very large, depending on the number of particles involved in -the process. Moreover, it repeats substructures of the diagrams which -are part of more than one diagram. One could in principle work with -this output and construct a [[feyngraph]] from each line, if allowed, -i.e. if there are only 3-vertices. +@ %def phs_fks_evaluate_other_channels +@ +<>= + procedure :: get_mcpar => phs_fks_get_mcpar +<>= + module subroutine phs_fks_get_mcpar (phs, c, r) + class(phs_fks_t), intent(in) :: phs + integer, intent(in) :: c + real(default), dimension(:), intent(out) :: r + end subroutine phs_fks_get_mcpar +<>= + module subroutine phs_fks_get_mcpar (phs, c, r) + class(phs_fks_t), intent(in) :: phs + integer, intent(in) :: c + real(default), dimension(:), intent(out) :: r + r(1 : phs%n_r_born) = phs%r(1 : phs%n_r_born,c) + select case (phs%mode) + case (PHS_MODE_ADDITIONAL_PARTICLE) + r(phs%n_r_born + 1 :) = phs%r_real + case (PHS_MODE_COLLINEAR_REMNANT) + r(phs%n_r_born + 1 :) = phs%r_isr + end select + end subroutine phs_fks_get_mcpar -The other output contains also all of these Feynman diagrams, but in -a factorized form. This means that the substructures which appear in -several Feynman diagrams, are written only once, if possible. This -leads to a much shorter input file, which speeds up the parsing -process. Furthermore it makes it possible to reconstruct the -[[feyngraphs]] in such a way that the calculations concerning -subdiagrams which reappear in other [[feyngraphs]] have to be -performed only once. This is already the case in the existing -[[cascades]] module but can be exploited more efficiently here -because the possible graphs are well known from the input file, whereas -the [[cascades]] module would create a large number of [[cascades]] -which do not lead to a complete Feynman diagram of the given process. -<<[[cascades2.f90]]>>= -<> +@ %def phs_fks_get_mcpar +@ +<>= + procedure :: set_beam_energy => phs_fks_set_beam_energy +<>= + module subroutine phs_fks_set_beam_energy (phs) + class(phs_fks_t), intent(inout) :: phs + end subroutine phs_fks_set_beam_energy +<>= + module subroutine phs_fks_set_beam_energy (phs) + class(phs_fks_t), intent(inout) :: phs + call phs%generator%set_sqrts_hat (phs%config%sqrts) + end subroutine phs_fks_set_beam_energy -module cascades2 +@ %def phs_fks_set_beam_energy +@ +<>= + procedure :: set_emitters => phs_fks_set_emitters +<>= + module subroutine phs_fks_set_emitters (phs, emitters) + class(phs_fks_t), intent(inout) :: phs + integer, intent(in), dimension(:), allocatable :: emitters + end subroutine phs_fks_set_emitters +<>= + module subroutine phs_fks_set_emitters (phs, emitters) + class(phs_fks_t), intent(inout) :: phs + integer, intent(in), dimension(:), allocatable :: emitters + call phs%generator%set_emitters (emitters) + end subroutine phs_fks_set_emitters -<> - use kinds, only: TC, i8 -<> - use cascades2_lexer - use sorting - use flavors - use model_data - use iso_varying_string, string_t => varying_string - use io_units - use physics_defs, only: SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR - use phs_forests, only: phs_parameters_t - use diagnostics - use hashes - use cascades, only: phase_space_vanishes, MAX_WARN_RESONANCE - use, intrinsic :: iso_fortran_env, only : input_unit, output_unit, error_unit - use resonances, only: resonance_info_t - use resonances, only: resonance_history_t - use resonances, only: resonance_history_set_t +@ %def phs_fks_set_emitters +@ +<>= + procedure :: set_momenta => phs_fks_set_momenta +<>= + module subroutine phs_fks_set_momenta (phs, p) + class(phs_fks_t), intent(inout) :: phs + type(vector4_t), intent(in), dimension(:) :: p + end subroutine phs_fks_set_momenta +<>= + module subroutine phs_fks_set_momenta (phs, p) + class(phs_fks_t), intent(inout) :: phs + type(vector4_t), intent(in), dimension(:) :: p + integer :: n_in, n_tot_born + select case (phs%mode) + case (PHS_MODE_ADDITIONAL_PARTICLE) + n_in = phs%config%n_in; n_tot_born = phs%config%n_tot - 1 + phs%p_born = p(1 : n_in) + phs%q_born = p(n_in + 1 : n_tot_born) + phs%p_born_tot = p + end select + end subroutine phs_fks_set_momenta -<> +@ %def phs_fks_set_momenta +@ +<>= + procedure :: setup_masses => phs_fks_setup_masses +<>= + module subroutine phs_fks_setup_masses (phs, n_tot) + class(phs_fks_t), intent(inout) :: phs + integer, intent(in) :: n_tot + end subroutine phs_fks_setup_masses +<>= + module subroutine phs_fks_setup_masses (phs, n_tot) + class(phs_fks_t), intent(inout) :: phs + integer, intent(in) :: n_tot + call phs%generator%setup_masses (n_tot) + end subroutine phs_fks_setup_masses -<> +@ %def phs_fks_setup_masses +@ +<>= + procedure :: get_born_momenta => phs_fks_get_born_momenta +<>= + module subroutine phs_fks_get_born_momenta (phs, p) + class(phs_fks_t), intent(inout) :: phs + type(vector4_t), intent(out), dimension(:) :: p + end subroutine phs_fks_get_born_momenta +<>= + module subroutine phs_fks_get_born_momenta (phs, p) + class(phs_fks_t), intent(inout) :: phs + type(vector4_t), intent(out), dimension(:) :: p + select case (phs%mode) + case (PHS_MODE_ADDITIONAL_PARTICLE) + p(1 : phs%config%n_in) = phs%p_born + p(phs%config%n_in + 1 :) = phs%q_born + case (PHS_MODE_COLLINEAR_REMNANT) + p(1:phs%config%n_in) = phs%phs_wood_t%p + p(phs%config%n_in + 1 : ) = phs%phs_wood_t%q + end select + if (.not. phs%config%lab_is_cm) p = phs%lt_cm_to_lab * p + end subroutine phs_fks_get_born_momenta -<> +@ %def phs_fks_get_born_momenta +@ +<>= + procedure :: get_outgoing_momenta => phs_fks_get_outgoing_momenta +<>= + module subroutine phs_fks_get_outgoing_momenta (phs, q) + class(phs_fks_t), intent(in) :: phs + type(vector4_t), intent(out), dimension(:) :: q + end subroutine phs_fks_get_outgoing_momenta +<>= + module subroutine phs_fks_get_outgoing_momenta (phs, q) + class(phs_fks_t), intent(in) :: phs + type(vector4_t), intent(out), dimension(:) :: q + select case (phs%mode) + case (PHS_MODE_ADDITIONAL_PARTICLE) + q = phs%q_real + case (PHS_MODE_COLLINEAR_REMNANT) + q = phs%phs_wood_t%q + end select + end subroutine phs_fks_get_outgoing_momenta -<> +@ %def phs_fks_get_outgoing_momenta +@ +<>= + procedure :: get_incoming_momenta => phs_fks_get_incoming_momenta +<>= + module subroutine phs_fks_get_incoming_momenta (phs, p) + class(phs_fks_t), intent(in) :: phs + type(vector4_t), intent(inout), dimension(:), allocatable :: p + end subroutine phs_fks_get_incoming_momenta +<>= + module subroutine phs_fks_get_incoming_momenta (phs, p) + class(phs_fks_t), intent(in) :: phs + type(vector4_t), intent(inout), dimension(:), allocatable :: p + p = phs%p_real + end subroutine phs_fks_get_incoming_momenta -<> +@ %def phs_fks_get_incoming_momenta +@ +<>= + procedure :: set_isr_kinematics => phs_fks_set_isr_kinematics +<>= + module subroutine phs_fks_set_isr_kinematics (phs, requires_boost) + class(phs_fks_t), intent(inout) :: phs + logical, intent(in) :: requires_boost + end subroutine phs_fks_set_isr_kinematics +<>= + module subroutine phs_fks_set_isr_kinematics (phs, requires_boost) + class(phs_fks_t), intent(inout) :: phs + logical, intent(in) :: requires_boost + type(vector4_t), dimension(2) :: p + if (phs%generator%isr_kinematics%isr_mode == SQRTS_VAR) then + if (requires_boost) then + p = phs%lt_cm_to_lab & + * phs%generator%real_kinematics%p_born_cms%phs_point(1)%select ([1,2]) + else + p = phs%generator%real_kinematics%p_born_lab%phs_point(1)%select ([1,2]) + end if + call phs%generator%set_isr_kinematics (p) + end if + end subroutine phs_fks_set_isr_kinematics -contains +@ %def phs_fks_set_isr_kinematics +@ +<>= + procedure :: generate_radiation_variables => & + phs_fks_generate_radiation_variables +<>= + module subroutine phs_fks_generate_radiation_variables & + (phs, r_in, threshold) + class(phs_fks_t), intent(inout) :: phs + real(default), intent(in), dimension(:) :: r_in + logical, intent(in) :: threshold + end subroutine phs_fks_generate_radiation_variables +<>= + module subroutine phs_fks_generate_radiation_variables & + (phs, r_in, threshold) + class(phs_fks_t), intent(inout) :: phs + real(default), intent(in), dimension(:) :: r_in + logical, intent(in) :: threshold + type(vector4_t), dimension(:), allocatable :: p_born + if (size (r_in) /= 3) call msg_fatal & + ("Real kinematics need to be generated using three random numbers!") + select case (phs%mode) + case (PHS_MODE_ADDITIONAL_PARTICLE) + allocate (p_born (size (phs%p_born_tot))) + if (threshold) then + p_born = phs%get_onshell_projected_momenta () + else + p_born = phs%p_born_tot + if (.not. phs%lab_is_cm ()) & + p_born = inverse (phs%lt_cm_to_lab) * p_born + end if + call phs%generator%generate_radiation_variables & + (r_in, p_born, phs%phs_identifiers, threshold) + phs%r_real = r_in + end select + end subroutine phs_fks_generate_radiation_variables -<> +@ %def phs_fks_generate_radiation_variables +@ +<>= + procedure :: compute_xi_ref_momenta => phs_fks_compute_xi_ref_momenta +<>= + module subroutine phs_fks_compute_xi_ref_momenta (phs, p_in, contributors) + class(phs_fks_t), intent(inout) :: phs + type(vector4_t), intent(in), dimension(:), optional :: p_in + type(resonance_contributors_t), intent(in), dimension(:), optional :: & + contributors + end subroutine phs_fks_compute_xi_ref_momenta +<>= + module subroutine phs_fks_compute_xi_ref_momenta (phs, p_in, contributors) + class(phs_fks_t), intent(inout) :: phs + type(vector4_t), intent(in), dimension(:), optional :: p_in + type(resonance_contributors_t), intent(in), dimension(:), optional :: & + contributors + if (phs%mode == PHS_MODE_ADDITIONAL_PARTICLE) then + if (present (p_in)) then + call phs%generator%compute_xi_ref_momenta (p_in, contributors) + else + call phs%generator%compute_xi_ref_momenta & + (phs%p_born_tot, contributors) + end if + end if + end subroutine phs_fks_compute_xi_ref_momenta -end module cascades2 +@ %def phs_fks_compute_xi_ref_momenta +@ +<>= + procedure :: compute_xi_ref_momenta_threshold => & + phs_fks_compute_xi_ref_momenta_threshold +<>= + module subroutine phs_fks_compute_xi_ref_momenta_threshold (phs) + class(phs_fks_t), intent(inout) :: phs + end subroutine phs_fks_compute_xi_ref_momenta_threshold +<>= + module subroutine phs_fks_compute_xi_ref_momenta_threshold (phs) + class(phs_fks_t), intent(inout) :: phs + select case (phs%mode) + case (PHS_MODE_ADDITIONAL_PARTICLE) + call phs%generator%compute_xi_ref_momenta_threshold & + (phs%get_onshell_projected_momenta ()) + end select + end subroutine phs_fks_compute_xi_ref_momenta_threshold -@ %def cascades2 +@ %def phs_fks_compute_xi_ref_momenta @ -\subsection{Particle properties} -We define a type holding the properties of the particles which are needed -for parsing and finding the phase space parametrizations and mappings. -The properties of all particles which appear in the parsed -Feynman diagrams for the given process will be stored in a central place, -and only pointers to these objects are used. -<>= - type :: part_prop_t - character (len=LABEL_LEN) :: particle_label - integer :: pdg = 0 - real(default) :: mass = 0. - real :: width = 0. - integer :: spin_type = 0 - logical :: is_vector = .false. - logical :: empty = .true. - type (part_prop_t), pointer :: anti => null () - type (string_t) :: tex_name - contains - <> - end type part_prop_t +<>= + procedure :: compute_cms_energy => phs_fks_compute_cms_energy +<>= + module subroutine phs_fks_compute_cms_energy (phs) + class(phs_fks_t), intent(inout) :: phs + end subroutine phs_fks_compute_cms_energy +<>= + module subroutine phs_fks_compute_cms_energy (phs) + class(phs_fks_t), intent(inout) :: phs + if (phs%mode == PHS_MODE_ADDITIONAL_PARTICLE) & + call phs%generator%compute_cms_energy (phs%p_born_tot) + end subroutine phs_fks_compute_cms_energy -@ %def part_prop_t -@ The [[particle_label]] in [[part_prop_t]] is simply the particle name -(e.g. 'W+'). The corresponding variable in the type [[f_node_t]] contains -some additional information related to the external momenta, see below. -The length of the [[character]] variable is fixed as: -<>= - integer, parameter :: LABEL_LEN=30 -@ %def LABEL_LEN -<>= -procedure :: final => part_prop_final -<>= - subroutine part_prop_final (part) - class(part_prop_t), intent(inout) :: part - part%anti => null () - end subroutine part_prop_final +@ %def phs_fks_compute_cms_energy +@ When initial-state radiation is involved, either due to beamstrahlung or +QCD/QED corrections, it is important to have access to both the phase +space points in the center-of-mass and lab frame. +<>= + procedure :: set_reference_frames => phs_fks_set_reference_frames +<>= + module subroutine phs_fks_set_reference_frames (phs, is_cms) + class(phs_fks_t), intent(inout) :: phs + logical, intent(in) :: is_cms + end subroutine phs_fks_set_reference_frames +<>= + module subroutine phs_fks_set_reference_frames (phs, is_cms) + class(phs_fks_t), intent(inout) :: phs + logical, intent(in) :: is_cms + associate (real_kinematics => phs%generator%real_kinematics) + if (phs%config%lab_is_cm) then + real_kinematics%p_born_cms%phs_point(1) = phs%p_born_tot + real_kinematics%p_born_lab%phs_point(1) = phs%p_born_tot + else + if (is_cms) then + real_kinematics%p_born_cms%phs_point(1) & + = phs%p_born_tot + real_kinematics%p_born_lab%phs_point(1) & + = phs%lt_cm_to_lab * phs%p_born_tot + else + real_kinematics%p_born_cms%phs_point(1) & + = inverse (phs%lt_cm_to_lab) * phs%p_born_tot + real_kinematics%p_born_lab%phs_point(1) & + = phs%p_born_tot + end if + end if + end associate + end subroutine phs_fks_set_reference_frames -@ %def part_prop_final -@ -\subsection{The mapping modes} -The possible mappings are essentially the same as in [[cascades]], but we -introduce in addition the mapping constant [[NON_RESONANT]], which does -not refer to a new mapping; it corresponds to the nonresonant version of -a potentially resonant particle (or [[k_node]]). This becomes relevant -when we compare [[k_nodes]] to eliminate equivalences. -<>= - integer, parameter :: & - & NONRESONANT = -2, EXTERNAL_PRT = -1, & - & NO_MAPPING = 0, S_CHANNEL = 1, T_CHANNEL = 2, U_CHANNEL = 3, & - & RADIATION = 4, COLLINEAR = 5, INFRARED = 6, & - & STEP_MAPPING_E = 11, STEP_MAPPING_H = 12, & - & ON_SHELL = 99 -@ %def NONRESONANT EXTERNAL_PRT -@ %def NO_MAPPING S_CHANNEL T_CHANNEL U_CHANNEL -@ %def RADIATION COLLINEAR INFRARED -@ %def STEP_MAPPING_E STEP_MAPPING_H -@ %def ON_SHELL +@ %def phs_fks_set_reference_frames @ -\subsection{Grove properties} -The channels or [[kingraphs]] will be grouped in groves, i.e. sets of -channels, which share some characteristic numbers. These numbers are -stored in the following type: -<>= - type :: grove_prop_t - integer :: multiplicity = 0 - integer :: n_resonances = 0 - integer :: n_log_enhanced = 0 - integer :: n_off_shell = 0 - integer :: n_t_channel = 0 - integer :: res_hash = 0 - end type grove_prop_t +<>= + procedure :: i_phs_is_isr => phs_fks_i_phs_is_isr +<>= + module function phs_fks_i_phs_is_isr (phs, i_phs) result (is_isr) + logical :: is_isr + class(phs_fks_t), intent(in) :: phs + integer, intent(in) :: i_phs + end function phs_fks_i_phs_is_isr +<>= + module function phs_fks_i_phs_is_isr (phs, i_phs) result (is_isr) + logical :: is_isr + class(phs_fks_t), intent(in) :: phs + integer, intent(in) :: i_phs + is_isr = phs%phs_identifiers(i_phs)%emitter <= phs%generator%n_in + end function phs_fks_i_phs_is_isr -@ %def grove_prop_t +@ %def phs_fks_i_phs_is_isr @ -\subsection{The tree type} -This type contains all the information which is needed to -reconstruct a [[feyngraph]] or [[kingraph]]. We store bincodes, pdg codes -and mappings for all nodes of a valid [[kingraph]]. If we label the -external particles as given in the process definition with integer -numbers representing their position in the process definition, the bincode -would be the number that one obtains by setting the bit at the position -that is given by this number. If we combine two particles/nodes to a third -one (using a three-vertex of the given model), the bincode is the number which -one obtains by setting all the bits which are set for the two particles. -The [[pdg]] and [[mapping]] are simply the pdg-code and mapping at the -position (i.e. propagator or external particle) which is specified by the -corresponding bincode. We use [[tree_t]] not only for completed [[kingraphs]], -but also for all [[k_nodes]], which are a subtree of a [[kingraph]]. -<>= - type :: tree_t - integer(TC), dimension(:), allocatable :: bc - integer, dimension(:), allocatable :: pdg - integer, dimension(:), allocatable :: mapping - integer :: n_entries = 0 - logical :: keep = .true. - logical :: empty = .true. - contains - <> - end type tree_t +\subsection{Creation of the real phase space - FSR} +At this point, the Born phase space has been generated, as well as the +three random variables $\xi$, $y$ and $\phi$. The question is how the +real phase space is generated for a final-state emission +configuration. We work with two different sets of momenta, the Born +configuration $\Bigl\{ \bar{k}_{\oplus}, \bar{k}_{\ominus}, \bar{k}_{1}, ..., +\bar{k}_{n} \Bigr\}$ and the real configuration $\Bigl\{ k_{\oplus}, +k_{\ominus}, k_1,..., k_n, k_{n+1} \Bigr\}$. We define the momentum of +the emitter to be on the $n$-th position and the momentum of the +radiated particle to be at position $n+1$. The magnitude of the +spatial component of k is denoted by $\underline{k}$. -@ %def tree_t -<>= - procedure :: final => tree_final -<>= - subroutine tree_final (tree) - class (tree_t), intent (inout) :: tree - if (allocated (tree%bc)) deallocate (tree%bc) - if (allocated (tree%pdg)) deallocate (tree%pdg) - if (allocated (tree%mapping)) deallocate (tree%mapping) - end subroutine tree_final +For final-state emissions, it is $\bar{k}_\oplus = k_\oplus$ and +$\bar{k}_\ominus = k_\ominus$. Thus, the center-of-mass systems +coincide and it is +\begin{equation} + q = \sum_{i=1}^n \bar{k}_i = \sum_{i=1}^{n+1} k_i, +\end{equation} +with $\vec{q} = 0$ and $q^2 = \left(q^0\right)^2$. -@ %def tree_final -<>= - interface assignment (=) - module procedure tree_assign - end interface assignment (=) +We want to construct the real phase space from the Born phase space +using three random numbers. They are defined as follows: +\begin{itemize} +\item $\xi = \frac{2k_{n+1}^0}{\sqrt{s}} \in [0, \xi_{max}]$, where + $k_{n+1}$ denotes the four-momentum of the radiated particle. +\item $y = \cos\theta = \frac{\vec{k}_n \cdot + \vec{k}_{n+1}}{\underline{k}_n \underline{k}_{n+1}}$ is the + splitting angle. +\item The angle between tho two splitting particles in the transversal + plane, $phi \in [0,2\pi]$. +\end{itemize} +Further, $k_{rec} = \sum_{i=1}^{n-1} k_i$ denotes the sum of all +recoiling momenta. +<>= + generic :: generate_fsr => generate_fsr_default, generate_fsr_resonances +<>= + procedure :: generate_fsr_default => phs_fks_generator_generate_fsr_default +<>= + module subroutine phs_fks_generator_generate_fsr_default & + (generator, emitter, i_phs, & + p_born, p_real, xi_y_phi, no_jacobians) + class(phs_fks_generator_t), intent(inout) :: generator + integer, intent(in) :: emitter, i_phs + type(vector4_t), intent(in), dimension(:) :: p_born + type(vector4_t), intent(inout), dimension(:) :: p_real + real(default), intent(in), dimension(3), optional :: xi_y_phi + logical, intent(in), optional :: no_jacobians + end subroutine phs_fks_generator_generate_fsr_default +<>= + module subroutine phs_fks_generator_generate_fsr_default & + (generator, emitter, i_phs, & + p_born, p_real, xi_y_phi, no_jacobians) + class(phs_fks_generator_t), intent(inout) :: generator + integer, intent(in) :: emitter, i_phs + type(vector4_t), intent(in), dimension(:) :: p_born + type(vector4_t), intent(inout), dimension(:) :: p_real + real(default), intent(in), dimension(3), optional :: xi_y_phi + logical, intent(in), optional :: no_jacobians + real(default) :: q0 -<>= - subroutine tree_assign (tree1, tree2) - type (tree_t), intent (inout) :: tree1 - type (tree_t), intent (in) :: tree2 - if (allocated (tree2%bc)) then - allocate (tree1%bc(size(tree2%bc))) - tree1%bc = tree2%bc - end if - if (allocated (tree2%pdg)) then - allocate (tree1%pdg(size(tree2%pdg))) - tree1%pdg = tree2%pdg - end if - if (allocated (tree2%mapping)) then - allocate (tree1%mapping(size(tree2%mapping))) - tree1%mapping = tree2%mapping + call generator%generate_fsr_in (p_born, p_real) + q0 = sum (p_born(1:generator%n_in))**1 + generator%i_fsr_first = generator%n_in + 1 + call generator%generate_fsr_out (emitter, i_phs, p_born, p_real, q0, & + xi_y_phi = xi_y_phi, no_jacobians = no_jacobians) + if (debug_active (D_PHASESPACE)) then + call vector4_check_momentum_conservation (p_real, generator%n_in, & + rel_smallness = 1000 * tiny_07, abs_smallness = tiny_07) end if - tree1%n_entries = tree2%n_entries - tree1%keep = tree2%keep - tree1%empty = tree2%empty - end subroutine tree_assign + end subroutine phs_fks_generator_generate_fsr_default -@ %def tree_assign +@ %def phs_fks_generator_generate_fsr @ -\subsection{Add entries to the tree} -The following procedures fill the arrays in [[tree_t]] with entries -resulting from the bincode and mapping assignment. -<>= - procedure :: add_entry_from_numbers => tree_add_entry_from_numbers - procedure :: add_entry_from_node => tree_add_entry_from_node - generic :: add_entry => add_entry_from_numbers, add_entry_from_node -@ Here we add a single entry to each of the arrays. This will exclusively -be used for external particles. -<>= - subroutine tree_add_entry_from_numbers (tree, bincode, pdg, mapping) - class (tree_t), intent (inout) :: tree - integer(TC), intent (in) :: bincode - integer, intent (in) :: pdg - integer, intent (in) :: mapping - integer :: pos - if (tree%empty) then - allocate (tree%bc(1)) - allocate (tree%pdg(1)) - allocate (tree%mapping(1)) - pos = tree%n_entries + 1 - tree%bc(pos) = bincode - tree%pdg(pos) = pdg - tree%mapping(pos) = mapping - tree%n_entries = pos - tree%empty = .false. - end if - end subroutine tree_add_entry_from_numbers - -@ %def tree_add_entry_from_numbers -@ Here we merge two existing subtrees and a single entry (bc, pdg and -mapping). -<>= - subroutine tree_merge (tree, tree1, tree2, bc, pdg, mapping) - class (tree_t), intent (inout) :: tree - type (tree_t), intent (in) :: tree1, tree2 - integer(TC), intent (in) :: bc - integer, intent (in) :: pdg, mapping - integer :: tree_size - integer :: i1, i2 - if (tree%empty) then - i1 = tree1%n_entries - i2 = tree1%n_entries + tree2%n_entries - !! Proof: tree_size > 0 (always) - tree_size = tree1%n_entries + tree2%n_entries + 1 - allocate (tree%bc (tree_size)) - allocate (tree%pdg (tree_size)) - allocate (tree%mapping (tree_size)) - if (.not. tree1%empty) then - tree%bc(:i1) = tree1%bc - tree%pdg(:i1) = tree1%pdg - tree%mapping(:i1) = tree1%mapping - end if - if (.not. tree2%empty) then - tree%bc(i1+1:i2) = tree2%bc - tree%pdg(i1+1:i2) = tree2%pdg - tree%mapping(i1+1:i2) = tree2%mapping - end if - tree%bc(tree_size) = bc - tree%pdg(tree_size) = pdg - tree%mapping(tree_size) = mapping - tree%n_entries = tree_size - tree%empty = .false. - end if - end subroutine tree_merge +<>= + procedure :: generate_fsr_resonances => & + phs_fks_generator_generate_fsr_resonances +<>= + module subroutine phs_fks_generator_generate_fsr_resonances (generator, & + emitter, i_phs, i_con, p_born, p_real, xi_y_phi, no_jacobians) + class(phs_fks_generator_t), intent(inout) :: generator + integer, intent(in) :: emitter, i_phs + integer, intent(in) :: i_con + type(vector4_t), intent(in), dimension(:) :: p_born + type(vector4_t), intent(inout), dimension(:) :: p_real + real(default), intent(in), dimension(3), optional :: xi_y_phi + logical, intent(in), optional :: no_jacobians + end subroutine phs_fks_generator_generate_fsr_resonances +<>= + module subroutine phs_fks_generator_generate_fsr_resonances (generator, & + emitter, i_phs, i_con, p_born, p_real, xi_y_phi, no_jacobians) + class(phs_fks_generator_t), intent(inout) :: generator + integer, intent(in) :: emitter, i_phs + integer, intent(in) :: i_con + type(vector4_t), intent(in), dimension(:) :: p_born + type(vector4_t), intent(inout), dimension(:) :: p_real + real(default), intent(in), dimension(3), optional :: xi_y_phi + logical, intent(in), optional :: no_jacobians + integer, dimension(:), allocatable :: resonance_list + integer, dimension(size(p_born)) :: inv_resonance_list + type(vector4_t), dimension(:), allocatable :: p_tmp_born + type(vector4_t), dimension(:), allocatable :: p_tmp_real + type(vector4_t) :: p_resonance + real(default) :: q0 + integer :: i, j, nlegborn, nlegreal + integer :: i_emitter + type(lorentz_transformation_t) :: boost_to_resonance + integer :: n_resonant_particles + if (debug_on) call msg_debug2 (D_PHASESPACE, "phs_fks_generator_generate_fsr_resonances") + nlegborn = size (p_born); nlegreal = nlegborn + 1 + allocate (resonance_list (size (generator%resonance_contributors(i_con)%c))) + resonance_list = generator%resonance_contributors(i_con)%c + n_resonant_particles = size (resonance_list) -@ %def tree_merge -@ Here we add entries to a tree for a given [[k_node]], which means that -we first have to determine whether the node is external or internal. -The arrays are sorted after the entries have been added (see below for -details). -<>= - subroutine tree_add_entry_from_node (tree, node) - class (tree_t), intent (inout) :: tree - type (k_node_t), intent (in) :: node - integer :: pdg - if (node%t_line) then - pdg = abs (node%particle%pdg) - else - pdg = node%particle%pdg - end if - if (associated (node%daughter1) .and. & - associated (node%daughter2)) then - call tree_merge (tree, node%daughter1%subtree, & - node%daughter2%subtree, node%bincode, & - node%particle%pdg, node%mapping) + if (.not. any (resonance_list == emitter)) then + call msg_fatal ("Emitter must be included in the resonance list!") else - call tree_add_entry_from_numbers (tree, node%bincode, & - node%particle%pdg, node%mapping) + do i = 1, n_resonant_particles + if (resonance_list (i) == emitter) i_emitter = i + end do end if - call tree%sort () - end subroutine tree_add_entry_from_node - -@ %def tree_add_entry_from_node -@ For a well-defined order of the elements of the arrays in [[tree_t]], -the elements can be sorted. The bincodes (entries of [[bc]]) are -simply ordered by size, the [[pdg]] and [[mapping]] entries go to the -positions of the corresponding [[bc]] values. -<>= - procedure :: sort => tree_sort -<>= - subroutine tree_sort (tree) - class (tree_t), intent (inout) :: tree - integer(TC), dimension(size(tree%bc)) :: bc_tmp - integer, dimension(size(tree%pdg)) :: pdg_tmp, mapping_tmp - integer, dimension(1) :: pos - integer :: i - bc_tmp = tree%bc - pdg_tmp = tree%pdg - mapping_tmp = tree%mapping - do i = size(tree%bc),1,-1 - pos = maxloc (bc_tmp) - tree%bc(i) = bc_tmp (pos(1)) - tree%pdg(i) = pdg_tmp (pos(1)) - tree%mapping(i) = mapping_tmp (pos(1)) - bc_tmp(pos(1)) = 0 - end do - end subroutine tree_sort - -@ %def tree_sort -@ -\subsection{Graph types} -We define an abstract type which will give rise to two different types: -The type [[feyngraph_t]] contains the pure information of the -corresponding Feynman diagram, but also a list of objects of the -[[kingraph]] type which contain the kinematically relevant data for the -mapping calculation as well as the mappings themselves. Every graph -should have an index which is unique. Graphs which are not needed any -more can be disabled by setting the [[keep]] variable to [[false]]. -<>= - type, abstract :: graph_t - integer :: index = 0 - integer :: n_nodes = 0 - logical :: keep = .true. - end type graph_t -@ %def graph_t -@ This is the type representing the Feynman diagrams which are read from -an input file created by O'Mega. It is a tree of nodes, which we call -[[f_nodes]], so that [[feyngraph_t]] contains a pointer to the root of -this tree, and each node can have two daughter nodes. The case of only -one associated daughter should never appear, because in the method of -phase space parametrization which is used here, we combine always two -particle momenta to a third one. The [[feyngraphs]] will be arranged in -a linked list. This is why we have a pointer to the next graph. The -[[kingraphs]] on the other hand are arranged in linked lists which are -attached to the corresponding [[feyngraph]]. In general, a [[feyngraph]] -can give rise to more than one [[kingraph]] because we make a copy -every time a particle can be resonant, so that in the copy we keep -the particle nonresonant. -<>= - type, extends (graph_t) :: feyngraph_t - type (string_t) :: omega_feyngraph_output - type (f_node_t), pointer :: root => null () - type (feyngraph_t), pointer :: next => null() - type (kingraph_t), pointer :: kin_first => null () - type (kingraph_t), pointer :: kin_last => null () - contains - <> - end type feyngraph_t + inv_resonance_list = & + create_inverse_resonance_list (nlegborn, resonance_list) -@ %def feyngraph_t -@ A container for a pointer of type [[feyngraph_t]]. This is used to -realize arrays of these pointers. -<>= - type :: feyngraph_ptr_t - type (feyngraph_t), pointer :: graph => null () - end type feyngraph_ptr_t + allocate (p_tmp_born (n_resonant_particles)) + allocate (p_tmp_real (n_resonant_particles + 1)) + p_tmp_born = vector4_null + p_tmp_real = vector4_null + j = 1 + do i = 1, n_resonant_particles + p_tmp_born(j) = p_born(resonance_list(i)) + j = j + 1 + end do -@ %def feyngraph_ptr_t -@ -The length of a string describing a Feynman diagram which is produced by -O'Mega is fixed by the parameter -<>= - integer, parameter :: FEYNGRAPH_LEN=300 -@ %def feyngraph_len -<>= - procedure :: final => feyngraph_final -<>= - subroutine feyngraph_final (graph) - class(feyngraph_t), intent(inout) :: graph - type (kingraph_t), pointer :: current - graph%root => null () - graph%kin_last => null () - do while (associated (graph%kin_first)) - current => graph%kin_first - graph%kin_first => graph%kin_first%next - call current%final () - deallocate (current) - enddo - end subroutine feyngraph_final + call generator%generate_fsr_in (p_born, p_real) -@ %def feyngraph_final -This is the type of graph which is used to find the phase space channels, -or in other words, each kingraph could correspond to a channel, if it is -not eliminated for kinematical reasons or due to an equivalence. For the -linked list which is attached to the corresponding [[feyngraph]], we -need the [[next]] pointer, whereas [[grove_next]] points to the next -[[kingraph]] within a grove. The information which is relevant for the -specification of a channel is stored in [[tree]]. We use [[grove_prop]] -to sort the [[kingraph]] in a grove in which all [[kingraphs]] are -characterized by the numbers contained in [[grove_prop]]. Later these -groves are further subdevided using the resonance hash. A [[kingraph]] -which is constructed directly from the output of O'Mega, is not -[[inverse]]. In this case the first incoming particle is the root ofthe -tree. In a scattering process, we can also construct a [[kingraph]] -where the root of the tree is the second incoming particle. In this -case the value of [[inverse]] is [[.true.]]. -<>= - type, extends (graph_t) :: kingraph_t - type (k_node_t), pointer :: root => null () - type (kingraph_t), pointer :: next => null() - type (kingraph_t), pointer :: grove_next => null () - type (tree_t) :: tree - type (grove_prop_t) :: grove_prop - logical :: inverse = .false. - integer :: prc_component = 0 - contains - <> - end type kingraph_t + p_resonance = generator%real_kinematics%xi_ref_momenta(i_con) + q0 = p_resonance**1 -@ %def kingraph_t -@ Another container for a pointer to emulate arrays of pointers: -<>= - type :: kingraph_ptr_t - type (kingraph_t), pointer :: graph => null () - end type kingraph_ptr_t + boost_to_resonance = inverse (boost (p_resonance, q0)) + p_tmp_born = boost_to_resonance * p_tmp_born -@ %def kingraph_ptr_t -@ -<>= - procedure :: final => kingraph_final -<>= - subroutine kingraph_final (graph) - class(kingraph_t), intent(inout) :: graph - graph%root => null () - graph%next => null () - graph%grove_next => null () - call graph%tree%final () - end subroutine kingraph_final + generator%i_fsr_first = 1 + call generator%generate_fsr_out (emitter, i_phs, p_tmp_born, p_tmp_real, & + q0, i_emitter, xi_y_phi) + p_tmp_real = inverse (boost_to_resonance) * p_tmp_real -@ %def kingraph_final -@ -\subsection{The node types} -We define an abstract type containing variables which are needed for -[[f_node_t]] as well as [[k_node_t]]. We say that a node is on the -t-line if it lies between the two nodes which correspond to the two -incoming particles. [[incoming]] and [[tline]] are used only for -scattering processes and remain [[.false.]] in decay processes. The -variable [[n_subtree_nodes]] holds the number of nodes (including the -node itself) of the subtree of which the node is the root. -<>= - type, abstract :: node_t - type (part_prop_t), pointer :: particle => null () - logical :: incoming = .false. - logical :: t_line = .false. - integer :: index = 0 - logical :: keep = .true. - integer :: n_subtree_nodes = 1 - end type node_t + do i = generator%n_in + 1, nlegborn + if (any (resonance_list == i)) then + p_real(i) = p_tmp_real(inv_resonance_list (i)) + else + p_real(i) = p_born (i) + end if + end do + p_real(nlegreal) = p_tmp_real (n_resonant_particles + 1) -@ %def node_t -@ We use two different list types for the different kinds of nodes. We -therefore start with an abstract type: -<>= - type, abstract :: list_t - integer :: n_entries = 0 - end type list_t + if (debug_active (D_PHASESPACE)) then + call vector4_check_momentum_conservation (p_real, generator%n_in, & + rel_smallness = 1000 * tiny_07, abs_smallness = tiny_07) + end if -@ %def list_t -@ Since the contents of the lists are different, we introduce two -different entry types. Since the trees of nodes use pointers, the nodes -should only be allocated by a type-bound procedure of the corresponding -list type, such that we can keep track of all nodes, eventually reuse -and in the end deallocate nodes correctly, without forgetting any nodes. -Here is the type for the [[k_nodes]]. The list is a linked list. We want -to reuse (recycle) the [[k_nodes]] which are neither [[incoming]] nore -[[t_line]]. -<>= - type :: k_node_entry_t - type (k_node_t), pointer :: node => null () - type (k_node_entry_t), pointer :: next => null () - logical :: recycle = .false. - contains - <> - end type k_node_entry_t + contains -@ %def k_node_entry_t -<>= - procedure :: final => k_node_entry_final -<>= - subroutine k_node_entry_final (entry) - class(k_node_entry_t), intent(inout) :: entry - if (associated (entry%node)) then - call entry%node%final - deallocate (entry%node) - end if - entry%next => null () - end subroutine k_node_entry_final + function create_inverse_resonance_list (nlegborn, resonance_list) & + result (inv_resonance_list) + integer, intent(in) :: nlegborn + integer, intent(in), dimension(:) :: resonance_list + integer, dimension(nlegborn) :: inv_resonance_list + integer :: i, j + inv_resonance_list = 0 + j = 1 + do i = 1, nlegborn + if (any (i == resonance_list)) then + inv_resonance_list (i) = j + j = j + 1 + end if + end do + end function create_inverse_resonance_list -@ %def k_node_entry_final -<>= - procedure :: write => k_node_entry_write -<>= - subroutine k_node_entry_write (k_node_entry, u) - class (k_node_entry_t), intent (in) :: k_node_entry - integer, intent (in) :: u - end subroutine k_node_entry_write + function boosted_energy () result (E) + real(default) :: E + type(vector4_t) :: p_boost + p_boost = boost_to_resonance * p_resonance + E = p_boost%p(0) + end function boosted_energy + end subroutine phs_fks_generator_generate_fsr_resonances -@ %def k_node_entry_write -@ Here is the list type for [[k_nodes]]. A [[k_node_list]] can be -declared to be an observer. In this case it does not create any nodes by -itself, but the entries set their pointers to existing nodes. In this -way we can use the list structure and the type bound procedures for -existing nodes. -<>= - type, extends (list_t) :: k_node_list_t - type (k_node_entry_t), pointer :: first => null () - type (k_node_entry_t), pointer :: last => null () - integer :: n_recycle - logical :: observer = .false. - contains - <> - end type k_node_list_t +@ %def phs_fks_generator_generate_fsr_resonances +@ +<>= + procedure :: generate_fsr_threshold => & + phs_fks_generator_generate_fsr_threshold +<>= + module subroutine phs_fks_generator_generate_fsr_threshold (generator, & + emitter, i_phs, p_born, p_real, xi_y_phi) + class(phs_fks_generator_t), intent(inout) :: generator + integer, intent(in) :: emitter, i_phs + type(vector4_t), intent(in), dimension(:) :: p_born + type(vector4_t), intent(inout), dimension(:) :: p_real + real(default), intent(in), dimension(3), optional :: xi_y_phi + end subroutine phs_fks_generator_generate_fsr_threshold +<>= + module subroutine phs_fks_generator_generate_fsr_threshold (generator, & + emitter, i_phs, p_born, p_real, xi_y_phi) + class(phs_fks_generator_t), intent(inout) :: generator + integer, intent(in) :: emitter, i_phs + type(vector4_t), intent(in), dimension(:) :: p_born + type(vector4_t), intent(inout), dimension(:) :: p_real + real(default), intent(in), dimension(3), optional :: xi_y_phi + type(vector4_t), dimension(2) :: p_tmp_born + type(vector4_t), dimension(3) :: p_tmp_real + integer :: nlegborn, nlegreal + type(vector4_t) :: p_top + real(default) :: q0 + type(lorentz_transformation_t) :: boost_to_top + integer :: leg, other_leg + real(default) :: sqrts, mtop + if (debug_on) call msg_debug2 & + (D_PHASESPACE, "phs_fks_generator_generate_fsr_resonances") + nlegborn = size (p_born); nlegreal = nlegborn + 1 -@ %def k_node_list_t -<>= - procedure :: final => k_node_list_final -<>= - subroutine k_node_list_final (list) - class(k_node_list_t), intent(inout) :: list - type (k_node_entry_t), pointer :: current - do while (associated (list%first)) - current => list%first - list%first => list%first%next - if (list%observer) current%node => null () - call current%final () - deallocate (current) - enddo - end subroutine k_node_list_final + leg = thr_leg(emitter); other_leg = 3 - leg -@ %def k_node_list_final -@ The [[f_node_t]] type contains the [[particle_label]] variable which is -extracted from the input file. It consists not only of the particle -name, but also of some numbers in brackets. These numbers indicate which -external particles are part of the subtree of this node. The [[f_node]] -contains also a list of [[k_nodes]]. Therefore, if the nodes are not -[[incoming]] or [[t_line]], the mapping calculations for these -[[k_nodes]] which can appear in several [[kingraphs]] have to be -performed only once. -<>= - type, extends (node_t) :: f_node_t - type (f_node_t), pointer :: daughter1 => null () - type (f_node_t), pointer :: daughter2 => null () - character (len=LABEL_LEN) :: particle_label - type (k_node_list_t) :: k_node_list - contains - <> - end type f_node_t + p_tmp_born(1) = p_born (ass_boson(leg)) + p_tmp_born(2) = p_born (ass_quark(leg)) -@ %def f_node_t -@ The finalizer nullifies the daughter pointers, since they are -deallocated, like the [[f_node]] itself, with the finalizer of the -[[f_node_list]]. -<>= - procedure :: final => f_node_final -<>= - recursive subroutine f_node_final (node) - class(f_node_t), intent(inout) :: node - call node%k_node_list%final () - node%daughter1 => null () - node%daughter2 => null () - end subroutine f_node_final + call generator%generate_fsr_in (p_born, p_real) -@ %def f_node_final -@ Finaliser for [[f_node_entry]]. -<>= - procedure :: final => f_node_entry_final -<>= - subroutine f_node_entry_final (entry) - class(f_node_entry_t), intent(inout) :: entry - if (associated (entry%node)) then - call entry%node%final () - deallocate (entry%node) - end if - entry%next => null () - end subroutine f_node_entry_final + p_top = generator%real_kinematics%xi_ref_momenta(leg) -@ %def f_node_entry_final -@ Set index if not yet done, i.e. if it is zero. -<>= - procedure :: set_index => f_node_set_index -<>= - subroutine f_node_set_index (f_node) - class (f_node_t), intent (inout) :: f_node - integer, save :: counter = 0 - if (f_node%index == 0) then - counter = counter + 1 - f_node%index = counter + q0 = p_top**1 + sqrts = two * p_born(1)%p(0) + mtop = m1s_to_mpole (sqrts) + if (sqrts**2 - four * mtop**2 > zero) then + boost_to_top = inverse (boost (p_top, q0)) + else + boost_to_top = identity end if - end subroutine f_node_set_index + p_tmp_born = boost_to_top * p_tmp_born -@ %def f_node_set_index -@ -Type for the nodes of the tree (lines of the Feynman diagrams). We also need a type containing a -pointer to a node, which is needed for creating arrays of pointers. This will be used for scattering -processes where we can take either the first or the second particle to be the root of the tree. Since -we need both cases for the calculations and O'Mega only gives us one of these, we have to perform a -transformation of the graph in which some nodes (on the line which we hereafter call t-line) need -to know their mother and sister nodes, which become their daughters within this transformation. -<>= - type :: f_node_ptr_t - type (f_node_t), pointer :: node => null () - contains - <> - end type f_node_ptr_t + generator%i_fsr_first = 1 + call generator%generate_fsr_out (emitter, i_phs, p_tmp_born, & + p_tmp_real, q0, 2, xi_y_phi) + p_tmp_real = inverse (boost_to_top) * p_tmp_real -@ %def f_node_ptr_t -<>= - procedure :: final => f_node_ptr_final -<>= - subroutine f_node_ptr_final (f_node_ptr) - class (f_node_ptr_t), intent (inout) :: f_node_ptr - f_node_ptr%node => null () - end subroutine f_node_ptr_final + p_real(ass_boson(leg)) = p_tmp_real(1) + p_real(ass_quark(leg)) = p_tmp_real(2) + p_real(ass_boson(other_leg)) = p_born(ass_boson(other_leg)) + p_real(ass_quark(other_leg)) = p_born(ass_quark(other_leg)) + p_real(THR_POS_GLUON) = p_tmp_real(3) -@ %def f_node_ptr_final -<>= - interface assignment (=) - module procedure f_node_ptr_assign - end interface assignment (=) -<>= - subroutine f_node_ptr_assign (ptr1, ptr2) - type (f_node_ptr_t), intent (out) :: ptr1 - type (f_node_ptr_t), intent (in) :: ptr2 - ptr1%node => ptr2%node - end subroutine f_node_ptr_assign + end subroutine phs_fks_generator_generate_fsr_threshold -@ %def f_node_ptr_assign +@ %def phs_fks_generator_generate_fsr_threshold @ -<>= - type :: k_node_ptr_t - type (k_node_t), pointer :: node => null () - end type k_node_ptr_t +<>= + procedure :: generate_fsr_in => phs_fks_generator_generate_fsr_in +<>= + module subroutine phs_fks_generator_generate_fsr_in & + (generator, p_born, p_real) + class(phs_fks_generator_t), intent(inout) :: generator + type(vector4_t), intent(in), dimension(:) :: p_born + type(vector4_t), intent(inout), dimension(:) :: p_real + end subroutine phs_fks_generator_generate_fsr_in +<>= + module subroutine phs_fks_generator_generate_fsr_in & + (generator, p_born, p_real) + class(phs_fks_generator_t), intent(inout) :: generator + type(vector4_t), intent(in), dimension(:) :: p_born + type(vector4_t), intent(inout), dimension(:) :: p_real + integer :: i + do i = 1, generator%n_in + p_real(i) = p_born(i) + end do + end subroutine phs_fks_generator_generate_fsr_in -@ %def k_node_ptr_t +@ %def phs_fks_generator_generate_fsr_in @ -<>= - type, extends (node_t) :: k_node_t - type (k_node_t), pointer :: daughter1 => null () - type (k_node_t), pointer :: daughter2 => null () - type (k_node_t), pointer :: inverse_daughter1 => null () - type (k_node_t), pointer :: inverse_daughter2 => null () - type (f_node_t), pointer :: f_node => null () - type (tree_t) :: subtree - real (default) :: ext_mass_sum = 0. - real (default) :: effective_mass = 0. - logical :: resonant = .false. - logical :: on_shell = .false. - logical :: log_enhanced = .false. - integer :: mapping = NO_MAPPING - integer(TC) :: bincode = 0 - logical :: mapping_assigned = .false. - logical :: is_nonresonant_copy = .false. - logical :: subtree_checked = .false. - integer :: n_off_shell = 0 - integer :: n_log_enhanced = 0 - integer :: n_resonances = 0 - integer :: multiplicity = 0 - integer :: n_t_channel = 0 - integer :: f_node_index = 0 - contains - <> - end type k_node_t +<>= + procedure :: generate_fsr_out => phs_fks_generator_generate_fsr_out +<>= + module subroutine phs_fks_generator_generate_fsr_out (generator, & + emitter, i_phs, p_born, p_real, q0, p_emitter_index, & + xi_y_phi, no_jacobians) + class(phs_fks_generator_t), intent(inout) :: generator + integer, intent(in) :: emitter, i_phs + type(vector4_t), intent(in), dimension(:) :: p_born + type(vector4_t), intent(inout), dimension(:) :: p_real + real(default), intent(in) :: q0 + integer, intent(in), optional :: p_emitter_index + real(default), intent(in), dimension(3), optional :: xi_y_phi + logical, intent(in), optional :: no_jacobians + end subroutine phs_fks_generator_generate_fsr_out +<>= + module subroutine phs_fks_generator_generate_fsr_out (generator, & + emitter, i_phs, p_born, p_real, q0, p_emitter_index, & + xi_y_phi, no_jacobians) + class(phs_fks_generator_t), intent(inout) :: generator + integer, intent(in) :: emitter, i_phs + type(vector4_t), intent(in), dimension(:) :: p_born + type(vector4_t), intent(inout), dimension(:) :: p_real + real(default), intent(in) :: q0 + integer, intent(in), optional :: p_emitter_index + real(default), intent(in), dimension(3), optional :: xi_y_phi + logical, intent(in), optional :: no_jacobians + real(default) :: xi, y, phi + integer :: nlegborn, nlegreal + real(default) :: uk_np1, uk_n + real(default) :: uk_rec, k_rec0 + type(vector3_t) :: k_n_born, k + real(default) :: uk_n_born, uk, k2, k0_n + real(default) :: cpsi, beta + type(vector3_t) :: vec, vec_orth + type(lorentz_transformation_t) :: rot + integer :: i, p_em + logical :: compute_jac + p_em = emitter; if (present (p_emitter_index)) p_em = p_emitter_index + compute_jac = .true. + if (present (no_jacobians)) compute_jac = .not. no_jacobians + if (generator%i_fsr_first < 0) & + call msg_fatal ("FSR generator is called for outgoing particles but "& + &"i_fsr_first is not set!") -@ %def k_node_t -@ -Subroutine for [[k_node]] assignment. -<>= - interface assignment (=) - module procedure k_node_assign - end interface assignment (=) -<>= - subroutine k_node_assign (k_node1, k_node2) - type (k_node_t), intent (inout) :: k_node1 - type (k_node_t), intent (in) :: k_node2 - k_node1%f_node => k_node2%f_node - k_node1%particle => k_node2%particle - k_node1%incoming = k_node2%incoming - k_node1%t_line = k_node2%t_line - k_node1%keep = k_node2%keep - k_node1%n_subtree_nodes = k_node2%n_subtree_nodes - k_node1%ext_mass_sum = k_node2%ext_mass_sum - k_node1%effective_mass = k_node2%effective_mass - k_node1%resonant = k_node2%resonant - k_node1%on_shell = k_node2%on_shell - k_node1%log_enhanced = k_node2%log_enhanced - k_node1%mapping = k_node2%mapping - k_node1%bincode = k_node2%bincode - k_node1%mapping_assigned = k_node2%mapping_assigned - k_node1%is_nonresonant_copy = k_node2%is_nonresonant_copy - k_node1%n_off_shell = k_node2%n_off_shell - k_node1%n_log_enhanced = k_node2%n_log_enhanced - k_node1%n_resonances = k_node2%n_resonances - k_node1%multiplicity = k_node2%multiplicity - k_node1%n_t_channel = k_node2%n_t_channel - k_node1%f_node_index = k_node2%f_node_index - end subroutine k_node_assign + if (present (xi_y_phi)) then + xi = xi_y_phi(I_XI) + y = xi_y_phi(I_Y) + phi = xi_y_phi(I_PHI) + else + associate (rad_var => generator%real_kinematics) + xi = rad_var%xi_tilde + if (rad_var%supply_xi_max) xi = xi * rad_var%xi_max(i_phs) + y = rad_var%y(i_phs) + phi = rad_var%phi + end associate + end if -@ %def k_node_assign -@ The finalizer of [[k_node_t]] nullifies all pointers to nodes, since the -deallocation of these nodes takes place in the finalizer of the list by which -they were created. -<>= - procedure :: final => k_node_final -<>= - recursive subroutine k_node_final (k_node) - class(k_node_t), intent(inout) :: k_node - k_node%daughter1 => null () - k_node%daughter2 => null () - k_node%inverse_daughter1 => null () - k_node%inverse_daughter2 => null () - k_node%f_node => null () - end subroutine k_node_final + nlegborn = size (p_born) + nlegreal = nlegborn + 1 + generator%E_gluon = q0 * xi / two + uk_np1 = generator%E_gluon + k_n_born = p_born(p_em)%p(1:3) + uk_n_born = k_n_born**1 -@ %def k_node_final -@ Set an index to a [[k_node]], if not yet done, i.e. if it is zero. The -indices are simply positive integer numbers starting from 1. -<>= - procedure :: set_index => k_node_set_index -<>= - subroutine k_node_set_index (k_node) - class (k_node_t), intent (inout) :: k_node - integer, save :: counter = 0 - if (k_node%index == 0) then - counter = counter + 1 - k_node%index = counter + generator%mrec2 = (q0 - p_born(p_em)%p(0))**2 & + - space_part_norm(p_born(p_em))**2 + if (generator%is_massive(emitter)) then + call generator%compute_emitter_kinematics (y, emitter, & + i_phs, q0, k0_n, uk_n, uk, compute_jac) + else + call generator%compute_emitter_kinematics (y, q0, uk_n, uk) + generator%real_kinematics%y_soft(i_phs) = y + k0_n = uk_n end if - end subroutine k_node_set_index -@ %def k_node_set_index -@ The process type (decay or scattering) is given by an integer which is -equal to the number of incoming particles. -<>= - public :: DECAY, SCATTERING -<>= - integer, parameter :: DECAY=1, SCATTERING=2 + if (debug_on) call msg_debug2 & + (D_PHASESPACE, "phs_fks_generator_generate_fsr_out") + call debug_input_values () -@ %def decay scattering -@ The entries of the [[f_node_list]] contain the substring of the input -file from which the node's subtree will be constructed (or a modified -string containing placeholders for substrings). We use the -length of this string for fast comparison to find the nodes in the -[[f_node_list]] which we want to reuse. -<>= - type :: f_node_entry_t - character (len=FEYNGRAPH_LEN) :: subtree_string - integer :: string_len = 0 - type (f_node_t), pointer :: node => null () - type (f_node_entry_t), pointer :: next => null () - integer :: subtree_size = 0 - contains - <> - end type f_node_entry_t + vec = uk_n / uk_n_born * k_n_born + vec_orth = create_orthogonal (vec) + p_real(p_em)%p(0) = k0_n + p_real(p_em)%p(1:3) = vec%p(1:3) + cpsi = (uk_n**2 + uk**2 - uk_np1**2) / (two * uk_n * uk) + !!! This is to catch the case where cpsi = 1, but numerically + !!! turns out to be slightly larger than 1. + call check_cpsi_bound (cpsi) + rot = rotation (cpsi, - sqrt (one - cpsi**2), vec_orth) + p_real(p_em) = rot * p_real(p_em) + vec = uk_np1 / uk_n_born * k_n_born + vec_orth = create_orthogonal (vec) + p_real(nlegreal)%p(0) = uk_np1 + p_real(nlegreal)%p(1:3) = vec%p(1:3) + cpsi = (uk_np1**2 + uk**2 - uk_n**2) / (two * uk_np1 * uk) + call check_cpsi_bound (cpsi) + rot = rotation (cpsi, sqrt (one - cpsi**2), vec_orth) + p_real(nlegreal) = rot * p_real(nlegreal) + call construct_recoiling_momenta () + if (compute_jac) call compute_jacobians () -@ %def f_node_entry_t -@ A write method for [[f_node_entry]]. -<>= - procedure :: write => f_node_entry_write -<>= - subroutine f_node_entry_write (f_node_entry, u) - class (f_node_entry_t), intent (in) :: f_node_entry - integer, intent (in) :: u - write (unit=u, fmt='(A)') trim(f_node_entry%subtree_string) - end subroutine f_node_entry_write + contains -@ %def f_node_entry_write -<>= - interface assignment (=) - module procedure f_node_entry_assign - end interface assignment (=) -<>= - subroutine f_node_entry_assign (entry1, entry2) - type (f_node_entry_t), intent (out) :: entry1 - type (f_node_entry_t), intent (in) :: entry2 - entry1%node => entry2%node - entry1%subtree_string = entry2%subtree_string - entry1%string_len = entry2%string_len - entry1%subtree_size = entry2%subtree_size - end subroutine f_node_entry_assign +<> -@ %def f_node_entry_assign -@ This is the list type for [[f_nodes]]. The variable [[max_tree_size]] -is the number of nodes which appear in a complete graph. -<>= - type, extends (list_t) :: f_node_list_t - type (f_node_entry_t), pointer :: first => null () - type (f_node_entry_t), pointer :: last => null () - type (k_node_list_t), pointer :: k_node_list => null () - integer :: max_tree_size = 0 - contains - <> - end type f_node_list_t + end subroutine phs_fks_generator_generate_fsr_out -@ %def f_node_list_t -@ Add an entry to the [[f_node_list]]. If the node might be reused, we check first -using the [[subtree_string]] if there is already a node in the list which -is the root of exactly the same subtree. Otherwise we add an entry to the -list and allocate the node. In both cases we return a pointer to the node -which allows to access the node. -<>= - procedure :: add_entry => f_node_list_add_entry -<>= - subroutine f_node_list_add_entry (list, subtree_string, ptr_to_node, & - recycle, subtree_size) - class (f_node_list_t), intent (inout) :: list - character (len=*), intent (in) :: subtree_string - type (f_node_t), pointer, intent (out) :: ptr_to_node - logical, intent (in) :: recycle - integer, intent (in), optional :: subtree_size - type (f_node_entry_t), pointer :: current - type (f_node_entry_t), pointer :: second - integer :: subtree_len - ptr_to_node => null () - if (recycle) then - subtree_len = len_trim (subtree_string) - current => list%first - do while (associated (current)) - if (present (subtree_size)) then - if (current%subtree_size /= subtree_size) exit - end if - if (current%string_len == subtree_len) then - if (trim (current%subtree_string) == trim (subtree_string)) then - ptr_to_node => current%node - exit - end if - end if - current => current%next - enddo - end if - if (.not. associated (ptr_to_node)) then - if (list%n_entries == 0) then - allocate (list%first) - list%last => list%first +@ %def phs_fks_generator_generate_fsr_out +@ +<>= + subroutine debug_input_values () + if (debug2_active (D_PHASESPACE)) then + call generator%write () + print *, 'emitter = ', emitter + print *, 'p_born:' + call vector4_write_set (p_born) + print *, 'p_real:' + call vector4_write_set (p_real) + print *, 'q0 = ', q0 + if (present(p_emitter_index)) then + print *, 'p_emitter_index = ', p_emitter_index else - second => list%first - list%first => null () - allocate (list%first) - list%first%next => second + print *, 'p_emitter_index not given' end if - list%n_entries = list%n_entries + 1 - list%first%subtree_string = trim(subtree_string) - list%first%string_len = subtree_len - if (present (subtree_size)) list%first%subtree_size = subtree_size - allocate (list%first%node) - call list%first%node%set_index () - ptr_to_node => list%first%node end if - end subroutine f_node_list_add_entry - -@ %def f_node_list_add_entry -@ A write method for debugging. -<>= - procedure :: write => f_node_list_write -<>= - subroutine f_node_list_write (f_node_list, u) - class (f_node_list_t), intent (in) :: f_node_list - integer, intent (in) :: u - type (f_node_entry_t), pointer :: current - integer :: pos = 0 - current => f_node_list%first - do while (associated (current)) - pos = pos + 1 - write (unit=u, fmt='(A,I10)') 'entry #: ', pos - call current%write (u) - write (unit=u, fmt=*) - current => current%next - enddo - end subroutine f_node_list_write - -@ %def f_node_list_write -<>= - interface assignment (=) - module procedure k_node_entry_assign - end interface assignment (=) -<>= - subroutine k_node_entry_assign (entry1, entry2) - type (k_node_entry_t), intent (out) :: entry1 - type (k_node_entry_t), intent (in) :: entry2 - entry1%node => entry2%node - entry1%recycle = entry2%recycle - end subroutine k_node_entry_assign + end subroutine debug_input_values -@ %def k_node_entry_assign -@ Add an entry to the [[k_node_list]]. We have to specify if the -node can be reused. The check for existing reusable nodes happens with -[[k_node_list_get_nodes]] (see below). -<>= - procedure :: add_entry => k_node_list_add_entry -<>= - recursive subroutine k_node_list_add_entry (list, ptr_to_node, recycle) - class (k_node_list_t), intent (inout) :: list - type (k_node_t), pointer, intent (out) :: ptr_to_node - logical, intent (in) :: recycle - if (list%n_entries == 0) then - allocate (list%first) - list%last => list%first - else - allocate (list%last%next) - list%last => list%last%next +<>= + subroutine check_cpsi_bound (cpsi) + real(default), intent(inout) :: cpsi + if (cpsi > one) then + cpsi = one + else if (cpsi < -one) then + cpsi = - one end if - list%n_entries = list%n_entries + 1 - list%last%recycle = recycle - allocate (list%last%node) - call list%last%node%set_index () - ptr_to_node => list%last%node - end subroutine k_node_list_add_entry + end subroutine check_cpsi_bound -@ %def k_node_list_add_entry -@ We need a similar subroutine for adding only a pointer to a list. This -is needed for a [[k_node_list]] which is only an observer, i.e. it does -not create any nodes by itself. -<>= - procedure :: add_pointer => k_node_list_add_pointer -<>= - subroutine k_node_list_add_pointer (list, ptr_to_node, recycle) - class (k_node_list_t), intent (inout) :: list - type (k_node_t), pointer, intent (in) :: ptr_to_node - logical, optional, intent (in) :: recycle - logical :: rec - if (present (recycle)) then - rec = recycle +@ Construction of the recoiling momenta. The reshuffling of momenta +must not change the invariant mass of the recoiling system, which +means $k_{\rm{rec}}^2 = \bar{k_{\rm{rec}}}^2$. Therefore, the momenta +are related by a boost, $\bar{k}_i = \Lambda k_i$. The boost parameter +is +\begin{equation*} + \beta = \frac{q^2 - (k_{\rm{rec}}^0 + + \underline{k}_{\rm{rec}})^2}{q^2 + (k_{\rm{rec}}^0 + + \underline{k}_{\rm{rec}})^2} +\end{equation*} +<>= + subroutine construct_recoiling_momenta () + type(lorentz_transformation_t) :: lambda + k_rec0 = q0 - p_real(p_em)%p(0) - p_real(nlegreal)%p(0) + if (k_rec0**2 > generator%mrec2) then + uk_rec = sqrt (k_rec0**2 - generator%mrec2) else - rec = .false. + uk_rec = 0 end if - if (list%n_entries == 0) then - allocate (list%first) - list%last => list%first + if (generator%is_massive(emitter)) then + beta = compute_beta (q0**2, k_rec0, uk_rec, & + p_born(p_em)%p(0), uk_n_born) else - allocate (list%last%next) - list%last => list%last%next + beta = compute_beta (q0**2, k_rec0, uk_rec) end if - list%n_entries = list%n_entries + 1 - list%last%recycle = rec - list%last%node => ptr_to_node - end subroutine k_node_list_add_pointer + k = p_real(p_em)%p(1:3) + p_real(nlegreal)%p(1:3) + vec%p(1:3) = one / uk * k%p(1:3) + lambda = boost (beta / sqrt(one - beta**2), vec) + do i = generator%i_fsr_first, nlegborn + if (i /= p_em) then + p_real(i) = lambda * p_born(i) + end if + end do + vec%p(1:3) = p_born(p_em)%p(1:3) / uk_n_born + rot = rotation (cos(phi), sin(phi), vec) + p_real(nlegreal) = rot * p_real(nlegreal) + p_real(p_em) = rot * p_real(p_em) + end subroutine construct_recoiling_momenta -@ %def k_node_list_add_pointer -@ The [[k_node_list]] can also be used to collect [[k_nodes]] which belong to -different [[f_nodes]] in order to compare these. This is done only for nodes -which have the same number of subtree nodes. We compare all nodes of the -list with each other (as long as the node is not deactivated, i.e. if -the [[keep]] variable is set to [[.true.]]) using the subroutine -[[subtree_select]]. If it turns out that two nodes are equivalent, we -keep only one of them. The term equivalent in this module refers to trees -or subtrees which differ in the pdg codes at positions where -the trivial mapping is used ([[NO_MAPPING]] or [[NON_RESONANT]]) so that -the mass of the particle does not matter. Depending on the available -couplings, two equivalent subtrees could eventually lead to the same phase -space channels, which is why only one of them is kept. -<>= - procedure :: check_subtree_equivalences => k_node_list_check_subtree_equivalences -<>= - subroutine k_node_list_check_subtree_equivalences (list, model) - class (k_node_list_t), intent (inout) :: list - type (model_data_t), intent (in) :: model - type (k_node_ptr_t), dimension (:), allocatable :: set - type (k_node_entry_t), pointer :: current - integer :: pos - integer :: i,j - if (list%n_entries == 0) return - allocate (set (list%n_entries)) - current => list%first - pos = 0 - do while (associated (current)) - pos = pos + 1 - set(pos)%node => current%node - current => current%next - enddo - do i=1, list%n_entries - if (set(i)%node%keep) then - do j=i+1, list%n_entries - if (set(j)%node%keep) then - if (set(i)%node%bincode == set(j)%node%bincode) then - call subtree_select (set(i)%node%subtree,set(j)%node%subtree, model) - if (.not. set(i)%node%subtree%keep) then - set(i)%node%keep = .false. - exit - else if (.not. set(j)%node%subtree%keep) then - set(j)%node%keep = .false. - end if - end if - end if - enddo +@ The factor $\frac{q^2}{(4\pi)^3}$ is not included here since it is +supplied during phase space generation. Also, we already divide by +$\xi$. +<>= + subroutine compute_jacobians () + associate (jac => generator%real_kinematics%jac(i_phs)) + if (generator%is_massive(emitter)) then + jac%jac(1) = jac%jac(1) * four / q0 / uk_n_born / xi + else + k2 = two * uk_n * uk_np1* (one - y) + jac%jac(1) = uk_n**2 / uk_n_born / (uk_n - k2 / (two * q0)) end if - enddo - deallocate (set) - end subroutine k_node_list_check_subtree_equivalences + jac%jac(2) = one + jac%jac(3) = one - xi / two * q0 / uk_n_born + end associate + end subroutine compute_jacobians -@ %def k_node_list_check_subtree_equivalences -@ This subroutine is used to obtain all [[k_nodes]] of a [[k_node_list]] -which can be recycled and are not disabled for some reason. We pass an -allocatable array of the type [[k_node_ptr_t]] which will be allocated -if there are any such nodes in the list and the pointers will be -associated with these nodes. -<>= - procedure :: get_nodes => k_node_list_get_nodes -<>= - subroutine k_node_list_get_nodes (list, nodes) - class (k_node_list_t), intent (inout) :: list - type (k_node_ptr_t), dimension(:), allocatable, intent (out) :: nodes - integer :: n_nodes - integer :: pos - type (k_node_entry_t), pointer :: current, garbage - n_nodes = 0 - current => list%first - do while (associated (current)) - if (current%recycle .and. current%node%keep) n_nodes = n_nodes + 1 - current => current%next - enddo - if (n_nodes /= 0) then - pos = 1 - allocate (nodes (n_nodes)) - do while (associated (list%first) .and. .not. list%first%node%keep) - garbage => list%first - list%first => list%first%next - call garbage%final () - deallocate (garbage) - enddo - current => list%first - do while (associated (current)) - do while (associated (current%next)) - if (.not. current%next%node%keep) then - garbage => current%next - current%next => current%next%next - call garbage%final - deallocate (garbage) - else - exit - end if - enddo - if (current%recycle .and. current%node%keep) then - nodes(pos)%node => current%node - pos = pos + 1 - end if - current => current%next - enddo - end if - end subroutine k_node_list_get_nodes +@ %def compute_jacobians +@ +<>= + procedure :: generate_fsr_in => phs_fks_generate_fsr_in +<>= + module subroutine phs_fks_generate_fsr_in (phs) + class(phs_fks_t), intent(inout) :: phs + end subroutine phs_fks_generate_fsr_in +<>= + module subroutine phs_fks_generate_fsr_in (phs) + class(phs_fks_t), intent(inout) :: phs + type(vector4_t), dimension(:), allocatable :: p + p = phs%generator%real_kinematics%p_born_lab%get_momenta & + (1, phs%generator%n_in) + end subroutine phs_fks_generate_fsr_in -@ %def k_node_list_get_nodes -<>= - procedure :: final => f_node_list_final -<>= - subroutine f_node_list_final (list) - class (f_node_list_t) :: list - type (f_node_entry_t), pointer :: current - list%k_node_list => null () - do while (associated (list%first)) - current => list%first - list%first => list%first%next - call current%final () - deallocate (current) - enddo - end subroutine f_node_list_final +@ %def phs_fks_generate_fsr_in +@ +<>= + procedure :: generate_fsr => phs_fks_generate_fsr +<>= + module subroutine phs_fks_generate_fsr (phs, emitter, i_phs, p_real, & + i_con, xi_y_phi, no_jacobians) + class(phs_fks_t), intent(inout) :: phs + integer, intent(in) :: emitter, i_phs + type(vector4_t), intent(inout), dimension(:) :: p_real + integer, intent(in), optional :: i_con + real(default), intent(in), dimension(3), optional :: xi_y_phi + logical, intent(in), optional :: no_jacobians + end subroutine phs_fks_generate_fsr +<>= + module subroutine phs_fks_generate_fsr (phs, emitter, i_phs, p_real, & + i_con, xi_y_phi, no_jacobians) + class(phs_fks_t), intent(inout) :: phs + integer, intent(in) :: emitter, i_phs + type(vector4_t), intent(inout), dimension(:) :: p_real + integer, intent(in), optional :: i_con + real(default), intent(in), dimension(3), optional :: xi_y_phi + logical, intent(in), optional :: no_jacobians + type(vector4_t), dimension(:), allocatable :: p + associate (generator => phs%generator) + p = generator%real_kinematics%p_born_cms%phs_point(1) + generator%real_kinematics%supply_xi_max = .true. + if (present (i_con)) then + call generator%generate_fsr (emitter, i_phs, i_con, p, p_real, & + xi_y_phi, no_jacobians) + else + call generator%generate_fsr (emitter, i_phs, p, p_real, & + xi_y_phi, no_jacobians) + end if + generator%real_kinematics%p_real_cms%phs_point(i_phs) = p_real + if (.not. phs%config%lab_is_cm) p_real = phs%lt_cm_to_lab * p_real + generator%real_kinematics%p_real_lab%phs_point(i_phs) = p_real + end associate + end subroutine phs_fks_generate_fsr -@ %def f_node_list_final +@ %def phs_fks_generate_fsr @ -\subsection{The grove list} -First a type is introduced in order to speed up the comparison of kingraphs -with the purpose to quickly find the graphs that might be equivalent. -This is done solely on the basis of a number (which is given -by the value of [[depth]] in [[compare_tree_t]]) of bincodes, which are -the highest ones that do not belong to external particles. -The highest such value determines the index of the element in the [[entry]] -array of the [[compare_tree]]. The next lower such value determines -the index of the element in the [[entry]] array of this [[entry]], and so -on and so forth. This results in a tree structure where the number of -levels is given by [[depth]] and should not be too large for reasons of -memory. -This is the entry type. -<>= - type :: compare_tree_entry_t - type (compare_tree_entry_t), dimension(:), pointer :: entry => null () - type (kingraph_ptr_t), dimension(:), allocatable :: graph_entry - contains - <> - end type compare_tree_entry_t +<>= + procedure :: get_onshell_projected_momenta => & + phs_fks_get_onshell_projected_momenta +<>= + pure module function phs_fks_get_onshell_projected_momenta (phs) result (p) + type(vector4_t), dimension(:), allocatable :: p + class(phs_fks_t), intent(in) :: phs + end function phs_fks_get_onshell_projected_momenta +<>= + pure module function phs_fks_get_onshell_projected_momenta (phs) result (p) + type(vector4_t), dimension(:), allocatable :: p + class(phs_fks_t), intent(in) :: phs + p = phs%generator%real_kinematics%p_born_onshell%phs_point(1) + end function phs_fks_get_onshell_projected_momenta -@ %def compare_tree_entry_t -@ This is the tree type. -<>= - type :: compare_tree_t - integer :: depth = 3 - type (compare_tree_entry_t), dimension(:), pointer :: entry => null () - contains - <> - end type compare_tree_t +@ %def phs_fks_get_onshell_projected_momenta +@ +<>= + procedure :: generate_fsr_threshold => phs_fks_generate_fsr_threshold +<>= + module subroutine phs_fks_generate_fsr_threshold & + (phs, emitter, i_phs, p_real) + class(phs_fks_t), intent(inout) :: phs + integer, intent(in) :: emitter, i_phs + type(vector4_t), intent(inout), dimension(:), optional :: p_real + end subroutine phs_fks_generate_fsr_threshold +<>= + module subroutine phs_fks_generate_fsr_threshold & + (phs, emitter, i_phs, p_real) + class(phs_fks_t), intent(inout) :: phs + integer, intent(in) :: emitter, i_phs + type(vector4_t), intent(inout), dimension(:), optional :: p_real + type(vector4_t), dimension(:), allocatable :: p_born + type(vector4_t), dimension(:), allocatable :: pp + integer :: leg + associate (generator => phs%generator) + generator%real_kinematics%supply_xi_max = .true. + allocate (p_born (1 : generator%real_kinematics%p_born_cms%get_n_particles())) + p_born = generator%real_kinematics%p_born_onshell%get_momenta (1) + allocate (pp (size (p_born) + 1)) + call generator%generate_fsr_threshold (emitter, i_phs, p_born, pp) + leg = thr_leg (emitter) + call generator%real_kinematics%p_real_onshell(leg)%set_momenta (i_phs, pp) + if (present (p_real)) p_real = pp + end associate + end subroutine phs_fks_generate_fsr_threshold -@ %def compare_tree_t -@ Finalizers for both types. The one for the entry type has to be recursive. -<>= - procedure :: final => compare_tree_final -<>= - subroutine compare_tree_final (ctree) - class (compare_tree_t), intent (inout) :: ctree - integer :: i - if (associated (ctree%entry)) then - do i=1, size (ctree%entry) - call ctree%entry(i)%final () - deallocate (ctree%entry) - end do - end if - end subroutine compare_tree_final +@ %def phs_fks_generate_fsr_threshold +@ +<>= + generic :: compute_xi_max => & + compute_xi_max_internal, compute_xi_max_with_output + procedure :: compute_xi_max_internal => phs_fks_compute_xi_max_internal +<>= + module subroutine phs_fks_compute_xi_max_internal (phs, p, threshold) + class(phs_fks_t), intent(inout) :: phs + type(vector4_t), intent(in), dimension(:) :: p + logical, intent(in) :: threshold + end subroutine phs_fks_compute_xi_max_internal +<>= + module subroutine phs_fks_compute_xi_max_internal (phs, p, threshold) + class(phs_fks_t), intent(inout) :: phs + type(vector4_t), intent(in), dimension(:) :: p + logical, intent(in) :: threshold + integer :: i_phs, i_con, emitter + do i_phs = 1, size (phs%phs_identifiers) + associate (phs_id => phs%phs_identifiers(i_phs), generator => phs%generator) + emitter = phs_id%emitter + if (threshold) then + call generator%compute_xi_max (emitter, i_phs, p, & + generator%real_kinematics%xi_max(i_phs), i_con = thr_leg(emitter)) + else if (allocated (phs_id%contributors)) then + do i_con = 1, size (phs_id%contributors) + call generator%compute_xi_max (emitter, i_phs, p, & + generator%real_kinematics%xi_max(i_phs), i_con = 1) + end do + else + call generator%compute_xi_max (emitter, i_phs, p, & + generator%real_kinematics%xi_max(i_phs)) + end if + end associate + end do + end subroutine phs_fks_compute_xi_max_internal -@ %def compare_tree_final -<>= - procedure :: final => compare_tree_entry_final -<>= - recursive subroutine compare_tree_entry_final (ct_entry) - class (compare_tree_entry_t), intent (inout) :: ct_entry - integer :: i - if (associated (ct_entry%entry)) then - do i=1, size (ct_entry%entry) - call ct_entry%entry(i)%final () - enddo - deallocate (ct_entry%entry) - else - deallocate (ct_entry%graph_entry) - end if - end subroutine compare_tree_entry_final +@ %def phs_fks_compute_xi_max +@ +<>= + procedure :: compute_xi_max_with_output => phs_fks_compute_xi_max_with_output +<>= + module subroutine phs_fks_compute_xi_max_with_output & + (phs, emitter, i_phs, y, p, xi_max) + class(phs_fks_t), intent(inout) :: phs + integer, intent(in) :: i_phs, emitter + real(default), intent(in) :: y + type(vector4_t), intent(in), dimension(:) :: p + real(default), intent(out) :: xi_max + end subroutine phs_fks_compute_xi_max_with_output +<>= + module subroutine phs_fks_compute_xi_max_with_output & + (phs, emitter, i_phs, y, p, xi_max) + class(phs_fks_t), intent(inout) :: phs + integer, intent(in) :: i_phs, emitter + real(default), intent(in) :: y + type(vector4_t), intent(in), dimension(:) :: p + real(default), intent(out) :: xi_max + call phs%generator%compute_xi_max (emitter, i_phs, p, xi_max, y_in = y) + end subroutine phs_fks_compute_xi_max_with_output -@ %def compare_tree_entry_final -@ Check the presence of a graph which is considered as equivalent and -select between the two. If there is no such graph, the current one -is added to the list. First the entry has to be found: -<>= - procedure :: check_kingraph => compare_tree_check_kingraph -<>= - subroutine compare_tree_check_kingraph (ctree, kingraph, model, preliminary) - class (compare_tree_t), intent (inout) :: ctree - type (kingraph_t), intent (inout), pointer :: kingraph - type (model_data_t), intent (in) :: model - logical, intent (in) :: preliminary - integer :: i - integer :: pos - integer(TC) :: sz - integer(TC), dimension(:), allocatable :: identifier - if (.not. associated (ctree%entry)) then - sz = 0_TC - do i = size(kingraph%tree%bc), 1, -1 - sz = ior (sz, kingraph%tree%bc(i)) - enddo - if (sz > 0) then - allocate (ctree%entry (sz)) - else - call msg_bug ("Compare tree could not be created") - end if - end if - allocate (identifier (ctree%depth)) - pos = 0 - do i = size(kingraph%tree%bc), 1, -1 - if (popcnt (kingraph%tree%bc(i)) /= 1) then - pos = pos + 1 - identifier(pos) = kingraph%tree%bc(i) - if (pos == ctree%depth) exit - end if - enddo - if (size (identifier) > 1) then - call ctree%entry(identifier(1))%check_kingraph (kingraph, model, & - preliminary, identifier(1), identifier(2:)) - else if (size (identifier) == 1) then - call ctree%entry(identifier(1))%check_kingraph (kingraph, model, preliminary) - end if - deallocate (identifier) - end subroutine compare_tree_check_kingraph +@ %def phs_fks_compute_xi_max_with_output +@ +<>= + generic :: compute_emitter_kinematics => & + compute_emitter_kinematics_massless, & + compute_emitter_kinematics_massive + procedure :: compute_emitter_kinematics_massless => & + phs_fks_generator_compute_emitter_kinematics_massless + procedure :: compute_emitter_kinematics_massive => & + phs_fks_generator_compute_emitter_kinematics_massive +<>= + module subroutine phs_fks_generator_compute_emitter_kinematics_massless & + (generator, y, q0, uk_em, uk) + class(phs_fks_generator_t), intent(inout) :: generator + real(default), intent(in) :: y, q0 + real(default), intent(out) :: uk_em, uk + end subroutine phs_fks_generator_compute_emitter_kinematics_massless + module subroutine phs_fks_generator_compute_emitter_kinematics_massive & + (generator, y, em, i_phs, q0, k0_em, uk_em, uk, compute_jac) + class(phs_fks_generator_t), intent(inout) :: generator + real(default), intent(in) :: y + integer, intent(in) :: em, i_phs + real(default), intent(in) :: q0 + real(default), intent(inout) :: k0_em, uk_em, uk + logical, intent(in) :: compute_jac + end subroutine phs_fks_generator_compute_emitter_kinematics_massive +<>= + module subroutine phs_fks_generator_compute_emitter_kinematics_massless & + (generator, y, q0, uk_em, uk) + class(phs_fks_generator_t), intent(inout) :: generator + real(default), intent(in) :: y, q0 + real(default), intent(out) :: uk_em, uk + real(default) :: k0_np1, q2 -@ %def compare_tree_check_kingraph -@ Then the graphs of the entry are checked. -<>= - procedure :: check_kingraph => compare_tree_entry_check_kingraph -<>= - recursive subroutine compare_tree_entry_check_kingraph (ct_entry, kingraph, & - model, preliminary, subtree_size, identifier) - class (compare_tree_entry_t), intent (inout) :: ct_entry - type (kingraph_t), pointer, intent (inout) :: kingraph - type (model_data_t), intent (in) :: model - logical, intent (in) :: preliminary - integer, intent (in), optional :: subtree_size - integer, dimension (:), intent (in), optional :: identifier - if (present (identifier)) then - if (.not. associated (ct_entry%entry)) & - allocate (ct_entry%entry(subtree_size)) - if (size (identifier) > 1) then - call ct_entry%entry(identifier(1))%check_kingraph (kingraph, & - model, preliminary, identifier(1), identifier(2:)) - else if (size (identifier) == 1) then - call ct_entry%entry(identifier(1))%check_kingraph (kingraph, & - model, preliminary) - end if - else - if (allocated (ct_entry%graph_entry)) then - call perform_check - else - allocate (ct_entry%graph_entry(1)) - ct_entry%graph_entry(1)%graph => kingraph - end if - end if + k0_np1 = generator%E_gluon + q2 = q0**2 - contains + uk_em = (q2 - generator%mrec2 - two * q0 * k0_np1) / & + (two * (q0 - k0_np1 * (one - y))) + uk = sqrt (uk_em**2 + k0_np1**2 + two * uk_em * k0_np1 * y) + end subroutine phs_fks_generator_compute_emitter_kinematics_massless - subroutine perform_check - integer :: i - logical :: rebuild - rebuild = .true. - do i=1, size(ct_entry%graph_entry) - if (ct_entry%graph_entry(i)%graph%keep) then - if (preliminary .or. & - ct_entry%graph_entry(i)%graph%prc_component /= kingraph%prc_component) then - call kingraph_select (ct_entry%graph_entry(i)%graph, kingraph, model, preliminary) - if (.not. kingraph%keep) then - return - else if (rebuild .and. .not. ct_entry%graph_entry(i)%graph%keep) then - ct_entry%graph_entry(i)%graph => kingraph - rebuild = .false. - end if - end if - end if - enddo - if (rebuild) call rebuild_graph_entry - end subroutine perform_check + module subroutine phs_fks_generator_compute_emitter_kinematics_massive & + (generator, y, em, i_phs, q0, k0_em, uk_em, uk, compute_jac) + class(phs_fks_generator_t), intent(inout) :: generator + real(default), intent(in) :: y + integer, intent(in) :: em, i_phs + real(default), intent(in) :: q0 + real(default), intent(inout) :: k0_em, uk_em, uk + logical, intent(in) :: compute_jac + real(default) :: k0_np1, q2, mrec2, m2 + real(default) :: k0_rec_max, k0_em_max, k0_rec, uk_rec + real(default) :: z, z1, z2 - subroutine rebuild_graph_entry - type (kingraph_ptr_t), dimension(:), allocatable :: tmp_ptr - integer :: i - integer :: pos - allocate (tmp_ptr(size(ct_entry%graph_entry)+1)) - pos = 0 - do i=1, size(ct_entry%graph_entry) - pos = pos + 1 - tmp_ptr(pos)%graph => ct_entry%graph_entry(i)%graph - enddo - pos = pos + 1 - tmp_ptr(pos)%graph => kingraph - deallocate (ct_entry%graph_entry) - allocate (ct_entry%graph_entry (pos)) - do i=1, pos - ct_entry%graph_entry(i)%graph => tmp_ptr(i)%graph - enddo - deallocate (tmp_ptr) - end subroutine rebuild_graph_entry - end subroutine compare_tree_entry_check_kingraph + k0_np1 = generator%E_gluon + q2 = q0**2 + mrec2 = generator%mrec2 + m2 = generator%m2(em) -@ %def compare_tree_entry_check_kingraph -@ The grove to which a completed [[kingraph]] will be added is determined by the -entries of [[grove_prop]]. We use another list type (linked list) to -arrange the groves. Each [[grove]] contains again a linked list of -[[kingraphs]]. -<>= - type :: grove_t - type (grove_prop_t) :: grove_prop - type (grove_t), pointer :: next => null () - type (kingraph_t), pointer :: first => null () - type (kingraph_t), pointer :: last => null () - type (compare_tree_t) :: compare_tree - contains - <> - end type grove_t + k0_rec_max = (q2 - m2 + mrec2) / (two * q0) + k0_em_max = (q2 + m2 - mrec2) /(two * q0) + z1 = (k0_rec_max + sqrt (k0_rec_max**2 - mrec2)) / q0 + z2 = (k0_rec_max - sqrt (k0_rec_max**2 - mrec2)) / q0 + z = z2 - (z2 - z1) * (one + y) / two + k0_em = k0_em_max - k0_np1 * z + k0_rec = q0 - k0_np1 - k0_em + uk_em = sqrt(k0_em**2 - m2) + uk_rec = sqrt(k0_rec**2 - mrec2) + uk = uk_rec + if (compute_jac) & + generator%real_kinematics%jac(i_phs)%jac = q0 * (z1 - z2) / four * k0_np1 + generator%real_kinematics%y_soft(i_phs) = & + (two * q2 * z - q2 - mrec2 + m2) / (sqrt(k0_em_max**2 - m2) * q0) / two + end subroutine phs_fks_generator_compute_emitter_kinematics_massive -@ %def grove_t -@ Container for a pointer of type [[grove_t]]: -<>= - type :: grove_ptr_t - type (grove_t), pointer :: grove => null () - end type grove_ptr_t +@ %def phs_fks_generator_compute_emitter_kinematics +@ +<>= + function recompute_xi_max (q0, mrec2, m2, y) result (xi_max) + real(default) :: xi_max + real(default), intent(in) :: q0, mrec2, m2, y + real(default) :: q2, k0_np1_max, k0_rec_max + real(default) :: z1, z2, z + q2 = q0**2 + k0_rec_max = (q2 - m2 + mrec2) / (two * q0) + z1 = (k0_rec_max + sqrt (k0_rec_max**2 - mrec2)) / q0 + z2 = (k0_rec_max - sqrt (k0_rec_max**2 - mrec2)) / q0 + z = z2 - (z2 - z1) * (one + y) / 2 + k0_np1_max = - (q2 * z**2 - two * q0 * k0_rec_max * z + mrec2) / (two * q0 * z * (one - z)) + xi_max = two * k0_np1_max / q0 + end function recompute_xi_max -@ %def grove_ptr_t -<>= - procedure :: final => grove_final -<>= - subroutine grove_final (grove) - class(grove_t), intent(inout) :: grove - grove%first => null () - grove%last => null () - grove%next => null () - end subroutine grove_final +@ %def recompute_xi_max +@ +<>= + function compute_beta_massless (q2, k0_rec, uk_rec) result (beta) + real(default), intent(in) :: q2, k0_rec, uk_rec + real(default) :: beta + beta = (q2 - (k0_rec + uk_rec)**2) / (q2 + (k0_rec + uk_rec)**2) + end function compute_beta_massless -@ %def grove_final -@ This is the list type: -<>= - type :: grove_list_t - type (grove_t), pointer :: first => null () - contains - <> - end type grove_list_t + function compute_beta_massive (q2, k0_rec, uk_rec, & + k0_em_born, uk_em_born) result (beta) + real(default), intent(in) :: q2, k0_rec, uk_rec + real(default), intent(in) :: k0_em_born, uk_em_born + real(default) :: beta + real(default) :: k0_rec_born, uk_rec_born, alpha + k0_rec_born = sqrt(q2) - k0_em_born + uk_rec_born = uk_em_born + alpha = (k0_rec + uk_rec) / (k0_rec_born + uk_rec_born) + beta = (one - alpha**2) / (one + alpha**2) + end function compute_beta_massive -@ %def grove_list_t -<>= - procedure :: final => grove_list_final -<>= - subroutine grove_list_final (list) - class(grove_list_t), intent(inout) :: list - class(grove_t), pointer :: current - do while (associated (list%first)) - current => list%first - list%first => list%first%next - call current%final () - deallocate (current) - end do - end subroutine grove_list_final +@ %def compute_beta +@ The momentum of the radiated particle is computed according to +\begin{equation} + \label{eq:phs_fks:compute_k_n} + \underline{k}_n = \frac{q^2 - M_{\rm{rec}}^2 - + 2q^0\underline{k}_{n+1}}{2(q^0 - \underline{k}_{n+1}(1-y))}, +\end{equation} +with $k = k_n + k_{n+1}$ and $M_{\rm{rec}}^2 = k_{\rm{rec}}^2 = +\left(q-k\right)^2$. Because of $\boldsymbol{\bar{k}}_n \parallel +\boldsymbol{k}_n + \boldsymbol{k}_{n+1}$ we find $M_{\rm{rec}}^2 = +\left(q-\bar{k}_n\right)^2$. +Equation \ref{eq:phs_fks:compute_k_n} follows from the fact that +$\left(\boldsymbol{k} - \boldsymbol{k}_n\right)^2 = +\boldsymbol{k}_{n+1}^2$, which is equivalent to $\boldsymbol{k}_n +\cdot \boldsymbol{k} = \frac{1}{2} \left(\underline{k}_n^2 + + \underline{k}^2 - \underline{k}_{n+1}^2\right)$.\\ +$\boldsymbol{k}_n$ and $\boldsymbol{k}_{n+1}$ are obtained by first +setting up vectors parallel to $\boldsymbol{\bar{k}}_n$, +\begin{equation*} + \boldsymbol{k}_n' = \underline{k}_n + \frac{\bar{\pmb{k}}_n}{\underline{\bar{k}}_n}, \quad \pmb{k}_{n+1}' + = \underline{k}_{n+1}\frac{\bar{\pmb{k}}_n}{\underline{\bar{k}}_n}, +\end{equation*} +and then rotating these vectors by an amount of $\cos\psi_n = +\frac{\boldsymbol{k}_n\cdot\pmb{k}}{\underline{k}_n \underline{k}}$. +@ The emitted particle cannot have more momentum than the emitter has +in the Born phase space. Thus, there is an upper bound for $\xi$, +determined by the condition $k_{n+1}^0 = \underline{\bar{k}}_n$, which +is equal to +\begin{equation*} +\xi_{\rm{max}} = \frac{2}{\underline{\bar{k}}_n}{q^0}. +\end{equation*} +<>= + pure function get_xi_max_fsr_massless (p_born, q0, emitter) result (xi_max) + type(vector4_t), intent(in), dimension(:) :: p_born + real(default), intent(in) :: q0 + integer, intent(in) :: emitter + real(default) :: xi_max + real(default) :: uk_n_born + uk_n_born = space_part_norm (p_born(emitter)) + xi_max = two * uk_n_born / q0 + end function get_xi_max_fsr_massless -@ %def grove_list_final -@ -\subsection{The feyngraph set} -The fundament of the module is the public type [[feyngraph_set_t]]. It -is not only a linked list of all [[feyngraphs]] but contains an array -of all particle properties ([[particle]]), an [[f_node_list]] and a -pointer of the type [[grove_list_t]], since several [[feyngraph_sets]] -can share a common [[grove_list]]. In addition it keeps the data which -unambiguously specifies the process, as well as the model which -provides information which allows us to choose between equivalent -subtrees or complete [[kingraphs]]. -<>= - public :: feyngraph_set_t -<>= - type :: feyngraph_set_t - type (model_data_t), pointer :: model => null () - type(flavor_t), dimension(:,:), allocatable :: flv - integer :: n_in = 0 - integer :: n_out = 0 - integer :: process_type = DECAY - type (phs_parameters_t) :: phs_par - logical :: fatal_beam_decay = .true. - type (part_prop_t), dimension (:), pointer :: particle => null () - type (f_node_list_t) :: f_node_list - type (feyngraph_t), pointer :: first => null () - type (feyngraph_t), pointer :: last => null () - integer :: n_graphs = 0 - type (grove_list_t), pointer :: grove_list => null () - logical :: use_dag = .true. - type (dag_t), pointer :: dag => null () - type (feyngraph_set_t), dimension (:), pointer :: fset => null () - contains - <> - end type feyngraph_set_t +@ %def get_xi_max_fsr_massless +@ The computation of $\xi_{\rm{max}}$ for massive emitters is described +in arXiv:1202.0465. Let's recapitulate it here. -@ %def feyngraph_set_t -@ This final procedure contains calls to all other necessary final -procedures. -<>= - procedure :: final => feyngraph_set_final -<>= - recursive subroutine feyngraph_set_final (set) - class(feyngraph_set_t), intent(inout) :: set - class(feyngraph_t), pointer :: current - integer :: i - if (associated (set%fset)) then - do i=1, size (set%fset) - call set%fset(i)%final () - enddo - deallocate (set%fset) - else - set%particle => null () - set%grove_list => null () - end if - set%model => null () - if (allocated (set%flv)) deallocate (set%flv) - set%last => null () - do while (associated (set%first)) - current => set%first - set%first => set%first%next - call current%final () - deallocate (current) - end do - if (associated (set%particle)) then - do i = 1, size (set%particle) - call set%particle(i)%final () - end do - deallocate (set%particle) - end if - if (associated (set%grove_list)) then - if (debug_on) call msg_debug (D_PHASESPACE, "grove_list: final") - call set%grove_list%final () - deallocate (set%grove_list) - end if - if (debug_on) call msg_debug (D_PHASESPACE, "f_node_list: final") - call set%f_node_list%final () - if (associated (set%dag)) then - if (debug_on) call msg_debug (D_PHASESPACE, "dag: final") - if (associated (set%dag)) then - call set%dag%final () - deallocate (set%dag) - end if - end if - end subroutine feyngraph_set_final +We consider the Dalitz-domain created by $k_{n+1}^0$, $k_n^0$ and +$k_{\rm{rec}}^0$ and introduce the parameterization +\begin{equation*} + k_n^0 = \bar{k}_n^0 - zk_{n+1}^0 +\end{equation*} +Then, for each value of $z$, there exists a maximum value of +$\underline{k}_{n+1}$ from which $\xi_{\rm{max}}$ can be extracted via +$\xi_{\rm{max}} = 2k_{n+1}^0/q$. It is determined by the condition +\begin{equation*} + \underline{k}_{n+1} \pm \underline{k}_n \pm \underline{k}_{\rm{rec}} = 0. +\end{equation*} +This can be manipulated to yield +\begin{equation*} + \left(\underline{k}_{n+1}^2 + \underline{k}_n^2 - + \underline{k}_{\rm{rec}}^2\right)^2 = + 4\underline{k}^2_{n+1}\underline{k}_n^2. +\end{equation*} +Here we can use $\underline{k}_n^2 = \left(k_n^0\right)^2 - m^2$ and +$\underline{k}_{\rm{rec}}^2 = \left(q - k_n^0 - k_{n+1}^0\right)^2 - +M_{\rm{rec}}^2$, as well as the above parameterization of $k_n^0$, to +obtain +\begin{equation*} + 4\underline{k}_{n+1}^2\left(2\underline{k}_{n+1}qz(1-z) + + q^2z^2 - 2q\bar{k}_{\rm{rec}}^0z + M_{\rm{rec}}^2\right) = 0. +\end{equation*} +Solving for $k_{n+1}^0$ gives +\begin{equation} + k_{n+1}^0 = \frac{2q\bar{k}^0_{\rm{rec}}z - q^2z^2 - M_{\rm{rec}}^2}{2qz(1-z)}. + \label{XiMaxMassive} +\end{equation} +It is still open how to compute $z$. For this, consider that the +right-hand-side of equation (\ref{XiMaxMassive}) vanishes for +\begin{equation*} + z_{1,2} = \left(\bar{k}_{\rm{rec}}^0 \pm + \sqrt{\left(\bar{k}_{\rm{rec}}^0\right)^2 - M_{\rm{rec}}^2}\right)/q, +\end{equation*} +which corresponds to the borders of the Dalitz-region where the gluon +momentum vanishes. Thus we define +\begin{equation*} + z = z_2 - \frac{1}{2} (z_2 - z_1)(1+y). +\end{equation*} +<>= + pure function get_xi_max_fsr_massive (p_born, q0, emitter, m2, y) result (xi_max) + real(default) :: xi_max + type(vector4_t), intent(in), dimension(:) :: p_born + real(default), intent(in) :: q0 + integer, intent(in) :: emitter + real(default), intent(in) :: m2, y + real(default) :: mrec2 + real(default) :: k0_rec_max + real(default) :: z, z1, z2 + real(default) :: k0_np1_max + associate (p => p_born(emitter)%p) + mrec2 = (q0 - p(0))**2 - p(1)**2 - p(2)**2 - p(3)**2 + end associate + call compute_dalitz_bounds (q0, m2, mrec2, z1, z2, k0_rec_max) + z = z2 - (z2 - z1) * (one + y) / two + k0_np1_max = - (q0**2 * z**2 - two * q0 * k0_rec_max * z + mrec2) & + / (two * q0 * z * (one - z)) + xi_max = two * k0_np1_max / q0 + end function get_xi_max_fsr_massive -@ %def feyngraph_set_final +@ %def get_xi_max_fsr_massive @ -\subsection{Construct the feyngraph set} -We construct the [[feyngraph_set]] from an input file. Therefore we pass -a unit to [[feyngraph_set_build]]. The parsing subroutines are chosen -depending on the value of [[use_dag]]. In the DAG output, which is the one -that is produced by default, we have to work on a string of one line, -where the lenght of this string becomes larger the more particles are -involved in the process. The other output (which is now only used in a -unit test) contains one Feynman diagram per line and each line starts with an open -parenthesis so that we read the file line per line and create a -[[feyngraph]] for every line. Only after this, nodes are created. In both -decay and scattering processes the diagrams are represented like in a decay -process, i.e. in a scattering process one of the incoming particles appears -as an outgoing particle. -<>= - procedure :: build => feyngraph_set_build -<>= - subroutine feyngraph_set_build (feyngraph_set, u_in) - class (feyngraph_set_t), intent (inout) :: feyngraph_set - integer, intent (in) :: u_in - integer :: stat = 0 - character (len=FEYNGRAPH_LEN) :: omega_feyngraph_output - type (feyngraph_t), pointer :: current_graph - type (feyngraph_t), pointer :: compare_graph - logical :: present - if (feyngraph_set%use_dag) then - allocate (feyngraph_set%dag) - if (.not. associated (feyngraph_set%first)) then - call feyngraph_set%dag%read_string (u_in, feyngraph_set%flv(:,1)) - call feyngraph_set%dag%construct (feyngraph_set) - call feyngraph_set%dag%make_feyngraphs (feyngraph_set) - end if - else - if (.not. associated (feyngraph_set%first)) then - read (unit=u_in, fmt='(A)', iostat=stat, advance='yes') omega_feyngraph_output - if (omega_feyngraph_output(1:1) == '(') then - allocate (feyngraph_set%first) - feyngraph_set%first%omega_feyngraph_output = trim(omega_feyngraph_output) - feyngraph_set%last => feyngraph_set%first - feyngraph_set%n_graphs = feyngraph_set%n_graphs + 1 - else - call msg_fatal ("Invalid input file") - end if - read (unit=u_in, fmt='(A)', iostat=stat, advance='yes') omega_feyngraph_output - do while (stat == 0) - if (omega_feyngraph_output(1:1) == '(') then - compare_graph => feyngraph_set%first - present = .false. - do while (associated (compare_graph)) - if (len_trim(compare_graph%omega_feyngraph_output) & - == len_trim(omega_feyngraph_output)) then - if (compare_graph%omega_feyngraph_output == omega_feyngraph_output) then - present = .true. - exit - end if - end if - compare_graph => compare_graph%next - enddo - if (.not. present) then - allocate (feyngraph_set%last%next) - feyngraph_set%last => feyngraph_set%last%next - feyngraph_set%last%omega_feyngraph_output = trim(omega_feyngraph_output) - feyngraph_set%n_graphs = feyngraph_set%n_graphs + 1 - end if - read (unit=u_in, fmt='(A)', iostat=stat, advance='yes') omega_feyngraph_output - else - exit - end if - enddo - current_graph => feyngraph_set%first - do while (associated (current_graph)) - call feyngraph_construct (feyngraph_set, current_graph) - current_graph => current_graph%next - enddo - feyngraph_set%f_node_list%max_tree_size = feyngraph_set%first%n_nodes - end if - end if - end subroutine feyngraph_set_build +<>= + integer, parameter, public :: I_PLUS = 1 + integer, parameter, public :: I_MINUS = 2 -@ %def feyngraph_set_build -@ Read the string from the file. The output which is produced by O'Mega -contains the DAG in a factorised form as a long string, distributed over -several lines (in addition, in the case of a scattering process, it -contains a similar string for the same process, but with the other -incoming particle as the root of the tree structure). In general, such a -file can contain many of these strings, belonging to different process -components. Therefore we first have to find the correct position of the -string for the process in question. Therefore we look for a line -containing a pair of colons, in which case the line contains a process -string. Then we check if the process string describes the correct -process, which is done by checking for all the incoming and outgoing -particle names. If the process is correct, the dag output should start -in the following line. As long as we do not find the correct process -string, we continue searching. If we reach the end of the file, we -rewind the unit once, and repeat searching. If the process is still not -found, there must be some sort of error. -<>= - procedure :: read_string => dag_read_string -<>= - subroutine dag_read_string (dag, u_in, flv) - class (dag_t), intent (inout) :: dag - integer, intent (in) :: u_in - type(flavor_t), dimension(:), intent(in) :: flv - character (len=BUFFER_LEN) :: process_string - logical :: process_found - logical :: rewound -!!! find process string in file - process_found = .false. - rewound = .false. - do while (.not. process_found) - process_string = "" - read (unit=u_in, fmt='(A)') process_string - if (len_trim(process_string) /= 0) then - if (index (process_string, "::") > 0) then - process_found = process_string_match (trim (process_string), flv) - end if - else if (.not. rewound) then - rewind (u_in) - rewound = .true. - else - call msg_bug ("Process string not found in O'Mega input file.") - end if - enddo - call fds_file_get_line (u_in, dag%string) - call dag%string%clean () - if (.not. allocated (dag%string%t) .or. dag%string%char_len == 0) & - call msg_bug ("Process string not found in O'Mega input file.") - end subroutine dag_read_string +@ %def parameters +@ Computes $\xi_{\text{max}}$ in the case of ISR as documented in eq. \ref{eqn:xi_max_isr}. +<>= + function get_xi_max_isr (xb, y) result (xi_max) + real(default) :: xi_max + real(default), dimension(2), intent(in) :: xb + real(default), intent(in) :: y + xi_max = one - max (xi_max_isr_plus (xb(I_PLUS), y), xi_max_isr_minus (xb(I_MINUS), y)) + contains + function xi_max_isr_plus (x, y) + real(default) :: xi_max_isr_plus + real(default), intent(in) :: x, y + real(default) :: deno + deno = sqrt ((one + x**2)**2 * (one - y)**2 + 16 * y * x**2) + (one - y) * (1 - x**2) + xi_max_isr_plus = two * (one + y) * x**2 / deno + end function xi_max_isr_plus -@ %def dag_read_string -@ The output of factorized Feynman diagrams which is created by O'Mega -for a given process could in principle be written to a single line in -the file. This can however lead to different problems with different -compilers as soon as such lines become too long. This is the reason why -the line is cut into smaller pieces. This means that a new line starts -after each vertical bar. For this long string the type [[dag_string_t]] -has been introduced. In order to read the file quickly into such a -[[dag_string]] we use another type, [[dag_chain_t]] which is a linked -list of such [[dag_strings]]. This has the advantage that we do not -have to recreate a new [[dag_string]] for every line which has been -read from file. Only in the end of this operation we compress the -list of strings to a single string, removing useless [[dag_tokens]], -such as blanc space tokens. This subroutine reads all lines starting -from the position in the file the unit is connected to, until no -backslash character is found at the end of a line (the backslash -means that the next line also belongs to the current string). -<>= - integer, parameter :: BUFFER_LEN = 1000 - integer, parameter :: STACK_SIZE = 100 -@ %def BUFFER_LEN STACK_SIZE -<>= - subroutine fds_file_get_line (u, string) - integer, intent (in) :: u - type (dag_string_t), intent (out) :: string - type (dag_chain_t) :: chain - integer :: string_size, current_len - character (len=BUFFER_LEN) :: buffer - integer :: fragment_len - integer :: stat - current_len = 0 - stat = 0 - string_size = 0 - do while (stat == 0) - read (unit=u, fmt='(A)', iostat=stat) buffer - if (stat /= 0) exit - fragment_len = len_trim (buffer) - if (fragment_len == 0) then - exit - else if (buffer (fragment_len:fragment_len) == BACKSLASH_CHAR) then - fragment_len = fragment_len - 1 - end if - call chain%append (buffer(:fragment_len)) - if (buffer(fragment_len+1:fragment_len+1) /= BACKSLASH_CHAR) exit - enddo - if (associated (chain%first)) then - call chain%compress () - string = chain%first - call chain%final () - end if - end subroutine fds_file_get_line + function xi_max_isr_minus (x, y) + real(default) :: xi_max_isr_minus + real(default), intent(in) :: x, y + real(default) :: deno + deno = sqrt ((one + x**2)**2 * (one + y)**2 - 16 * y * x**2) + (one + y) * (1 - x**2) + xi_max_isr_minus = two * (one - y) * x**2 / deno + end function xi_max_isr_minus + end function get_xi_max_isr -@ %def fds_file_get_line -@ We check, if the process string which has been read from file -corresponds to the process for which we want to extract the Feynman -diagrams. -<>= - function process_string_match (string, flv) result (match) - character (len=*), intent(in) :: string - type(flavor_t), dimension(:), intent(in) :: flv - logical :: match - integer :: pos - integer :: occurence - integer :: i - pos = 1 - match = .false. - do i=1, size (flv) - occurence = index (string(pos:), char(flv(i)%get_name())) - if (occurence > 0) then - pos = pos + occurence - match = .true. - else - match = .false. - exit - end if - enddo - end function process_string_match +@ %def get_xi_max_isr +@ +<>= + recursive function get_xi_max_isr_decay (p) result (xi_max) + real(default) :: xi_max + type(vector4_t), dimension(:), intent(in) :: p + integer :: n_tot + type(vector4_t), dimension(:), allocatable :: p_dec_new + n_tot = size (p) + if (n_tot == 3) then + xi_max = xi_max_one_to_two (p(1), p(2), p(3)) + else + allocate (p_dec_new (n_tot - 1)) + p_dec_new(1) = sum (p (3 : )) + p_dec_new(2 : n_tot - 1) = p (3 : n_tot) + xi_max = min (xi_max_one_to_two (p(1), p(2), sum(p(3 : ))), & + get_xi_max_isr_decay (p_dec_new)) + end if + contains + function xi_max_one_to_two (p_in, p_out1, p_out2) result (xi_max) + real(default) :: xi_max + type(vector4_t), intent(in) :: p_in, p_out1, p_out2 + real(default) :: m_in, m_out1, m_out2 + m_in = p_in**1 + m_out1 = p_out1**1; m_out2 = p_out2**1 + xi_max = one - (m_out1 + m_out2)**2 / m_in**2 + end function xi_max_one_to_two + end function get_xi_max_isr_decay -@ %def process_string_match +@ %def get_xi_max_isr_decay @ -\subsection{Particle properties} -This subroutine initializes a model instance with the Standard Model -data. It is only relevant for a unit test. -We do not have to care about the model initialization in this module -because the [[model]] is passed to [[feyngraph_set_generate]] when -it is called. -<>= - public :: init_sm_full_test -<>= - subroutine init_sm_full_test (model) - class(model_data_t), intent(out) :: model - type(field_data_t), pointer :: field - integer, parameter :: n_real = 17 - integer, parameter :: n_field = 21 - integer, parameter :: n_vtx = 56 - integer :: i - call model%init (var_str ("SM_vertex_test"), & - n_real, 0, n_field, n_vtx) - call model%init_par (1, var_str ("mZ"), 91.1882_default) - call model%init_par (2, var_str ("mW"), 80.419_default) - call model%init_par (3, var_str ("mH"), 125._default) - call model%init_par (4, var_str ("me"), 0.000510997_default) - call model%init_par (5, var_str ("mmu"), 0.105658389_default) - call model%init_par (6, var_str ("mtau"), 1.77705_default) - call model%init_par (7, var_str ("ms"), 0.095_default) - call model%init_par (8, var_str ("mc"), 1.2_default) - call model%init_par (9, var_str ("mb"), 4.2_default) - call model%init_par (10, var_str ("mtop"), 173.1_default) - call model%init_par (11, var_str ("wtop"), 1.523_default) - call model%init_par (12, var_str ("wZ"), 2.443_default) - call model%init_par (13, var_str ("wW"), 2.049_default) - call model%init_par (14, var_str ("wH"), 0.004143_default) - call model%init_par (15, var_str ("ee"), 0.3079561542961_default) - call model%init_par (16, var_str ("cw"), 8.819013863636E-01_default) - call model%init_par (17, var_str ("sw"), 4.714339240339E-01_default) - i = 0 - i = i + 1 - field => model%get_field_ptr_by_index (i) - call field%init (var_str ("D_QUARK"), 1) - call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2) - call field%set (name = [var_str ("d")], anti = [var_str ("dbar")]) - i = i + 1 - field => model%get_field_ptr_by_index (i) - call field%init (var_str ("U_QUARK"), 2) - call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2) - call field%set (name = [var_str ("u")], anti = [var_str ("ubar")]) - i = i + 1 - field => model%get_field_ptr_by_index (i) - call field%init (var_str ("S_QUARK"), 3) - call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2) - call field%set (mass_data=model%get_par_real_ptr (7)) - call field%set (name = [var_str ("s")], anti = [var_str ("sbar")]) - i = i + 1 - field => model%get_field_ptr_by_index (i) - call field%init (var_str ("C_QUARK"), 4) - call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2) - call field%set (mass_data=model%get_par_real_ptr (8)) - call field%set (name = [var_str ("c")], anti = [var_str ("cbar")]) - i = i + 1 - field => model%get_field_ptr_by_index (i) - call field%init (var_str ("B_QUARK"), 5) - call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2) - call field%set (mass_data=model%get_par_real_ptr (9)) - call field%set (name = [var_str ("b")], anti = [var_str ("bbar")]) - i = i + 1 - field => model%get_field_ptr_by_index (i) - call field%init (var_str ("T_QUARK"), 6) - call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2) - call field%set (mass_data=model%get_par_real_ptr (10)) - call field%set (width_data=model%get_par_real_ptr (11)) - call field%set (name = [var_str ("t")], anti = [var_str ("tbar")]) - i = i + 1 - field => model%get_field_ptr_by_index (i) - call field%init (var_str ("E_LEPTON"), 11) - call field%set (spin_type=2) - call field%set (mass_data=model%get_par_real_ptr (4)) - call field%set (name = [var_str ("e-")], anti = [var_str ("e+")]) - i = i + 1 - field => model%get_field_ptr_by_index (i) - call field%init (var_str ("E_NEUTRINO"), 12) - call field%set (spin_type=2, is_left_handed=.true.) - call field%set (name = [var_str ("nue")], anti = [var_str ("nuebar")]) - i = i + 1 - field => model%get_field_ptr_by_index (i) - call field%init (var_str ("MU_LEPTON"), 13) - call field%set (spin_type=2) - call field%set (mass_data=model%get_par_real_ptr (5)) - call field%set (name = [var_str ("mu-")], anti = [var_str ("mu+")]) - i = i + 1 - field => model%get_field_ptr_by_index (i) - call field%init (var_str ("MU_NEUTRINO"), 14) - call field%set (spin_type=2, is_left_handed=.true.) - call field%set (name = [var_str ("numu")], anti = [var_str ("numubar")]) - i = i + 1 - field => model%get_field_ptr_by_index (i) - call field%init (var_str ("TAU_LEPTON"), 15) - call field%set (spin_type=2) - call field%set (mass_data=model%get_par_real_ptr (6)) - call field%set (name = [var_str ("tau-")], anti = [var_str ("tau+")]) - i = i + 1 - field => model%get_field_ptr_by_index (i) - call field%init (var_str ("TAU_NEUTRINO"), 16) - call field%set (spin_type=2, is_left_handed=.true.) - call field%set (name = [var_str ("nutau")], anti = [var_str ("nutaubar")]) - i = i + 1 - field => model%get_field_ptr_by_index (i) - call field%init (var_str ("GLUON"), 21) - call field%set (spin_type=3, color_type=8) - call field%set (name = [var_str ("gl")]) - i = i + 1 - field => model%get_field_ptr_by_index (i) - call field%init (var_str ("PHOTON"), 22) - call field%set (spin_type=3) - call field%set (name = [var_str ("A")]) - i = i + 1 - field => model%get_field_ptr_by_index (i) - call field%init (var_str ("Z_BOSON"), 23) - call field%set (spin_type=3) - call field%set (mass_data=model%get_par_real_ptr (1)) - call field%set (width_data=model%get_par_real_ptr (12)) - call field%set (name = [var_str ("Z")]) - i = i + 1 - field => model%get_field_ptr_by_index (i) - call field%init (var_str ("W_BOSON"), 24) - call field%set (spin_type=3) - call field%set (mass_data=model%get_par_real_ptr (2)) - call field%set (width_data=model%get_par_real_ptr (13)) - call field%set (name = [var_str ("W+")], anti = [var_str ("W-")]) - i = i + 1 - field => model%get_field_ptr_by_index (i) - call field%init (var_str ("HIGGS"), 25) - call field%set (spin_type=1) - call field%set (mass_data=model%get_par_real_ptr (3)) - call field%set (width_data=model%get_par_real_ptr (14)) - call field%set (name = [var_str ("H")]) - i = i + 1 - field => model%get_field_ptr_by_index (i) - call field%init (var_str ("PROTON"), 2212) - call field%set (spin_type=2) - call field%set (name = [var_str ("p")], anti = [var_str ("pbar")]) -! call field%set (mass_data=model%get_par_real_ptr (12)) - i = i + 1 - field => model%get_field_ptr_by_index (i) - call field%init (var_str ("HADRON_REMNANT_SINGLET"), 91) - call field%set (color_type=1) - call field%set (name = [var_str ("hr1")]) - i = i + 1 - field => model%get_field_ptr_by_index (i) - call field%init (var_str ("HADRON_REMNANT_TRIPLET"), 92) - call field%set (color_type=3) - call field%set (name = [var_str ("hr3")], anti = [var_str ("hr3bar")]) - i = i + 1 - field => model%get_field_ptr_by_index (i) - call field%init (var_str ("HADRON_REMNANT_OCTET"), 93) - call field%set (color_type=8) - call field%set (name = [var_str ("hr8")]) - call model%freeze_fields () - i = 0 - i = i + 1 -!!! QED - call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("A")]) - i = i + 1 - call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("A")]) - i = i + 1 - call model%set_vertex (i, [var_str ("sbar"), var_str ("s"), var_str ("A")]) - i = i + 1 - call model%set_vertex (i, [var_str ("cbar"), var_str ("c"), var_str ("A")]) - i = i + 1 - call model%set_vertex (i, [var_str ("bbar"), var_str ("b"), var_str ("A")]) - i = i + 1 - call model%set_vertex (i, [var_str ("tbar"), var_str ("t"), var_str ("A")]) - i = i + 1 -!!! - call model%set_vertex (i, [var_str ("e+"), var_str ("e-"), var_str ("A")]) - i = i + 1 - call model%set_vertex (i, [var_str ("mu+"), var_str ("mu-"), var_str ("A")]) - i = i + 1 - call model%set_vertex (i, [var_str ("tau+"), var_str ("tau-"), var_str ("A")]) - i = i + 1 -!!! QCD - call model%set_vertex (i, [var_str ("gl"), var_str ("gl"), var_str ("gl")]) - i = i + 1 - call model%set_vertex (i, [var_str ("gl"), var_str ("gl"), & - var_str ("gl"), var_str ("gl")]) - i = i + 1 -!!! - call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("gl")]) - i = i + 1 - call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("gl")]) - i = i + 1 - call model%set_vertex (i, [var_str ("sbar"), var_str ("s"), var_str ("gl")]) - i = i + 1 - call model%set_vertex (i, [var_str ("cbar"), var_str ("c"), var_str ("gl")]) - i = i + 1 - call model%set_vertex (i, [var_str ("bbar"), var_str ("b"), var_str ("gl")]) - i = i + 1 - call model%set_vertex (i, [var_str ("tbar"), var_str ("t"), var_str ("gl")]) - i = i + 1 -!!! Neutral currents - call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("Z")]) - i = i + 1 - call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("Z")]) - i = i + 1 - call model%set_vertex (i, [var_str ("sbar"), var_str ("s"), var_str ("Z")]) - i = i + 1 - call model%set_vertex (i, [var_str ("cbar"), var_str ("c"), var_str ("Z")]) - i = i + 1 - call model%set_vertex (i, [var_str ("bbar"), var_str ("b"), var_str ("Z")]) - i = i + 1 - call model%set_vertex (i, [var_str ("tbar"), var_str ("t"), var_str ("Z")]) - i = i + 1 -!!! - call model%set_vertex (i, [var_str ("e+"), var_str ("e-"), var_str ("Z")]) - i = i + 1 - call model%set_vertex (i, [var_str ("mu+"), var_str ("muu-"), var_str ("Z")]) - i = i + 1 - call model%set_vertex (i, [var_str ("tau+"), var_str ("tau-"), var_str ("Z")]) - i = i + 1 - call model%set_vertex (i, [var_str ("nuebar"), var_str ("nue"), var_str ("Z")]) - i = i + 1 - call model%set_vertex (i, [var_str ("numubar"), var_str ("numu"), var_str ("Z")]) - i = i + 1 - call model%set_vertex (i, [var_str ("nutaubar"), var_str ("nutau"), & - var_str ("Z")]) - i = i + 1 -!!! Charged currents - call model%set_vertex (i, [var_str ("ubar"), var_str ("d"), var_str ("W+")]) - i = i + 1 - call model%set_vertex (i, [var_str ("cbar"), var_str ("s"), var_str ("W+")]) - i = i + 1 - call model%set_vertex (i, [var_str ("tbar"), var_str ("b"), var_str ("W+")]) - i = i + 1 - call model%set_vertex (i, [var_str ("dbar"), var_str ("u"), var_str ("W-")]) - i = i + 1 - call model%set_vertex (i, [var_str ("sbar"), var_str ("c"), var_str ("W-")]) - i = i + 1 - call model%set_vertex (i, [var_str ("bbar"), var_str ("t"), var_str ("W-")]) - i = i + 1 -!!! - call model%set_vertex (i, [var_str ("nuebar"), var_str ("e-"), var_str ("W+")]) - i = i + 1 - call model%set_vertex (i, [var_str ("numubar"), var_str ("mu-"), var_str ("W+")]) - i = i + 1 - call model%set_vertex (i, [var_str ("nutaubar"), var_str ("tau-"), var_str ("W+")]) - i = i + 1 - call model%set_vertex (i, [var_str ("e+"), var_str ("nue"), var_str ("W-")]) - i = i + 1 - call model%set_vertex (i, [var_str ("mu+"), var_str ("numu"), var_str ("W-")]) - i = i + 1 - call model%set_vertex (i, [var_str ("tau+"), var_str ("nutau"), var_str ("W-")]) - i = i + 1 -!!! Yukawa -!!! keeping only 3rd generation for the moment - ! call model%set_vertex (i, [var_str ("sbar"), var_str ("s"), var_str ("H")]) - ! i = i + 1 - ! call model%set_vertex (i, [var_str ("cbar"), var_str ("c"), var_str ("H")]) - ! i = i + 1 - call model%set_vertex (i, [var_str ("bbar"), var_str ("b"), var_str ("H")]) - i = i + 1 - call model%set_vertex (i, [var_str ("tbar"), var_str ("t"), var_str ("H")]) - i = i + 1 - ! call model%set_vertex (i, [var_str ("mubar"), var_str ("mu"), var_str ("H")]) - ! i = i + 1 - call model%set_vertex (i, [var_str ("taubar"), var_str ("tau"), var_str ("H")]) - i = i + 1 -!!! Vector-boson self-interactions - call model%set_vertex (i, [var_str ("W+"), var_str ("W-"), var_str ("A")]) - i = i + 1 - call model%set_vertex (i, [var_str ("W+"), var_str ("W-"), var_str ("Z")]) - i = i + 1 -!!! - call model%set_vertex (i, [var_str ("W+"), var_str ("W-"), var_str ("Z"), var_str ("Z")]) - i = i + 1 - call model%set_vertex (i, [var_str ("W+"), var_str ("W+"), var_str ("W-"), var_str ("W-")]) - i = i + 1 - call model%set_vertex (i, [var_str ("W+"), var_str ("W-"), var_str ("Z"), var_str ("A")]) - i = i + 1 - call model%set_vertex (i, [var_str ("W+"), var_str ("W-"), var_str ("A"), var_str ("A")]) - i = i + 1 -!!! Higgs - vector boson - ! call model%set_vertex (i, [var_str ("H"), var_str ("Z"), var_str ("A")]) - ! i = i + 1 - ! call model%set_vertex (i, [var_str ("H"), var_str ("A"), var_str ("A")]) - ! i = i + 1 - ! call model%set_vertex (i, [var_str ("H"), var_str ("gl"), var_str ("gl")]) - ! i = i + 1 -!!! - call model%set_vertex (i, [var_str ("H"), var_str ("W+"), var_str ("W-")]) - i = i + 1 - call model%set_vertex (i, [var_str ("H"), var_str ("Z"), var_str ("Z")]) - i = i + 1 - call model%set_vertex (i, [var_str ("H"), var_str ("H"), var_str ("W+"), var_str ("W-")]) - i = i + 1 - call model%set_vertex (i, [var_str ("H"), var_str ("H"), var_str ("Z"), var_str ("Z")]) - i = i + 1 -!!! Higgs self-interactions - call model%set_vertex (i, [var_str ("H"), var_str ("H"), var_str ("H")]) - i = i + 1 - call model%set_vertex (i, [var_str ("H"), var_str ("H"), var_str ("H"), var_str ("H")]) - i = i + 1 - call model%freeze_vertices () - end subroutine init_sm_full_test +\subsection{Creation of the real phase space - ISR} +<>= + procedure :: generate_isr => phs_fks_generate_isr +<>= + module subroutine phs_fks_generate_isr (phs, i_phs, p_real) + class(phs_fks_t), intent(inout) :: phs + integer, intent(in) :: i_phs + type(vector4_t), intent(inout), dimension(:) :: p_real + end subroutine phs_fks_generate_isr +<>= + module subroutine phs_fks_generate_isr (phs, i_phs, p_real) + class(phs_fks_t), intent(inout) :: phs + integer, intent(in) :: i_phs + type(vector4_t), intent(inout), dimension(:) :: p_real + type(vector4_t) :: p0, p1 + type(lorentz_transformation_t) :: lt + real(default) :: sqrts_hat + type(vector4_t), dimension(:), allocatable :: p_work -@ %def init_sm_full_test -@ Initialize a [[part_prop]] object by passing a [[particle_label]], -which is simply the particle name. [[part_prop]] should be part of the -[[particle]] array of [[feyngraph_set]]. We use the [[model]] of -[[feyngraph_set]] to obtain the relevant data of the particle which is -needed to find [[phase_space]] parametrizations. When a [[part_prop]] -is initialized, we add and initialize also the corresponding anti- -particle [[part_prop]] if it is not yet in the array. -<>= - procedure :: init => part_prop_init -<>= - recursive subroutine part_prop_init (part_prop, feyngraph_set, particle_label) - class (part_prop_t), intent (out), target :: part_prop - type (feyngraph_set_t), intent (inout) :: feyngraph_set - character (len=*), intent (in) :: particle_label - type (flavor_t) :: flv, anti - type (string_t) :: name - integer :: i - name = particle_label - call flv%init (name, feyngraph_set%model) - part_prop%particle_label = particle_label - part_prop%pdg = flv%get_pdg () - part_prop%mass = flv%get_mass () - part_prop%width = flv%get_width() - part_prop%spin_type = flv%get_spin_type () - part_prop%is_vector = flv%get_spin_type () == VECTOR - part_prop%empty = .false. - part_prop%tex_name = flv%get_tex_name () - anti = flv%anti () - if (flv%get_pdg() == anti%get_pdg()) then - select type (part_prop) - type is (part_prop_t) - part_prop%anti => part_prop + associate (generator => phs%generator) + select case (generator%n_in) + case (1) + p_work = generator%real_kinematics%p_born_cms%phs_point(1) + call generator%generate_isr_fixed_beam_energy (i_phs, p_work, p_real) + phs%config%lab_is_cm = .true. + case (2) + select case (generator%isr_kinematics%isr_mode) + case (SQRTS_FIXED) + p_work = generator%real_kinematics%p_born_cms%phs_point(1) + call generator%generate_isr_fixed_beam_energy (i_phs, p_work, p_real) + case (SQRTS_VAR) + p_work = generator%real_kinematics%p_born_lab%phs_point(1) + call generator%generate_isr (i_phs, p_work, p_real) + end select end select - else - do i=1, size (feyngraph_set%particle) - if (feyngraph_set%particle(i)%pdg == (- part_prop%pdg)) then - part_prop%anti => feyngraph_set%particle(i) - exit - else if (feyngraph_set%particle(i)%empty) then - part_prop%anti => feyngraph_set%particle(i) - call feyngraph_set%particle(i)%init (feyngraph_set, char(anti%get_name())) - exit - end if - enddo - end if - end subroutine part_prop_init - -@ %def part_prop_init -@ This subroutine assigns to a node the particle properties. Since these -properties do not change and are simply read from the model file, we -use pointers to the elements of the [[particle]] array of the -[[feyngraph_set]]. If there is no corresponding array element, we -have to initialize the first empty element of the array. -<>= - integer, parameter :: PRT_ARRAY_SIZE = 200 -<>= - procedure :: assign_particle_properties => f_node_assign_particle_properties -<>= - subroutine f_node_assign_particle_properties (node, feyngraph_set) - class (f_node_t), intent (inout ) :: node - type (feyngraph_set_t), intent (inout) :: feyngraph_set - character (len=LABEL_LEN) :: particle_label - integer :: i - particle_label = node%particle_label(1:index (node%particle_label, '[')-1) - if (.not. associated (feyngraph_set%particle)) then - allocate (feyngraph_set%particle (PRT_ARRAY_SIZE)) - end if - do i = 1, size (feyngraph_set%particle) - if (particle_label == feyngraph_set%particle(i)%particle_label) then - node%particle => feyngraph_set%particle(i) - exit - else if (feyngraph_set%particle(i)%empty) then - call feyngraph_set%particle(i)%init (feyngraph_set, particle_label) - node%particle => feyngraph_set%particle(i) - exit - end if - enddo -!!! Since the O'Mega output uses the anti-particles instead of the particles specified -!!! in the process definition, we revert this here. An exception is the first particle -!!! in the parsable DAG output - node%particle => node%particle%anti - end subroutine f_node_assign_particle_properties - -@ %def f_node_assign_particle_properties -@ From the output of a Feynman diagram (in the non-factorized output) -we need to find out how many daughter nodes would be required to -reconstruct it correctly, to make sure that we keep -only those [[feyngraphs]] which are constructed solely on the basis of -the 3-vertices which are provided by the model. The number of daughter -particles can easily be determined from the syntax of O'Mega's output: -The particle which appears before the colon ':' is the mother particle. -The particles or subtrees (i.e. whole parentheses) follow after the -colon and are separated by commas. -<>= - function get_n_daughters (subtree_string, pos_first_colon) & - result (n_daughters) - character (len=*), intent (in) :: subtree_string - integer, intent (in) :: pos_first_colon - integer :: n_daughters - integer :: n_open_par - integer :: i - n_open_par = 1 - n_daughters = 0 - if (len_trim(subtree_string) > 0) then - if (pos_first_colon > 0) then - do i=pos_first_colon, len_trim(subtree_string) - if (subtree_string(i:i) == ',') then - if (n_open_par == 1) n_daughters = n_daughters + 1 - else if (subtree_string(i:i) == '(') then - n_open_par = n_open_par + 1 - else if (subtree_string(i:i) == ')') then - n_open_par = n_open_par - 1 - end if - end do - if (n_open_par == 0) then - n_daughters = n_daughters + 1 - end if - end if - end if - end function get_n_daughters - -@ %def get_n_daughters -@ -\subsection{Reconstruction of trees} -The reconstruction of a tree or subtree with the non-factorized input can -be done recursively, i.e. we first find the root of the tree in the -string and create an [[f_node]]. Then we look for daughters, which in the -string appear either as single particles or subtrees (which are of the -same form as the tree which we want to reconstruct. Therefore the -subroutine can simply be called again and again until there are no more -daughter nodes to create. When we meet a vertex which requires more than -two daughter particles, we stop the recursion and disable the node using -its [[keep]] variable. Whenever a daughter node is not kept, we do not -keep the mother node as well. -<>= - recursive subroutine node_construct_subtree_rec (feyngraph_set, & - feyngraph, subtree_string, mother_node) - type (feyngraph_set_t), intent (inout) :: feyngraph_set - type (feyngraph_t), intent (inout) :: feyngraph - character (len=*), intent (in) :: subtree_string - type (f_node_t), pointer, intent (inout) :: mother_node - integer :: n_daughters - integer :: pos_first_colon - integer :: current_daughter - integer :: pos_subtree_begin, pos_subtree_end - integer :: i - integer :: n_open_par - if (.not. associated (mother_node)) then - call feyngraph_set%f_node_list%add_entry (subtree_string, mother_node, .true.) - current_daughter = 1 - n_open_par = 1 - pos_first_colon = index (subtree_string, ':') - n_daughters = get_n_daughters (subtree_string, pos_first_colon) - if (pos_first_colon == 0) then - mother_node%particle_label = subtree_string + generator%real_kinematics%p_real_lab%phs_point(i_phs) = p_real + if (.not. phs%config%lab_is_cm) then + sqrts_hat = (p_real(1) + p_real(2))**1 + p0 = p_real(1) + p_real(2) + lt = boost (p0, sqrts_hat) + p1 = inverse(lt) * p_real(1) + lt = lt * rotation_to_2nd (3, space_part (p1)) + phs%generator%real_kinematics%p_real_cms%phs_point(i_phs) & + = inverse (lt) * p_real else - mother_node%particle_label = subtree_string(2:pos_first_colon-1) - end if - if (.not. associated (mother_node%particle)) then - call mother_node%assign_particle_properties (feyngraph_set) - end if - if (n_daughters /= 2 .and. n_daughters /= 0) then - mother_node%keep = .false. - feyngraph%keep = .false. - return - end if - pos_subtree_begin = pos_first_colon + 1 - do i = pos_first_colon + 1, len(trim(subtree_string)) - if (current_daughter == 2) then - pos_subtree_end = len(trim(subtree_string)) - 1 - call node_construct_subtree_rec (feyngraph_set, feyngraph, & - subtree_string(pos_subtree_begin:pos_subtree_end), & - mother_node%daughter2) - exit - else if (subtree_string(i:i) == ',') then - if (n_open_par == 1) then - pos_subtree_end = i - 1 - call node_construct_subtree_rec (feyngraph_set, feyngraph, & - subtree_string(pos_subtree_begin:pos_subtree_end), & - mother_node%daughter1) - current_daughter = 2 - pos_subtree_begin = i + 1 - end if - else if (subtree_string(i:i) == '(') then - n_open_par = n_open_par + 1 - else if (subtree_string(i:i) == ')') then - n_open_par = n_open_par - 1 - end if - end do - end if - if (associated (mother_node%daughter1)) then - if (.not. mother_node%daughter1%keep) then - mother_node%keep = .false. - end if - end if - if (associated (mother_node%daughter2)) then - if (.not. mother_node%daughter2%keep) then - mother_node%keep = .false. + phs%generator%real_kinematics%p_real_cms%phs_point(i_phs) & + = p_real end if - end if - if (associated (mother_node%daughter1) .and. & - associated (mother_node%daughter2)) then - mother_node%n_subtree_nodes = & - mother_node%daughter1%n_subtree_nodes & - + mother_node%daughter2%n_subtree_nodes + 1 - end if - if (.not. mother_node%keep) then - feyngraph%keep = .false. - end if - end subroutine node_construct_subtree_rec + end associate + end subroutine phs_fks_generate_isr -@ %def node_construct_subtree_rec -@ When the non-factorized version of the O'Mega output is used, the -[[feyngraph]] is reconstructed from the contents of its [[string_t]] -variable [[omega_feyngraph_output]]. This can be used for the recursive -reconstruction of the tree of [[k_nodes]] with -[[node_construct_subtree_rec]]. -<>= - subroutine feyngraph_construct (feyngraph_set, feyngraph) - type (feyngraph_set_t), intent (inout) :: feyngraph_set - type (feyngraph_t), pointer, intent (inout) :: feyngraph - call node_construct_subtree_rec (feyngraph_set, feyngraph, & - char(feyngraph%omega_feyngraph_output), feyngraph%root) - feyngraph%n_nodes = feyngraph%root%n_subtree_nodes - end subroutine feyngraph_construct +@ %def phs_fks_generate_isr +@ The real phase space for an inital-state emission involved in a decay +process is generated by first setting the gluon momentum like in the +scattering case by using its angular coordinates $y$ and $\phi$ and then +adjusting the gluon energy with $\xi$. The emitter momentum is kept +identical to the Born case, i.e. $p_{\rm{in}} = \bar{p}_{\rm{in}}$, so +that after the emission it has momentum $p_{\rm{virt}} = p_{\rm{in}} - +p_{\rm{g}}$ and invariant mass $m^2 = p_{\rm{virt}}^2$. Note that the +final state momenta have to remain on-shell, so that $p_1^2 = +\bar{p}_1^2 = m_1^2$ and $p_2^2 = \bar{p}_2^2 = m_2^2$. Let $\Lambda$ be +the boost from into the rest frame of the emitter after emission, i.e. +$\Lambda p_{\rm{virt}} = \left(m, 0, 0, 0\right)$. In this reference +frame, the spatial components of the final-state momenta sum up to zero, +and their magnitude is +\begin{equation*} + p = \frac{\sqrt {\lambda (m^2, m_1^2, m_2^2)}}{2m}, +\end{equation*} +a fact already used in the evaluation of the phase space trees of +[[phs_forest]]. Obviously, from this, the final-state energies can be +deferred via $E_i^2 = m_i^2 - p^2$. In the next step, the $p_{1,2}$ are +set up as vectors $(E,0,0,\pm p)$ along the z-axis and then rotated +about the same azimuthal and polar angles as in the Born system. +Finally, the momenta are boosted out of the rest frame by multiplying +with $\Lambda$. +<>= + procedure :: generate_isr_fixed_beam_energy => & + phs_fks_generator_generate_isr_fixed_beam_energy +<>= + module subroutine phs_fks_generator_generate_isr_fixed_beam_energy & + (generator, i_phs, p_born, p_real) + class(phs_fks_generator_t), intent(inout) :: generator + integer, intent(in) :: i_phs + type(vector4_t), intent(in), dimension(:) :: p_born + type(vector4_t), intent(inout), dimension(:) :: p_real + end subroutine phs_fks_generator_generate_isr_fixed_beam_energy +<>= + module subroutine phs_fks_generator_generate_isr_fixed_beam_energy & + (generator, i_phs, p_born, p_real) + class(phs_fks_generator_t), intent(inout) :: generator + integer, intent(in) :: i_phs + type(vector4_t), intent(in), dimension(:) :: p_born + type(vector4_t), intent(inout), dimension(:) :: p_real + real(default) :: xi_max, xi, y, phi + integer :: nlegborn, nlegreal, i + real(default) :: k0_np1 + real(default) :: msq_in + type(vector4_t) :: p_virt + real(default) :: jac_real -@ %def feyngraph_construct -@ We introduce another node type, which is called [[dag_node_t]] and -is used to reproduce the dag structure which is represented by the input. -The [[dag_nodes]] can have several combinations of daughters 1 and 2. -The [[dag]] type contains an array of [[dag_nodes]] and is only used -for the reconstruction of [[feyngraphs]] which are factorized as well, but -in the other direction as the original output. This means in particular -that the outgoing particles in the output file (which there can appear -many times) exist only once as [[f_nodes]]. To represent combinations of -daughters and alternatives (options), we further use the types -[[dag_options_t]] and [[dag_combination_t]]. The [[dag_nodes]], -[[dag_options]] and [[dag_combinations]] correspond to a substring of -the string which has been read from file (and transformed into an object -of type [[dag_string_t]], which is simply another compact representation -of this string), or a modified version of this substring. The aim is to -create only one object for a given substring, even if it appears several -times in the original string and then create trees of [[f_nodes]], which -build up the [[feyngraph]], such that as many [[f_nodes]] as possible can be reused. -An outgoing particle (always interpreting the input as a decay) is -called a [[leaf]] in the context of a [[dag]]. -<>= - type :: dag_node_t - integer :: string_len - type (dag_string_t) :: string - logical :: leaf = .false. - type (f_node_ptr_t), dimension (:), allocatable :: f_node - integer :: subtree_size = 0 - contains - <> - end type dag_node_t + associate (rad_var => generator%real_kinematics) + xi_max = rad_var%xi_max(i_phs) + xi = rad_var%xi_tilde * xi_max + y = rad_var%y(i_phs) + phi = rad_var%phi + rad_var%y_soft(i_phs) = y + end associate -@ %def dag_node_t -<>= - procedure :: final => dag_node_final -<>= - subroutine dag_node_final (dag_node) - class (dag_node_t), intent (inout) :: dag_node - integer :: i - call dag_node%string%final () - if (allocated (dag_node%f_node)) then - do i=1, size (dag_node%f_node) - if (associated (dag_node%f_node(i)%node)) then - call dag_node%f_node(i)%node%final () - deallocate (dag_node%f_node(i)%node) - end if - enddo - deallocate (dag_node%f_node) - end if - end subroutine dag_node_final + nlegborn = size (p_born) + nlegreal = nlegborn + 1 -@ %def dag_node_final -@ Whenever there are more than one possible subtrees (represented by -a [[dag_node]]) or combinations of subtrees to daughters (represented -by [[dag_combination_t]]), we use the type [[dag_options_t]]. In the -syntax of the factorized output, options are listed within curly -braces, separated by horizontal bars. -<>= - type :: dag_options_t - integer :: string_len - type (dag_string_t) :: string - type (f_node_ptr_t), dimension (:), allocatable :: f_node_ptr1 - type (f_node_ptr_t), dimension (:), allocatable :: f_node_ptr2 - contains - <> - end type dag_options_t + msq_in = sum (p_born(1:generator%n_in))**2 + generator%real_kinematics%jac(i_phs)%jac = one -@ %def dag_node_options_t -<>= - procedure :: final => dag_options_final -<>= - subroutine dag_options_final (dag_options) - class (dag_options_t), intent (inout) :: dag_options - integer :: i - call dag_options%string%final () - if (allocated (dag_options%f_node_ptr1)) then - do i=1, size (dag_options%f_node_ptr1) - dag_options%f_node_ptr1(i)%node => null () - enddo - deallocate (dag_options%f_node_ptr1) - end if - if (allocated (dag_options%f_node_ptr2)) then - do i=1, size (dag_options%f_node_ptr2) - dag_options%f_node_ptr2(i)%node => null () - enddo - deallocate (dag_options%f_node_ptr2) - end if - end subroutine dag_options_final + p_real(1) = p_born(1) + if (generator%n_in > 1) p_real(2) = p_born(2) + k0_np1 = zero + do i = 1, generator%n_in + k0_np1 = k0_np1 + p_real(i)%p(0) * xi / two + end do + p_real(nlegreal)%p(0) = k0_np1 + p_real(nlegreal)%p(1) = k0_np1 * sqrt(one - y**2) * sin(phi) + p_real(nlegreal)%p(2) = k0_np1 * sqrt(one - y**2) * cos(phi) + p_real(nlegreal)%p(3) = k0_np1 * y -@ %def dag_options_final -@ A pair of two daughters (which can be [[dag_nodes]] or [[dag_options]]) -is represented by the type [[dag_combination_t]]. In the original string, -a [[dag_combination]] appears between parentheses, which contain a comma, -but not a colon. If we find a colon between these parentheses, it is a -a [[dag_node]] instead. -<>= - type :: dag_combination_t - integer :: string_len - type (dag_string_t) :: string - integer, dimension (2) :: combination - type (f_node_ptr_t), dimension (:), allocatable :: f_node_ptr1 - type (f_node_ptr_t), dimension (:), allocatable :: f_node_ptr2 - contains - <> - end type dag_combination_t + p_virt = sum (p_real(1:generator%n_in)) - p_real(nlegreal) -@ %def dag_combination_t -<>= - procedure :: final => dag_combination_final -<>= - subroutine dag_combination_final (dag_combination) - class (dag_combination_t), intent (inout) :: dag_combination - integer :: i - call dag_combination%string%final () - if (allocated (dag_combination%f_node_ptr1)) then - do i=1, size (dag_combination%f_node_ptr1) - dag_combination%f_node_ptr1(i)%node => null () - enddo - deallocate (dag_combination%f_node_ptr1) - end if - if (allocated (dag_combination%f_node_ptr2)) then - do i=1, size (dag_combination%f_node_ptr2) - dag_combination%f_node_ptr2(i)%node => null () - enddo - deallocate (dag_combination%f_node_ptr2) - end if - end subroutine dag_combination_final + jac_real = one + call generate_on_shell_decay (p_virt, & + p_born(generator%n_in + 1 : nlegborn), & + p_real(generator%n_in + 1 : nlegreal - 1), 1, msq_in, jac_real) -@ %def dag_combination_final -@ Here is the type representing the DAG, i.e. it holds arrays of the -[[dag_nodes]], [[dag_options]] and [[dag_combinations]]. The root node -of the [[dag]] is the last filled element of the [[node]] array. -<>= - type :: dag_t - type (dag_string_t) :: string - type (dag_node_t), dimension (:), allocatable :: node - type (dag_options_t), dimension (:), allocatable :: options - type (dag_combination_t), dimension (:), allocatable :: combination - integer :: n_nodes = 0 - integer :: n_options = 0 - integer :: n_combinations = 0 - contains - <> - end type dag_t + associate (jac => generator%real_kinematics%jac(i_phs)) + jac%jac(1) = jac_real + jac%jac(2) = one + end associate -@ %def dag_t -<>= - procedure :: final => dag_final -<>= - subroutine dag_final (dag) - class (dag_t), intent (inout) :: dag - integer :: i - call dag%string%final () - if (allocated (dag%node)) then - do i=1, size (dag%node) - call dag%node(i)%final () - enddo - deallocate (dag%node) - end if - if (allocated (dag%options)) then - do i=1, size (dag%options) - call dag%options(i)%final () - enddo - deallocate (dag%options) - end if - if (allocated (dag%combination)) then - do i=1, size (dag%combination) - call dag%combination(i)%final () - enddo - deallocate (dag%combination) - end if - end subroutine dag_final + end subroutine phs_fks_generator_generate_isr_fixed_beam_energy -@ %def dag_final -@ We construct the DAG from the given [[dag_string]] which is modified -several times so that in the end the remaining string corresponds to a -simple [[dag_node]], the root of the factorized tree. This means that -we first identify the leaves, i.e. outgoing particles. Then we identify -[[dag_nodes]], [[dag_combinations]] and [[options]] until the number of -these objects does not change any more. Identifying means that we add -a corresponding object to the array (if not yet present), which can be identified -with the corresponding substring, and replace the substring in the -original [[dag_string]] by a [[dag_token]] of the corresponding type -(in the char output of this token, this corresponds to a place holder -like e.g. '' which in this particular case corresponds to an option -and can be found at the position 23 in the array). The character output -of the substrings turns out to be very useful for debugging. -<>= - procedure :: construct => dag_construct -<>= - subroutine dag_construct (dag, feyngraph_set) - class (dag_t), intent (inout) :: dag - type (feyngraph_set_t), intent (inout) :: feyngraph_set - integer :: n_nodes - integer :: n_options - integer :: n_combinations - logical :: continue_loop - integer :: subtree_size - integer :: i,j - subtree_size = 1 - call dag%get_nodes_and_combinations (leaves = .true.) - do i=1, dag%n_nodes - call dag%node(i)%make_f_nodes (feyngraph_set, dag) - enddo - continue_loop = .true. - subtree_size = subtree_size + 2 - do while (continue_loop) - n_nodes = dag%n_nodes - n_options = dag%n_options - n_combinations = dag%n_combinations - call dag%get_nodes_and_combinations (leaves = .false.) - if (n_nodes /= dag%n_nodes) then - dag%node(n_nodes+1:dag%n_nodes)%subtree_size = subtree_size - do i = n_nodes+1, dag%n_nodes - call dag%node(i)%make_f_nodes (feyngraph_set, dag) - enddo - subtree_size = subtree_size + 2 - end if - if (n_combinations /= dag%n_combinations) then - !$OMP PARALLEL DO - do i = n_combinations+1, dag%n_combinations - call dag%combination(i)%make_f_nodes (feyngraph_set, dag) - enddo - !$OMP END PARALLEL DO - end if - call dag%get_options () - if (n_options /= dag%n_options) then - !$OMP PARALLEL DO - do i = n_options+1, dag%n_options - call dag%options(i)%make_f_nodes (feyngraph_set, dag) - enddo - !$OMP END PARALLEL DO - end if - if (n_nodes == dag%n_nodes .and. n_options == dag%n_options & - .and. n_combinations == dag%n_combinations) then - continue_loop = .false. - end if - enddo -!!! add root node to dag - call dag%add_node (dag%string%t, leaf = .false.) - dag%node(dag%n_nodes)%subtree_size = subtree_size - call dag%node(dag%n_nodes)%make_f_nodes (feyngraph_set, dag) - if (debug2_active (D_PHASESPACE)) then - call dag%write (output_unit) - end if -!!! set indices for all f_nodes - do i=1, dag%n_nodes - if (allocated (dag%node(i)%f_node)) then - do j=1, size (dag%node(i)%f_node) - if (associated (dag%node(i)%f_node(j)%node)) & - call dag%node(i)%f_node(j)%node%set_index () - enddo - end if - enddo - end subroutine dag_construct +@ %def phs_fks_generator_generate_isr_fixed_beam_energy +@ +<>= + procedure :: generate_isr_factorized => & + phs_fks_generator_generate_isr_factorized +<>= + module subroutine phs_fks_generator_generate_isr_factorized & + (generator, i_phs, emitter, p_born, p_real) + class(phs_fks_generator_t), intent(inout) :: generator + integer, intent(in) :: i_phs, emitter + type(vector4_t), intent(in), dimension(:) :: p_born + type(vector4_t), intent(inout), dimension(:) :: p_real + end subroutine phs_fks_generator_generate_isr_factorized +<>= + module subroutine phs_fks_generator_generate_isr_factorized & + (generator, i_phs, emitter, p_born, p_real) + class(phs_fks_generator_t), intent(inout) :: generator + integer, intent(in) :: i_phs, emitter + type(vector4_t), intent(in), dimension(:) :: p_born + type(vector4_t), intent(inout), dimension(:) :: p_real + type(vector4_t), dimension(3) :: p_tmp_born + type(vector4_t), dimension(4) :: p_tmp_real + type(vector4_t) :: p_top + type(lorentz_transformation_t) :: boost_to_rest_frame + integer, parameter :: nlegreal = 7 + !!! Factorized phase space so far only required for ee -> bwbw -@ %def dag_construct -@ Identify [[dag_nodes]] and [[dag_combinations]]. Leaves are simply -nodes (i.e. of type [[NODE_TK]]) where only one bit in the bincode is -set. The [[dag_nodes]] and [[dag_combinations]] have in common that they -are surrounded by parentheses. There is however a way to distinguish -between them because the corresponding substring contains a colon (or -[[dag_token]] with type [[COLON_TK]]) if it is a [[dag_node]]. Otherwise -it is a [[dag_combination]]. The string of the [[dag_node]] or -[[dag_combination]] should not contain curly braces, because these -correspond to [[dag_options]] and should be identified before. -<>= - procedure :: get_nodes_and_combinations => dag_get_nodes_and_combinations -<>= - subroutine dag_get_nodes_and_combinations (dag, leaves) - class (dag_t), intent (inout) :: dag - logical, intent (in) :: leaves - type (dag_string_t) :: new_string - integer :: i, j, k - integer :: i_node - integer :: new_size - integer :: first_colon - logical :: combination -!!! Create nodes also for external particles, except for the incoming one which -!!! appears as the root of the tree. These can easily be identified by their -!!! bincodes, since they should contain only one bit which is set. - if (leaves) then - first_colon = minloc (dag%string%t%type, 1, dag%string%t%type == COLON_TK) - do i = first_colon + 1, size (dag%string%t) - if (dag%string%t(i)%type == NODE_TK) then - if (popcnt(dag%string%t(i)%bincode) == 1) then - call dag%add_node (dag%string%t(i:i), .true., i_node) - call dag%string%t(i)%init_dag_object_token (DAG_NODE_TK, i_node) - end if - end if - enddo - call dag%string%update_char_len () + p_tmp_born = vector4_null; p_tmp_real = vector4_null + p_real(1:2) = p_born(1:2) + if (emitter == THR_POS_B) then + p_top = p_born (THR_POS_WP) + p_born (THR_POS_B) + p_tmp_born(2) = p_born (THR_POS_WP) + p_tmp_born(3) = p_born (THR_POS_B) + else if (emitter == THR_POS_BBAR) then + p_top = p_born (THR_POS_WM) + p_born (THR_POS_BBAR) + p_tmp_born(2) = p_born (THR_POS_WM) + p_tmp_born(3) = p_born (THR_POS_BBAR) else -!!! Create a node or combination for every closed pair of parentheses -!!! which do not contain any other parentheses or curly braces. -!!! A node (not outgoing) contains a colon. This is not the case -!!! for combinations, which we use as the criteria to distinguish -!!! between both. - allocate (new_string%t (size (dag%string%t))) - i = 1 - new_size = 0 - do while (i <= size(dag%string%t)) - if (dag%string%t(i)%type == OPEN_PAR_TK) then - combination = .true. - do j = i+1, size (dag%string%t) - select case (dag%string%t(j)%type) - case (CLOSED_PAR_TK) - new_size = new_size + 1 - if (combination) then - call dag%add_combination (dag%string%t(i:j), i_node) - call new_string%t(new_size)%init_dag_object_token (DAG_COMBINATION_TK, i_node) - else - call dag%add_node (dag%string%t(i:j), leaves, i_node) - call new_string%t(new_size)%init_dag_object_token (DAG_NODE_TK, i_node) - end if - i = j + 1 - exit - case (OPEN_PAR_TK, OPEN_CURLY_TK, CLOSED_CURLY_TK) - new_size = new_size + 1 - new_string%t(new_size) = dag%string%t(i) - i = i + 1 - exit - case (COLON_TK) - combination = .false. - end select - enddo - else - new_size = new_size + 1 - new_string%t(new_size) = dag%string%t(i) - i = i + 1 - end if - enddo - dag%string = new_string%t(:new_size) - call dag%string%update_char_len () + call msg_fatal ("Threshold computation requires emitters to be at position 5 and 6 " // & + "Please check if your process specification fulfills this requirement.") end if - end subroutine dag_get_nodes_and_combinations - -@ %def dag_get_nodes_and_combinations -@ Identify [[dag_options]], i.e. lists of rival nodes or combinations -of nodes. These are identified by the surrounding curly braces. They -should not contain any parentheses any more, because these correspond -either to nodes or to combinations and should be identified before. -<>= - procedure :: get_options => dag_get_options -<>= - subroutine dag_get_options (dag) - class (dag_t), intent (inout) :: dag - type (dag_string_t) :: new_string - integer :: i, j, k - integer :: new_size - integer :: i_options - character (len=10) :: index_char - integer :: index_start, index_end -!!! Create a node or combination for every closed pair of parentheses -!!! which do not contain any other parentheses or curly braces. -!!! A node (not outgoing) contains a colon. This is not the case -!!! for combinations, which we use as the criteria to distinguish -!!! between both. - allocate (new_string%t (size (dag%string%t))) - i = 1 - new_size = 0 - do while (i <= size(dag%string%t)) - if (dag%string%t(i)%type == OPEN_CURLY_TK) then - do j = i+1, size (dag%string%t) - select case (dag%string%t(j)%type) - case (CLOSED_CURLY_TK) - new_size = new_size + 1 - call dag%add_options (dag%string%t(i:j), i_options) - call new_string%t(new_size)%init_dag_object_token (DAG_OPTIONS_TK, i_options) - i = j + 1 - exit - case (OPEN_PAR_TK, CLOSED_PAR_TK, OPEN_CURLY_TK) - new_size = new_size + 1 - new_string%t(new_size) = dag%string%t(i) - i = i + 1 - exit - end select - enddo - else - new_size = new_size + 1 - new_string%t(new_size) = dag%string%t(i) - i = i + 1 - end if - enddo - dag%string = new_string%t(:new_size) - call dag%string%update_char_len () - end subroutine dag_get_options + p_tmp_born (1) = p_top + boost_to_rest_frame = inverse (boost (p_top, p_top**1)) + p_tmp_born = boost_to_rest_frame * p_tmp_born + call generator%compute_xi_max_isr_factorized (i_phs, p_tmp_born) + call generator%generate_isr_fixed_beam_energy & + (i_phs, p_tmp_born, p_tmp_real) + p_tmp_real = inverse (boost_to_rest_frame) * p_tmp_real + if (emitter == THR_POS_B) then + p_real(THR_POS_WP) = p_tmp_real(2) + p_real(THR_POS_B) = p_tmp_real(3) + p_real(THR_POS_WM) = p_born(THR_POS_WM) + p_real(THR_POS_BBAR) = p_born(THR_POS_BBAR) + !!! Exception has been handled above + else + p_real(THR_POS_WM) = p_tmp_real(2) + p_real(THR_POS_BBAR) = p_tmp_real(3) + p_real(THR_POS_WP) = p_born(THR_POS_WP) + p_real(THR_POS_B) = p_born(THR_POS_B) + end if + p_real(nlegreal) = p_tmp_real(4) + end subroutine phs_fks_generator_generate_isr_factorized -@ %def dag_get_options -@ Add a [[dag_node]] to the list. The optional argument returns the index -of the node. The node might already exist. In this case we only return -the index. -<>= - procedure :: add_node => dag_add_node -<>= - integer, parameter :: DAG_STACK_SIZE = 1000 -<>= - subroutine dag_add_node (dag, string, leaf, i_node) - class (dag_t), intent (inout) :: dag - type (dag_token_t), dimension (:), intent (in) :: string - logical, intent (in) :: leaf - integer, intent (out), optional :: i_node - type (dag_node_t), dimension (:), allocatable :: tmp_node - integer :: string_len +@ %def phs_fks_generator_generate_isr_factorized +@ Construction of the real momenta [[p_real]] in case of ISR. +Follows the discussion in [0709.2092] sec. 5.1. +The sequence of Lorentz boosts required to construct [[p_real]] from +[[p_born]] is as follows: +\begin{enumerate} + \item[\labelitemii] We construct the IS momenta of [[p_real]] from + the Born momenta via rescaling: + [[p_real(1:2)]] $= \frac{x}{\overline{x}} \cdot$ [[p_born(1:2)]]. + If the Born momenta are imported in the lab frame, these will define + the real lab frame. + \item[\labelitemii] We construct the momentum of the radiated + particle in the real CMS: + $k_{n+1} = \frac{s \xi}{2} \cdot (1, \sin(\theta) \sin(\phi), + \sin(\theta) \cos(\phi), \cos(\theta))$ + \setcounter{enumi}{-1} + \item We first boost the momentum of the radiated particle from the + real CMS to the real lab frame determined from [[p_real(1:2)]]. + \item We initialize the non-radiated real FS momenta by a + longitudinal boost of [[p_born]] to a system with zero rapidity, + i.e. zero longitudinal momenum. This is $\mathbb{B}_L$. + \item We boost these momenta in a transverse direction to compensate + the transverse momentum of the radiation. This is + $\mathbb{B}_T$. Note: we switched $\mathbb{B}_T$ and + $\mathbb{B}^{-1}_T$ in Eq. (5.16) and their definition + w.r.t. [0709.2092]. + \item We restore longitudinal momentum conservation by applying the + inverse boost of $\mathbb{B}_L$ to all non-radiated real FS momenta. +\end{enumerate} +This way, all components of [[p_real]] are constructed in the real Lab frame. +<>= + procedure :: generate_isr => phs_fks_generator_generate_isr +<>= + module subroutine phs_fks_generator_generate_isr & + (generator, i_phs, p_born, p_real) + class(phs_fks_generator_t), intent(inout) :: generator + integer, intent(in) :: i_phs + type(vector4_t), intent(in) , dimension(:) :: p_born + type(vector4_t), intent(inout), dimension(:) :: p_real + end subroutine phs_fks_generator_generate_isr +<>= + module subroutine phs_fks_generator_generate_isr & + (generator, i_phs, p_born, p_real) + !!! Important: Import Born momenta in the lab frame + class(phs_fks_generator_t), intent(inout) :: generator + integer, intent(in) :: i_phs + type(vector4_t), intent(in) , dimension(:) :: p_born + type(vector4_t), intent(inout), dimension(:) :: p_real + real(default) :: xi_max, xi_tilde, xi, y, phi + integer :: nlegborn, nlegreal + real(default) :: sqrts_real + real(default) :: k0_np1 + type(lorentz_transformation_t) :: & + lambda_transv, lambda_longit, lambda_longit_inv + real(default) :: x_plus, x_minus, xb_plus, xb_minus + real(default) :: onemy, onepy integer :: i - string_len = sum (string%char_len) - if (.not. allocated (dag%node)) then - allocate (dag%node (DAG_STACK_SIZE)) - else if (dag%n_nodes == size (dag%node)) then - allocate (tmp_node (dag%n_nodes)) - tmp_node = dag%node - deallocate (dag%node) - allocate (dag%node (dag%n_nodes+DAG_STACK_SIZE)) - dag%node(:dag%n_nodes) = tmp_node - deallocate (tmp_node) - end if - do i = 1, dag%n_nodes - if (dag%node(i)%string_len == string_len) then - if (size (dag%node(i)%string%t) == size (string)) then - if (all(dag%node(i)%string%t == string)) then - if (present (i_node)) i_node = i - return - end if - end if - end if - enddo - dag%n_nodes = dag%n_nodes + 1 - dag%node(dag%n_nodes)%string = string - dag%node(dag%n_nodes)%string_len = string_len - if (present (i_node)) i_node = dag%n_nodes - dag%node(dag%n_nodes)%leaf = leaf - end subroutine dag_add_node + real(default) :: xi_plus, xi_minus + real(default) :: beta_gamma + type(vector3_t) :: beta_vec -@ %def dag_add_node -@ A similar subroutine for options. -<>= - procedure :: add_options => dag_add_options -<>= - subroutine dag_add_options (dag, string, i_options) - class (dag_t), intent (inout) :: dag - type (dag_token_t), dimension (:), intent (in) :: string - integer, intent (out), optional :: i_options - type (dag_options_t), dimension (:), allocatable :: tmp_options - integer :: string_len - integer :: i - string_len = sum (string%char_len) - if (.not. allocated (dag%options)) then - allocate (dag%options (DAG_STACK_SIZE)) - else if (dag%n_options == size (dag%options)) then - allocate (tmp_options (dag%n_options)) - tmp_options = dag%options - deallocate (dag%options) - allocate (dag%options (dag%n_options+DAG_STACK_SIZE)) - dag%options(:dag%n_options) = tmp_options - deallocate (tmp_options) - end if - do i = 1, dag%n_options - if (dag%options(i)%string_len == string_len) then - if (size (dag%options(i)%string%t) == size (string)) then - if (all(dag%options(i)%string%t == string)) then - if (present (i_options)) i_options = i - return - end if - end if - end if - enddo - dag%n_options = dag%n_options + 1 - dag%options(dag%n_options)%string = string - dag%options(dag%n_options)%string_len = string_len - if (present (i_options)) i_options = dag%n_options - end subroutine dag_add_options + associate (rad_var => generator%real_kinematics) + xi_max = rad_var%xi_max(i_phs) + xi_tilde = rad_var%xi_tilde + xi = xi_tilde * xi_max + y = rad_var%y(i_phs) + onemy = one - y; onepy = one + y + phi = rad_var%phi + rad_var%y_soft(i_phs) = y + end associate -@ %def dag_add_options -@ A similar subroutine for combinations. -<>= - procedure :: add_combination => dag_add_combination -<>= - subroutine dag_add_combination (dag, string, i_combination) - class (dag_t), intent (inout) :: dag - type (dag_token_t), dimension (:), intent (in) :: string - integer, intent (out), optional :: i_combination - type (dag_combination_t), dimension (:), allocatable :: tmp_combination - integer :: string_len - integer :: i - string_len = sum (string%char_len) - if (.not. allocated (dag%combination)) then - allocate (dag%combination (DAG_STACK_SIZE)) - else if (dag%n_combinations == size (dag%combination)) then - allocate (tmp_combination (dag%n_combinations)) - tmp_combination = dag%combination - deallocate (dag%combination) - allocate (dag%combination (dag%n_combinations+DAG_STACK_SIZE)) - dag%combination(:dag%n_combinations) = tmp_combination - deallocate (tmp_combination) - end if - do i = 1, dag%n_combinations - if (dag%combination(i)%string_len == string_len) then - if (size (dag%combination(i)%string%t) == size (string)) then - if (all(dag%combination(i)%string%t == string)) then - i_combination = i - return - end if - end if - end if - enddo - dag%n_combinations = dag%n_combinations + 1 - dag%combination(dag%n_combinations)%string = string - dag%combination(dag%n_combinations)%string_len = string_len - if (present (i_combination)) i_combination = dag%n_combinations - end subroutine dag_add_combination + nlegborn = size (p_born) + nlegreal = nlegborn + 1 + generator%isr_kinematics%sqrts_born = (p_born(1) + p_born(2))**1 -@ %def dag_add_combination -@ For a given [[dag_node]] we want to create all [[f_nodes]]. If the node -is not a leaf, it contains in its string placeholders for options or -combinations. For these objects there are similar subroutines which are -needed here to obtain the sets of daughter nodes. If the [[dag_node]] is -a leaf, it corresponds to an external particle and the token contains the -particle name. -<>= - procedure :: make_f_nodes => dag_node_make_f_nodes -<>= - subroutine dag_node_make_f_nodes (dag_node, feyngraph_set, dag) - class (dag_node_t), intent (inout) :: dag_node - type (feyngraph_set_t), intent (inout) :: feyngraph_set - type (dag_t), intent (inout) :: dag - character (len=LABEL_LEN) :: particle_label - integer :: i, j - integer, dimension (2) :: obj - integer, dimension (2) :: i_obj - integer :: n_obj - integer :: pos - integer :: new_size, size1, size2 - integer, dimension(:), allocatable :: match - if (allocated (dag_node%f_node)) return - pos = minloc (dag_node%string%t%type, 1,dag_node%string%t%type == NODE_TK) - particle_label = char (dag_node%string%t(pos)) - if (dag_node%leaf) then -!!! construct subtree with procedure similar to the one for the old output - allocate (dag_node%f_node(1)) - allocate (dag_node%f_node(1)%node) - dag_node%f_node(1)%node%particle_label = particle_label - call dag_node%f_node(1)%node%assign_particle_properties (feyngraph_set) - if (.not. dag_node%f_node(1)%node%keep) then - deallocate (dag_node%f_node) - return - end if - else - n_obj = 0 - do i = 1, size (dag_node%string%t) - select case (dag_node%string%t(i)%type) - case (DAG_NODE_TK, DAG_OPTIONS_TK, DAG_COMBINATION_TK) - n_obj = n_obj + 1 - if (n_obj > 2) return - obj(n_obj) = dag_node%string%t(i)%type - i_obj(n_obj) = dag_node%string%t(i)%index - end select - enddo - if (n_obj == 1) then - if (obj(1) == DAG_OPTIONS_TK) then - if (allocated (dag%options(i_obj(1))%f_node_ptr1)) then - size1 = size(dag%options(i_obj(1))%f_node_ptr1) - allocate (dag_node%f_node(size1)) - do i=1, size1 - allocate (dag_node%f_node(i)%node) - dag_node%f_node(i)%node%particle_label = particle_label - call dag_node%f_node(i)%node%assign_particle_properties (feyngraph_set) - dag_node%f_node(i)%node%daughter1 => dag%options(i_obj(1))%f_node_ptr1(i)%node - dag_node%f_node(i)%node%daughter2 => dag%options(i_obj(1))%f_node_ptr2(i)%node - dag_node%f_node(i)%node%n_subtree_nodes = & - dag%options(i_obj(1))%f_node_ptr1(i)%node%n_subtree_nodes & - + dag%options(i_obj(1))%f_node_ptr2(i)%node%n_subtree_nodes + 1 - enddo - end if - else if (obj(1) == DAG_COMBINATION_TK) then - if (allocated (dag%combination(i_obj(1))%f_node_ptr1)) then - size1 = size(dag%combination(i_obj(1))%f_node_ptr1) - allocate (dag_node%f_node(size1)) - do i=1, size1 - allocate (dag_node%f_node(i)%node) - dag_node%f_node(i)%node%particle_label = particle_label - call dag_node%f_node(i)%node%assign_particle_properties (feyngraph_set) - dag_node%f_node(i)%node%daughter1 => dag%combination(i_obj(1))%f_node_ptr1(i)%node - dag_node%f_node(i)%node%daughter2 => dag%combination(i_obj(1))%f_node_ptr2(i)%node - dag_node%f_node(i)%node%n_subtree_nodes = & - dag%combination(i_obj(1))%f_node_ptr1(i)%node%n_subtree_nodes & - + dag%combination(i_obj(1))%f_node_ptr2(i)%node%n_subtree_nodes + 1 - enddo - end if - end if -!!! simply set daughter pointers, daughters are already combined correctly - else if (n_obj == 2) then - size1 = 0 - size2 = 0 - if (obj(1) == DAG_NODE_TK) then - if (allocated (dag%node(i_obj(1))%f_node)) then - do i=1, size (dag%node(i_obj(1))%f_node) - if (dag%node(i_obj(1))%f_node(i)%node%keep) size1 = size1 + 1 - enddo - end if - else if (obj(1) == DAG_OPTIONS_TK) then - if (allocated (dag%options(i_obj(1))%f_node_ptr1)) then - do i=1, size (dag%options(i_obj(1))%f_node_ptr1) - if (dag%options(i_obj(1))%f_node_ptr1(i)%node%keep) size1 = size1 + 1 - enddo - end if - end if - if (obj(2) == DAG_NODE_TK) then - if (allocated (dag%node(i_obj(2))%f_node)) then - do i=1, size (dag%node(i_obj(2))%f_node) - if (dag%node(i_obj(2))%f_node(i)%node%keep) size2 = size2 + 1 - enddo - end if - else if (obj(2) == DAG_OPTIONS_TK) then - if (allocated (dag%options(i_obj(2))%f_node_ptr1)) then - do i=1, size (dag%options(i_obj(2))%f_node_ptr1) - if (dag%options(i_obj(2))%f_node_ptr1(i)%node%keep) size2 = size2 + 1 - enddo - end if - end if -!!! make all combinations of daughters - select case (obj(1)) - case (DAG_NODE_TK) - select case (obj(2)) - case (DAG_NODE_TK) - call combine_all_daughters(dag%node(i_obj(1))%f_node, & - dag%node(i_obj(2))%f_node) - case (DAG_OPTIONS_TK) - call combine_all_daughters(dag%node(i_obj(1))%f_node, & - dag%options(i_obj(2))%f_node_ptr1) - end select - case (DAG_OPTIONS_TK) - select case (obj(2)) - case (DAG_NODE_TK) - call combine_all_daughters(dag%options(i_obj(1))%f_node_ptr1, & - dag%node(i_obj(2))%f_node) - case (DAG_OPTIONS_TK) - call combine_all_daughters(dag%options(i_obj(1))%f_node_ptr1, & - dag%options(i_obj(2))%f_node_ptr1) - end select - end select - end if - end if + !!! Initial state real momenta + xb_plus = generator%isr_kinematics%x(I_PLUS) + xb_minus = generator%isr_kinematics%x(I_MINUS) + x_plus = xb_plus / sqrt(one - xi) * sqrt ((two - xi * onemy) / & + (two - xi * onepy)) + x_minus = xb_minus / sqrt(one - xi) * sqrt ((two - xi * onepy) / & + (two - xi * onemy)) + xi_plus = xi_tilde * (one - xb_plus) + xi_minus = xi_tilde * (one - xb_minus) + p_real(I_PLUS) = x_plus / xb_plus * p_born(I_PLUS) + p_real(I_MINUS) = x_minus / xb_minus * p_born(I_MINUS) - contains + !!! Fraction of momentum fractions in a collinear splitting + generator%isr_kinematics%z(I_PLUS) = (one - xi_plus) + generator%isr_kinematics%z(I_MINUS) = (one - xi_minus) - subroutine combine_all_daughters (daughter1_ptr, daughter2_ptr) - type (f_node_ptr_t), dimension (:), intent (in) :: daughter1_ptr - type (f_node_ptr_t), dimension (:), intent (in) :: daughter2_ptr - integer :: i, j - integer :: pos - new_size = size1*size2 - allocate (dag_node%f_node(new_size)) - pos = 0 - do i = 1, size (daughter1_ptr) - if (daughter1_ptr(i)%node%keep) then - do j = 1, size (daughter2_ptr) - if (daughter2_ptr(j)%node%keep) then - pos = pos + 1 - allocate (dag_node%f_node(pos)%node) - dag_node%f_node(pos)%node%particle_label = particle_label - call dag_node%f_node(pos)%node%assign_particle_properties (feyngraph_set) - dag_node%f_node(pos)%node%daughter1 => daughter1_ptr(i)%node - dag_node%f_node(pos)%node%daughter2 => daughter2_ptr(j)%node - dag_node%f_node(pos)%node%n_subtree_nodes = daughter1_ptr(i)%node%n_subtree_nodes & - + daughter2_ptr(j)%node%n_subtree_nodes + 1 - call feyngraph_set%model%match_vertex (daughter1_ptr(i)%node%particle%pdg, & - daughter2_ptr(j)%node%particle%pdg, match) - if (allocated (match)) then - if (any (abs(match) == abs(dag_node%f_node(pos)%node%particle%pdg))) then - dag_node%f_node(pos)%node%keep = .true. - else - dag_node%f_node(pos)%node%keep = .false. - end if - deallocate (match) - else - dag_node%f_node(pos)%node%keep = .false. - end if - end if - enddo - end if - enddo - end subroutine combine_all_daughters - end subroutine dag_node_make_f_nodes + !!! Create radiation momentum in the real CMS + sqrts_real = generator%isr_kinematics%sqrts_born / sqrt (one - xi) + k0_np1 = sqrts_real * xi / two + p_real(nlegreal)%p(0) = k0_np1 + p_real(nlegreal)%p(1) = k0_np1 * sqrt (one - y**2) * sin(phi) + p_real(nlegreal)%p(2) = k0_np1 * sqrt (one - y**2) * cos(phi) + p_real(nlegreal)%p(3) = k0_np1 * y -@ %def dag_node_make_f_nodes -@ In [[dag_options_make_f_nodes_single]] -we obtain all [[f_nodes]] for [[dag_nodes]] which correspond to a -set of rival subtrees or nodes, which is the first possibility for -which [[dag_options]] can appear. -In [[dag_options_make_f_nodes_pair]] -the options are rival pairs ([[daughter1]], [[daughter2]]). -Therefore we have to pass two allocatable arrays of type [[f_node_ptr_t]] -to the subroutine. -<>= - procedure :: make_f_nodes => dag_options_make_f_nodes -<>= - subroutine dag_options_make_f_nodes (dag_options, & - feyngraph_set, dag) - class (dag_options_t), intent (inout) :: dag_options - type (feyngraph_set_t), intent (inout) :: feyngraph_set - type (dag_t), intent (inout) :: dag - integer, dimension (:), allocatable :: obj, i_obj - integer :: n_obj - integer :: i - integer :: pos -!!! read options - if (allocated (dag_options%f_node_ptr1)) return - n_obj = count ((dag_options%string%t%type == DAG_NODE_TK) .or. & - (dag_options%string%t%type == DAG_OPTIONS_TK) .or. & - (dag_options%string%t%type == DAG_COMBINATION_TK), 1) - allocate (obj(n_obj)); allocate (i_obj(n_obj)) - pos = 0 - do i = 1, size (dag_options%string%t) - select case (dag_options%string%t(i)%type) - case (DAG_NODE_TK, DAG_OPTIONS_TK, DAG_COMBINATION_TK) - pos = pos + 1 - obj(pos) = dag_options%string%t(i)%type - i_obj(pos) = dag_options%string%t(i)%index - end select - enddo - if (any (dag_options%string%t%type == DAG_NODE_TK)) then - call dag_options_make_f_nodes_single - else if (any (dag_options%string%t%type == DAG_COMBINATION_TK)) then - call dag_options_make_f_nodes_pair - end if - deallocate (obj, i_obj) + !!! Boosts the radiation from real CMS to the real LAB frame + call get_boost_parameters (p_real, beta_gamma, beta_vec) + lambda_longit = create_longitudinal_boost & + (beta_gamma, beta_vec, inverse = .true.) + p_real(nlegreal) = lambda_longit * p_real(nlegreal) - contains + call get_boost_parameters (p_born, beta_gamma, beta_vec) + lambda_longit = create_longitudinal_boost & + (beta_gamma, beta_vec, inverse = .false.) + forall (i = 3 : nlegborn) p_real(i) = lambda_longit * p_born(i) - subroutine dag_options_make_f_nodes_single - integer :: i_start, i_end - integer :: n_nodes - n_nodes = 0 - do i=1, n_obj - if (allocated (dag%node(i_obj(i))%f_node)) then - n_nodes = n_nodes + size (dag%node(i_obj(i))%f_node) - end if - enddo - if (n_nodes /= 0) then - allocate (dag_options%f_node_ptr1 (n_nodes)) - i_end = 0 - do i = 1, n_obj - if (allocated (dag%node(i_obj(i))%f_node)) then - i_start = i_end + 1 - i_end = i_end + size (dag%node(i_obj(i))%f_node) - dag_options%f_node_ptr1(i_start:i_end) = dag%node(i_obj(i))%f_node - end if - enddo - end if - end subroutine dag_options_make_f_nodes_single + lambda_transv = create_transversal_boost (p_real(nlegreal), xi, sqrts_real) + forall (i = 3 : nlegborn) p_real(i) = lambda_transv * p_real(i) - subroutine dag_options_make_f_nodes_pair - integer :: i_start, i_end - integer :: n_nodes -!!! get f_nodes from each combination - n_nodes = 0 - do i=1, n_obj - if (allocated (dag%combination(i_obj(i))%f_node_ptr1)) then - n_nodes = n_nodes + size (dag%combination(i_obj(i))%f_node_ptr1) - end if - enddo - if (n_nodes /= 0) then - allocate (dag_options%f_node_ptr1 (n_nodes)) - allocate (dag_options%f_node_ptr2 (n_nodes)) - i_end = 0 - do i=1, n_obj - if (allocated (dag%combination(i_obj(i))%f_node_ptr1)) then - i_start = i_end + 1 - i_end = i_end + size (dag%combination(i_obj(i))%f_node_ptr1) - dag_options%f_node_ptr1(i_start:i_end) = dag%combination(i_obj(i))%f_node_ptr1 - dag_options%f_node_ptr2(i_start:i_end) = dag%combination(i_obj(i))%f_node_ptr2 - end if - enddo - end if - end subroutine dag_options_make_f_nodes_pair - end subroutine dag_options_make_f_nodes + lambda_longit_inv = create_longitudinal_boost & + (beta_gamma, beta_vec, inverse = .true.) + forall (i = 3 : nlegborn) p_real(i) = lambda_longit_inv * p_real(i) -@ %def dag_options_make_f_nodes -@ We create all combinations of daughter [[f_nodes]] for a combination. -In the combination each daughter can be either a single [[dag_node]] or -[[dag_options]] which are a set of single [[dag_nodes]]. Therefore, we -first create all possible [[f_nodes]] for daughter1, then all possible -[[f_nodes]] for daughter2. In the end we combine all [[daughter1]] nodes -with all [[daughter2]] nodes. -<>= - procedure :: make_f_nodes => dag_combination_make_f_nodes -<>= - subroutine dag_combination_make_f_nodes (dag_combination, & - feyngraph_set, dag) - class (dag_combination_t), intent (inout) :: dag_combination - type (feyngraph_set_t), intent (inout) :: feyngraph_set - type (dag_t), intent (inout) :: dag - integer, dimension (2) :: obj, i_obj - integer :: n_obj - integer :: new_size, size1, size2 - integer :: i, j, pos - if (allocated (dag_combination%f_node_ptr1)) return - n_obj = 0 - do i = 1, size (dag_combination%string%t) - select case (dag_combination%string%t(i)%type) - case (DAG_NODE_TK, DAG_OPTIONS_TK, DAG_COMBINATION_TK) - n_obj = n_obj + 1 - if (n_obj > 2) return - obj(n_obj) = dag_combination%string%t(i)%type - i_obj(n_obj) = dag_combination%string%t(i)%index - end select - enddo - size1 = 0 - size2 = 0 - if (obj(1) == DAG_NODE_TK) then - if (allocated (dag%node(i_obj(1))%f_node)) & - size1 = size (dag%node(i_obj(1))%f_node) - else if (obj(1) == DAG_OPTIONS_TK) then - if (allocated (dag%options(i_obj(1))%f_node_ptr1)) & - size1 = size (dag%options(i_obj(1))%f_node_ptr1) - end if - if (obj(2) == DAG_NODE_TK) then - if (allocated (dag%node(i_obj(2))%f_node)) & - size2 = size (dag%node(i_obj(2))%f_node) - else if (obj(2) == DAG_OPTIONS_TK) then - if (allocated (dag%options(i_obj(2))%f_node_ptr1)) & - size2 = size (dag%options(i_obj(2))%f_node_ptr1) - end if -!!! combine the 2 arrays of f_nodes - new_size = size1*size2 - if (new_size /= 0) then - allocate (dag_combination%f_node_ptr1 (new_size)) - allocate (dag_combination%f_node_ptr2 (new_size)) - pos = 0 - select case (obj(1)) - case (DAG_NODE_TK) - select case (obj(2)) - case (DAG_NODE_TK) - do i = 1, size1 - do j = 1, size2 - pos = pos + 1 - dag_combination%f_node_ptr1(pos) = dag%node(i_obj(1))%f_node(i) - dag_combination%f_node_ptr2(pos) = dag%node(i_obj(2))%f_node(j) - enddo - enddo - case (DAG_OPTIONS_TK) - do i = 1, size1 - do j = 1, size2 - pos = pos + 1 - dag_combination%f_node_ptr1(pos) = dag%node(i_obj(1))%f_node(i) - dag_combination%f_node_ptr2(pos) = dag%options(i_obj(2))%f_node_ptr1(j) - enddo - enddo - end select - case (DAG_OPTIONS_TK) - select case (obj(2)) - case (DAG_NODE_TK) - do i = 1, size1 - do j = 1, size2 - pos = pos + 1 - dag_combination%f_node_ptr1(pos) = dag%options(i_obj(1))%f_node_ptr1(i) - dag_combination%f_node_ptr2(pos) = dag%node(i_obj(2))%f_node(j) - enddo - enddo - case (DAG_OPTIONS_TK) - do i = 1, size1 - do j = 1, size2 - pos = pos + 1 - dag_combination%f_node_ptr1(pos) = dag%options(i_obj(1))%f_node_ptr1(i) - dag_combination%f_node_ptr2(pos) = dag%options(i_obj(2))%f_node_ptr1(j) - enddo - enddo - end select - end select - end if - end subroutine dag_combination_make_f_nodes + !!! Compute Jacobians + associate (jac => generator%real_kinematics%jac(i_phs)) + !!! Additional 1 / (1 - xi) factor because in the real jacobian, + !!! there is s_real in the numerator + !!! We also have to adapt the flux factor, which is 1/2s_real for + !!! the real component + !!! The reweighting factor is s_born / s_real, cancelling the + !!! (1-x) factor from above + jac%jac(1) = one / (one - xi) + jac%jac(2) = one + jac%jac(3) = one / (one - xi_plus)**2 + jac%jac(4) = one / (one - xi_minus)**2 + end associate + contains + subroutine get_boost_parameters (p, beta_gamma, beta_vec) + type(vector4_t), intent(in), dimension(:) :: p + real(default), intent(out) :: beta_gamma + type(vector3_t), intent(out) :: beta_vec + beta_vec = (p(1)%p(1:3) + p(2)%p(1:3)) / (p(1)%p(0) + p(2)%p(0)) + beta_gamma = beta_vec**1 / sqrt (one - beta_vec**2) + beta_vec = beta_vec / beta_vec**1 + end subroutine get_boost_parameters -@ %def dag_combination_make_f_nodes -@ Here we create the [[feyngraphs]]. After the construction of the -[[dag]] the remaining [[dag_string]] should contain a token for a -single [[dag_node]] which corresponds to the roots of the -[[feyngraphs]]. Therefore we make all [[f_nodes]] for this [[dag_node]] -and create a [[feyngraph]] for each [[f_node]]. Note that only -3-vertices are accepted. All other vertices are rejected. The -starting point is the last dag node which has been added to the list, -since this corresponds to the root of the tree. -Is is important to understand that the structure of feyngraphs is not -the same as the structure of the dag which is read from file, because -for the calculations which are performed in this module we want to -reuse the nodes for the outgoing particles, which means that they -appear only once. In O'Mega's output, it is the first incoming particle -which appears only once and the outgoing particles appear many times. This -transition is incorporated in the subroutines which create [[f_nodes]] -from the different dag objects. -<>= - procedure :: make_feyngraphs => dag_make_feyngraphs -<>= - subroutine dag_make_feyngraphs (dag, feyngraph_set) - class (dag_t), intent (inout) :: dag - type (feyngraph_set_t), intent (inout) :: feyngraph_set - integer :: i - integer :: max_subtree_size - max_subtree_size = dag%node(dag%n_nodes)%subtree_size - if (allocated (dag%node(dag%n_nodes)%f_node)) then - do i = 1, size (dag%node(dag%n_nodes)%f_node) - if (.not. associated (feyngraph_set%first)) then - allocate (feyngraph_set%last) - feyngraph_set%first => feyngraph_set%last - else - allocate (feyngraph_set%last%next) - feyngraph_set%last => feyngraph_set%last%next - end if - feyngraph_set%last%root => dag%node(dag%n_nodes)%f_node(i)%node -!!! The first particle was correct in the O'Mega parsable DAG output. It was however -!!! changed to its anti-particle in f_node_assign_particle_properties, which we revert here. - feyngraph_set%last%root%particle => feyngraph_set%last%root%particle%anti - feyngraph_set%last%n_nodes = feyngraph_set%last%root%n_subtree_nodes - feyngraph_set%n_graphs = feyngraph_set%n_graphs + 1 - enddo - feyngraph_set%f_node_list%max_tree_size = feyngraph_set%first%n_nodes - end if - end subroutine dag_make_feyngraphs + function create_longitudinal_boost & + (beta_gamma, beta_vec, inverse) result (lambda) + real(default), intent(in) :: beta_gamma + type(vector3_t), intent(in) :: beta_vec + logical, intent(in) :: inverse + type(lorentz_transformation_t) :: lambda + if (inverse) then + lambda = boost (beta_gamma, beta_vec) + else + lambda = boost (-beta_gamma, beta_vec) + end if + end function create_longitudinal_boost -@ %def dag_make_feyngraphs -@ A write procedure of the [[dag]] for debugging. -<>= - procedure :: write => dag_write -<>= - subroutine dag_write (dag, u) - class (dag_t), intent (in) :: dag - integer, intent(in) :: u - integer :: i - write (u,fmt='(A)') 'nodes' - do i=1, dag%n_nodes - write (u,fmt='(I5,3X,A)') i, char (dag%node(i)%string) - enddo - write (u,fmt='(A)') 'options' - do i=1, dag%n_options - write (u,fmt='(I5,3X,A)') i, char (dag%options(i)%string) - enddo - write (u,fmt='(A)') 'combination' - do i=1, dag%n_combinations - write (u,fmt='(I5,3X,A)') i, char (dag%combination(i)%string) - enddo - end subroutine dag_write + function create_transversal_boost (p_rad, xi, sqrts_real) result (lambda) + type(vector4_t), intent(in) :: p_rad + real(default), intent(in) :: xi, sqrts_real + type(lorentz_transformation_t) :: lambda + type(vector3_t) :: vec_transverse + real(default) :: pt2, beta, beta_gamma + pt2 = transverse_part (p_rad)**2 + beta = one / sqrt (one + sqrts_real**2 * (one - xi) / pt2) + beta_gamma = beta / sqrt (one - beta**2) + vec_transverse%p(1:2) = p_rad%p(1:2) + vec_transverse%p(3) = zero + vec_transverse = normalize (vec_transverse) + lambda = boost (-beta_gamma, vec_transverse) + end function create_transversal_boost + end subroutine phs_fks_generator_generate_isr -@ %def dag_write -@ Make a copy of a resonant [[k_node]], where the copy is kept -nonresonant. -<>= - subroutine k_node_make_nonresonant_copy (k_node) - type (k_node_t), intent (in) :: k_node - type (k_node_t), pointer :: copy - call k_node%f_node%k_node_list%add_entry (copy, recycle=.true.) - copy%daughter1 => k_node%daughter1 - copy%daughter2 => k_node%daughter2 - copy = k_node - copy%mapping = NONRESONANT - copy%resonant = .false. - copy%on_shell = .false. - copy%mapping_assigned = .true. - copy%is_nonresonant_copy = .true. - end subroutine k_node_make_nonresonant_copy +@ %def phs_fks_generator_generate_isr +@ +<>= + procedure :: set_sqrts_hat => phs_fks_generator_set_sqrts_hat +<>= + module subroutine phs_fks_generator_set_sqrts_hat (generator, sqrts) + class(phs_fks_generator_t), intent(inout) :: generator + real(default), intent(in) :: sqrts + end subroutine phs_fks_generator_set_sqrts_hat +<>= + module subroutine phs_fks_generator_set_sqrts_hat (generator, sqrts) + class(phs_fks_generator_t), intent(inout) :: generator + real(default), intent(in) :: sqrts + generator%sqrts = sqrts + end subroutine phs_fks_generator_set_sqrts_hat -@ %def k_node_make_nonresonant_copy -@ For a given [[feyngraph]] we create all possible [[kingraphs]]. Here -we use existing [[k_nodes]] which have already been created when the -mapping calculations of the pure s-channel subgraphs are performed. The -nodes for the incoming particles or the nodes on the t-line will have -to be created in all cases because they are not used in several graphs. -To obtain the existing [[k_nodes]], we use the subroutine -[[k_node_init_from_f_node]] which itself uses [[f_node_list_get_nodes]] -to obtain all active [[k_nodes]] in the [[k_node_list]] of the [[f_node]]. -The created [[kingraphs]] are attached to the linked list -of the [[feyngraph]]. For scattering processes we have to split up the -t-line, because since all graphs are represented as a decay, different -nodes can share daughter nodes. This happens also for the t-line or -the incoming particle which appears as an outgoing particle. For the -[[t_line]] or [[incoming]] nodes we do not want to recycle nodes but -rather create a copy of this line for each [[kingraph]]. -<>= - procedure :: make_kingraphs => feyngraph_make_kingraphs -<>= - subroutine feyngraph_make_kingraphs (feyngraph, feyngraph_set) - class (feyngraph_t), intent (inout) :: feyngraph - type (feyngraph_set_t), intent (in) :: feyngraph_set - type (k_node_ptr_t), dimension (:), allocatable :: kingraph_root - integer :: i - if (.not. associated (feyngraph%kin_first)) then - call k_node_init_from_f_node (feyngraph%root, & - kingraph_root, feyngraph_set) - if (.not. feyngraph%root%keep) return - if (feyngraph_set%process_type == SCATTERING) then - call split_up_t_lines (kingraph_root) - end if - do i=1, size (kingraph_root) - if (associated (feyngraph%kin_last)) then - allocate (feyngraph%kin_last%next) - feyngraph%kin_last => feyngraph%kin_last%next - else - allocate (feyngraph%kin_last) - feyngraph%kin_first => feyngraph%kin_last - end if - feyngraph%kin_last%root => kingraph_root(i)%node - feyngraph%kin_last%n_nodes = feyngraph%n_nodes - feyngraph%kin_last%keep = feyngraph%keep - if (feyngraph_set%process_type == SCATTERING) then - feyngraph%kin_last%root%bincode = & - f_node_get_external_bincode (feyngraph_set, feyngraph%root) - end if - enddo - deallocate (kingraph_root) - end if - end subroutine feyngraph_make_kingraphs +@ %def phs_fks_generator_set_sqrts_hat +@ +<>= + procedure :: set_emitters => phs_fks_generator_set_emitters +<>= + module subroutine phs_fks_generator_set_emitters (generator, emitters) + class(phs_fks_generator_t), intent(inout) :: generator + integer, intent(in), dimension(:), allocatable :: emitters + end subroutine phs_fks_generator_set_emitters +<>= + module subroutine phs_fks_generator_set_emitters (generator, emitters) + class(phs_fks_generator_t), intent(inout) :: generator + integer, intent(in), dimension(:), allocatable :: emitters + allocate (generator%emitters (size (emitters))) + generator%emitters = emitters + end subroutine phs_fks_generator_set_emitters -@ %def feyngraph_make_kingraphs -@ Create all [[k_nodes]] for a given [[f_node]]. We return these nodes -using [[k_node_ptr]]. If the node is external, we assign also the bincode -to the [[k_nodes]] because this is determined from substrings of the -input file which belong to the [[feyngraphs]] and [[f_nodes]]. -<>= - recursive subroutine k_node_init_from_f_node (f_node, k_node_ptr, feyngraph_set) - type (f_node_t), target, intent (inout) :: f_node - type (k_node_ptr_t), allocatable, dimension (:), intent (out) :: k_node_ptr - type (feyngraph_set_t), intent (in) :: feyngraph_set - type (k_node_ptr_t), allocatable, dimension(:) :: daughter_ptr1, daughter_ptr2 - integer :: n_nodes - integer :: i, j - integer :: pos - integer, save :: counter = 0 - if (.not. (f_node%incoming .or. f_node%t_line)) then - call f_node%k_node_list%get_nodes (k_node_ptr) - if (.not. allocated (k_node_ptr) .and. f_node%k_node_list%n_entries > 0) then - f_node%keep = .false. - return - end if - end if - if (.not. allocated (k_node_ptr)) then - if (associated (f_node%daughter1) .and. associated (f_node%daughter2)) then - call k_node_init_from_f_node (f_node%daughter1, daughter_ptr1, & - feyngraph_set) - call k_node_init_from_f_node (f_node%daughter2, daughter_ptr2, & - feyngraph_set) - if (.not. (f_node%daughter1%keep .and. f_node%daughter2%keep)) then - f_node%keep = .false. - return - end if - n_nodes = size (daughter_ptr1) * size (daughter_ptr2) - allocate (k_node_ptr (n_nodes)) - pos = 1 - do i=1, size (daughter_ptr1) - do j=1, size (daughter_ptr2) - if (f_node%incoming .or. f_node%t_line) then - call f_node%k_node_list%add_entry (k_node_ptr(pos)%node, recycle = .false.) - else - call f_node%k_node_list%add_entry (k_node_ptr(pos)%node, recycle = .true.) - end if - k_node_ptr(pos)%node%f_node => f_node - k_node_ptr(pos)%node%daughter1 => daughter_ptr1(i)%node - k_node_ptr(pos)%node%daughter2 => daughter_ptr2(j)%node - k_node_ptr(pos)%node%f_node_index = f_node%index - k_node_ptr(pos)%node%incoming = f_node%incoming - k_node_ptr(pos)%node%t_line = f_node%t_line - k_node_ptr(pos)%node%particle => f_node%particle - pos = pos + 1 - enddo - enddo - deallocate (daughter_ptr1, daughter_ptr2) - else - allocate (k_node_ptr(1)) - if (f_node%incoming .or. f_node%t_line) then - call f_node%k_node_list%add_entry (k_node_ptr(1)%node, recycle=.false.) - else - call f_node%k_node_list%add_entry (k_node_ptr(1)%node, recycle=.true.) - end if - k_node_ptr(1)%node%f_node => f_node - k_node_ptr(1)%node%f_node_index = f_node%index - k_node_ptr(1)%node%incoming = f_node%incoming - k_node_ptr(1)%node%t_line = f_node%t_line - k_node_ptr(1)%node%particle => f_node%particle - k_node_ptr(1)%node%bincode = f_node_get_external_bincode (feyngraph_set, & - f_node) - end if +@ %def phs_fks_generator_set_emitters +@ +<>= + procedure :: setup_masses => phs_fks_generator_setup_masses +<>= + module subroutine phs_fks_generator_setup_masses (generator, n_tot) + class(phs_fks_generator_t), intent(inout) :: generator + integer, intent(in) :: n_tot + end subroutine phs_fks_generator_setup_masses +<>= + module subroutine phs_fks_generator_setup_masses (generator, n_tot) + class(phs_fks_generator_t), intent(inout) :: generator + integer, intent(in) :: n_tot + if (.not. allocated (generator%m2)) then + allocate (generator%is_massive (n_tot)) + allocate (generator%m2 (n_tot)) + generator%is_massive = .false. + generator%m2 = zero end if - end subroutine k_node_init_from_f_node - -@ %def k_node_init_from_f_node -@ The graphs resulting from [[k_node_init_from_f_node]] are fine if they -are used only in one direction. This is however not the case when one -wants to invert the graphs, i.e. take the other incoming particle of a -scattering process as the decaying particle, because the outgoing -[[f_nodes]] (and hence also the [[k_nodes]]) exist only once. This -problem is solved here by creating a distinct t-line for each of the -graphs. The following subroutine disentangles the data structure by -creating new nodes such that the different t-lines are not connected -any more. -<>= - recursive subroutine split_up_t_lines (t_node) - type (k_node_ptr_t), dimension(:), intent (inout) :: t_node - type (k_node_t), pointer :: ref_node => null () - type (k_node_t), pointer :: ref_daughter => null () - type (k_node_t), pointer :: new_daughter => null () - type (k_node_ptr_t), dimension(:), allocatable :: t_daughter - integer :: ref_daughter_index - integer :: i, j - allocate (t_daughter (size (t_node))) - do i=1, size (t_node) - ref_node => t_node(i)%node - if (associated (ref_node%daughter1) .and. associated (ref_node%daughter2)) then - ref_daughter => null () - if (ref_node%daughter1%incoming .or. ref_node%daughter1%t_line) then - ref_daughter => ref_node%daughter1 - ref_daughter_index = 1 - else if (ref_node%daughter2%incoming .or. ref_node%daughter2%t_line) then - ref_daughter => ref_node%daughter2 - ref_daughter_index = 2 - end if - do j=1, size (t_daughter) - if (.not. associated (t_daughter(j)%node)) then - t_daughter(j)%node => ref_daughter - exit - else if (t_daughter(j)%node%index == ref_daughter%index) then - new_daughter => null () - call ref_daughter%f_node%k_node_list%add_entry (new_daughter, recycle=.false.) - new_daughter = ref_daughter - new_daughter%daughter1 => ref_daughter%daughter1 - new_daughter%daughter2 => ref_daughter%daughter2 - if (ref_daughter_index == 1) then - ref_node%daughter1 => new_daughter - else if (ref_daughter_index == 2) then - ref_node%daughter2 => new_daughter - end if - ref_daughter => new_daughter - end if - enddo - else - return - end if - enddo - call split_up_t_lines (t_daughter) - deallocate (t_daughter) - end subroutine split_up_t_lines + end subroutine phs_fks_generator_setup_masses -@ %def split_up_t_lines -@ This subroutine sets the [[inverse_daughters]] of a [[k_node]]. If we -invert a [[kingraph]] such that not the first but the second incoming -particle appears as the root of the tree, the [[incoming]] and [[t_line]] -particles obtain other daughters. These are the former mother node and -the sister node [[s_daughter]]. Here we set only the pointers for -the [[inverse_daughters]]. The inversion happens in [[kingraph_make_inverse_copy]] -and [[node_inverse_deep_copy]]. -<>= - subroutine kingraph_set_inverse_daughters (kingraph) - type (kingraph_t), intent (inout) :: kingraph - type (k_node_t), pointer :: mother - type (k_node_t), pointer :: t_daughter - type (k_node_t), pointer :: s_daughter - mother => kingraph%root - do while (associated (mother)) - if (associated (mother%daughter1) .and. & - associated (mother%daughter2)) then - if (mother%daughter1%t_line .or. mother%daughter1%incoming) then - t_daughter => mother%daughter1; s_daughter => mother%daughter2 - else if (mother%daughter2%t_line .or. mother%daughter2%incoming) then - t_daughter => mother%daughter2; s_daughter => mother%daughter1 - else - exit - end if - t_daughter%inverse_daughter1 => mother - t_daughter%inverse_daughter2 => s_daughter - mother => t_daughter - else - exit - end if - enddo - end subroutine kingraph_set_inverse_daughters +@ %def phs_fks_generator_setup_masses +@ +<>= + procedure :: set_xi_and_y_bounds => phs_fks_generator_set_xi_and_y_bounds +<>= + module subroutine phs_fks_generator_set_xi_and_y_bounds & + (generator, fks_xi_min, fks_y_max) + class(phs_fks_generator_t), intent(inout) :: generator + real(default), intent(in), optional :: fks_xi_min, fks_y_max + end subroutine phs_fks_generator_set_xi_and_y_bounds +<>= + module subroutine phs_fks_generator_set_xi_and_y_bounds & + (generator, fks_xi_min, fks_y_max) + class(phs_fks_generator_t), intent(inout) :: generator + real(default), intent(in), optional :: fks_xi_min, fks_y_max + real(default) :: xi_min, y_max + xi_min = zero; y_max = one + if (present (fks_xi_min)) xi_min = fks_xi_min + if (present (fks_y_max)) y_max = fks_y_max + generator%xi_min = min (one, max (xi_min, tiny_07)) + generator%y_max = min (abs (y_max), one) + end subroutine phs_fks_generator_set_xi_and_y_bounds -@ %def kingraph_set_inverse_daughters -@ Set the bincode of an [[f_node]] which corresponds to an external -particle. This is done on the basis of the [[particle_label]] which is a -substring of the input file. Here it is not the particle name which is -important, but the number(s) in brackets which in general indicate the -external particles which are connected to the current node. This function -is however only used for external particles, so there can either be -one or [[n_out + 1]] particles in the brackets (in the DAG input file -always one, because also for the root there is only a single number). -In all cases we check the number of particles (in the DAG input the -numbers are separated by a slash). -<>= - function f_node_get_external_bincode (feyngraph_set, f_node) result (bincode) - type (feyngraph_set_t), intent (in) :: feyngraph_set - type (f_node_t), intent (in) :: f_node - integer (TC) :: bincode - character (len=LABEL_LEN) :: particle_label - integer :: start_pos, end_pos, n_out_decay - integer :: n_prt ! for DAG - integer :: i - bincode = 0 - if (feyngraph_set%process_type == DECAY) then - n_out_decay = feyngraph_set%n_out +@ %def phs_fks_generator_set_xi_and_y_bounds +@ Sets [[x]] in the [[isr_kinematics]] of the generator. +<>= + procedure :: set_isr_kinematics => phs_fks_generator_set_isr_kinematics +<>= + module subroutine phs_fks_generator_set_isr_kinematics (generator, p) + class(phs_fks_generator_t), intent(inout) :: generator + type(vector4_t), dimension(2), intent(in) :: p + end subroutine phs_fks_generator_set_isr_kinematics +<>= + module subroutine phs_fks_generator_set_isr_kinematics (generator, p) + class(phs_fks_generator_t), intent(inout) :: generator + type(vector4_t), dimension(2), intent(in) :: p + if (allocated (generator%isr_kinematics%beam_energy)) then + select case (size (generator%isr_kinematics%beam_energy)) + case (1) + generator%isr_kinematics%x = p%p(0) / & + generator%isr_kinematics%beam_energy(1) + case (2) + generator%isr_kinematics%x = p%p(0) / & + generator%isr_kinematics%beam_energy + end select else - n_out_decay = feyngraph_set%n_out + 1 + generator%isr_kinematics%x = 0 end if - particle_label = f_node%particle_label - start_pos = index (particle_label, '[') + 1 - end_pos = index (particle_label, ']') - 1 - particle_label = particle_label(start_pos:end_pos) -!!! n_out_decay is the number of outgoing particles in the -!!! O'Mega output, which is always represented as a decay - if (feyngraph_set%use_dag) then - n_prt = 1 - do i=1, len(particle_label) - if (particle_label(i:i) == '/') n_prt = n_prt + 1 - enddo + end subroutine phs_fks_generator_set_isr_kinematics + +@ %def phs_fks_generator_set_isr_kinematics +@ +<>= + procedure :: generate_radiation_variables => & + phs_fks_generator_generate_radiation_variables +<>= + module subroutine phs_fks_generator_generate_radiation_variables & + (generator, r_in, p_born, phs_identifiers, threshold) + class(phs_fks_generator_t), intent(inout) :: generator + real(default), intent(in), dimension(:) :: r_in + type(vector4_t), intent(in), dimension(:) :: p_born + type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers + logical, intent(in), optional :: threshold + end subroutine phs_fks_generator_generate_radiation_variables +<>= + module subroutine phs_fks_generator_generate_radiation_variables & + (generator, r_in, p_born, phs_identifiers, threshold) + class(phs_fks_generator_t), intent(inout) :: generator + real(default), intent(in), dimension(:) :: r_in + type(vector4_t), intent(in), dimension(:) :: p_born + type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers + logical, intent(in), optional :: threshold + + associate (rad_var => generator%real_kinematics) + rad_var%phi = r_in (I_PHI) * twopi + select case (generator%mode) + case (GEN_REAL_PHASE_SPACE) + rad_var%jac_rand = twopi + call generator%compute_y_real_phs (r_in(I_Y), p_born, phs_identifiers, & + rad_var%jac_rand, rad_var%y, threshold) + case (GEN_SOFT_MISMATCH) + rad_var%jac_mismatch = twopi + call generator%compute_y_mismatch (r_in(I_Y), rad_var%jac_mismatch, & + rad_var%y_mismatch, rad_var%y_soft) + case default + call generator%compute_y_test (rad_var%y) + end select + call generator%compute_xi_tilde (r_in(I_XI)) + call generator%set_masses (p_born, phs_identifiers) + end associate + end subroutine phs_fks_generator_generate_radiation_variables + +@ %def phs_fks_generator_generate_radiation_variables +@ +<>= + procedure :: compute_xi_ref_momenta => & + phs_fks_generator_compute_xi_ref_momenta +<>= + module subroutine phs_fks_generator_compute_xi_ref_momenta & + (generator, p_born, resonance_contributors) + class(phs_fks_generator_t), intent(inout) :: generator + type(vector4_t), intent(in), dimension(:) :: p_born + type(resonance_contributors_t), intent(in), dimension(:), optional & + :: resonance_contributors + end subroutine phs_fks_generator_compute_xi_ref_momenta +<>= + module subroutine phs_fks_generator_compute_xi_ref_momenta & + (generator, p_born, resonance_contributors) + class(phs_fks_generator_t), intent(inout) :: generator + type(vector4_t), intent(in), dimension(:) :: p_born + type(resonance_contributors_t), intent(in), dimension(:), optional & + :: resonance_contributors + integer :: i_con, n_contributors + if (present (resonance_contributors)) then + n_contributors = size (resonance_contributors) + if (.not. allocated (generator%resonance_contributors)) & + allocate (generator%resonance_contributors (n_contributors)) + do i_con = 1, n_contributors + generator%real_kinematics%xi_ref_momenta(i_con) = & + get_resonance_momentum (p_born, resonance_contributors(i_con)%c) + generator%resonance_contributors(i_con) = & + resonance_contributors(i_con) + end do else - n_prt = end_pos - start_pos + 1 + generator%real_kinematics%xi_ref_momenta(1) = & + sum (p_born(1:generator%n_in)) end if - if (n_prt == 1) then - bincode = calculate_external_bincode (particle_label, & - feyngraph_set%process_type, n_out_decay) - else if (n_prt == n_out_decay) then - bincode = ibset (0, n_out_decay) - end if - end function f_node_get_external_bincode + end subroutine phs_fks_generator_compute_xi_ref_momenta -@ %def f_node_get_external_bincode -@ Assign a bincode to an internal node, which is calculated from -the bincodes of [[daughter1]] and [[daughter2]]. -<>= - subroutine node_assign_bincode (node) - type (k_node_t), intent (inout) :: node - if (associated (node%daughter1) .and. associated (node%daughter2) & - .and. .not. node%incoming) then - node%bincode = ior(node%daughter1%bincode, node%daughter2%bincode) - end if - end subroutine node_assign_bincode +@ %def phs_fks_generator_compute_xi_ref_momenta +@ +<>= + procedure :: compute_xi_ref_momenta_threshold & + => phs_fks_generator_compute_xi_ref_momenta_threshold +<>= + module subroutine phs_fks_generator_compute_xi_ref_momenta_threshold & + (generator, p_born) + class(phs_fks_generator_t), intent(inout) :: generator + type(vector4_t), intent(in), dimension(:) :: p_born + end subroutine phs_fks_generator_compute_xi_ref_momenta_threshold +<>= + module subroutine phs_fks_generator_compute_xi_ref_momenta_threshold & + (generator, p_born) + class(phs_fks_generator_t), intent(inout) :: generator + type(vector4_t), intent(in), dimension(:) :: p_born + generator%real_kinematics%xi_ref_momenta(1) = & + p_born(THR_POS_WP) + p_born(THR_POS_B) + generator%real_kinematics%xi_ref_momenta(2) = & + p_born(THR_POS_WM) + p_born(THR_POS_BBAR) + end subroutine phs_fks_generator_compute_xi_ref_momenta_threshold -@ %def node_assign_bincode -@ Calculate the [[bincode]] from the number in the brackets of the -[[particle_label]], if the node is external. For the root in the -non-factorized output, this is calculated directly in -[[f_node_get_external_bincode]] because in this case all the other -external particle numbers appear between the brackets. -<>= - function calculate_external_bincode (label_number_string, process_type, n_out_decay) result (bincode) - character (len=*), intent (in) :: label_number_string - integer, intent (in) :: process_type - integer, intent (in) :: n_out_decay - character :: number_char - integer :: number_int - integer (kind=TC) :: bincode - bincode = 0 - read (label_number_string, fmt='(A)') number_char -!!! check if the character is a letter (A,B,C,...) or a number (1...9) -!!! numbers 1 and 2 are special cases - select case (number_char) - case ('1') - if (process_type == SCATTERING) then - number_int = n_out_decay + 3 +@ %def phs_fks_generator_compute_xi_ref_momenta_threshold +@ +<>= + procedure :: compute_cms_energy => phs_fks_generator_compute_cms_energy +<>= + module subroutine phs_fks_generator_compute_cms_energy (generator, p_born) + class(phs_fks_generator_t), intent(inout) :: generator + type(vector4_t), intent(in), dimension(:) :: p_born + end subroutine phs_fks_generator_compute_cms_energy +<>= + module subroutine phs_fks_generator_compute_cms_energy (generator, p_born) + class(phs_fks_generator_t), intent(inout) :: generator + type(vector4_t), intent(in), dimension(:) :: p_born + type(vector4_t) :: p_sum + p_sum = sum (p_born (1 : generator%n_in)) + generator%real_kinematics%cms_energy2 = p_sum**2 + end subroutine phs_fks_generator_compute_cms_energy + +@ %def phs_fks_generator_compute_cms_energy +@ +<>= + procedure :: compute_xi_max => phs_fks_generator_compute_xi_max +<>= + module subroutine phs_fks_generator_compute_xi_max (generator, emitter, & + i_phs, p, xi_max, i_con, y_in) + class(phs_fks_generator_t), intent(inout) :: generator + integer, intent(in) :: i_phs, emitter + type(vector4_t), intent(in), dimension(:) :: p + real(default), intent(out) :: xi_max + integer, intent(in), optional :: i_con + real(default), intent(in), optional :: y_in + end subroutine phs_fks_generator_compute_xi_max +<>= + module subroutine phs_fks_generator_compute_xi_max (generator, emitter, & + i_phs, p, xi_max, i_con, y_in) + class(phs_fks_generator_t), intent(inout) :: generator + integer, intent(in) :: i_phs, emitter + type(vector4_t), intent(in), dimension(:) :: p + real(default), intent(out) :: xi_max + integer, intent(in), optional :: i_con + real(default), intent(in), optional :: y_in + real(default) :: q0 + type(vector4_t), dimension(:), allocatable :: pp, pp_decay + type(vector4_t) :: p_res + type(lorentz_transformation_t) :: L_to_resonance + real(default) :: y + if (.not. any (generator%emitters == emitter)) return + allocate (pp (size (p))) + associate (rad_var => generator%real_kinematics) + if (present (i_con)) then + q0 = rad_var%xi_ref_momenta(i_con)**1 else - number_int = n_out_decay + 2 + q0 = energy (sum (p(1:generator%n_in))) end if - case ('2') - if (process_type == SCATTERING) then - number_int = n_out_decay + 2 + if (present (y_in)) then + y = y_in else - number_int = 2 + y = rad_var%y(i_phs) end if - case ('A') - number_int = 10 - case ('B') - number_int = 11 - case ('C') - number_int = 12 - case ('D') - number_int = 13 - case default - read (number_char, fmt='(I1)') number_int - end select - bincode = ibset (bincode, number_int - process_type - 1) - end function calculate_external_bincode - -@ %def calculate_external_bincode -@ -\subsection{Mapping calculations} -Once a [[k_node]] and its subtree nodes have been created, we can -perform the kinematical calculations and assign mappings, depending on -the particle properties and the results for the subtree nodes. This -could in principle be done recursively, calling the procedure first -for the daughter nodes and then perform the calculations for the actual -node. But for parallization and comparing the nodes, this will be done -simultaneously for all nodes with the same number of subtree nodes, and the number of -subtree nodes increases, starting from one, in steps of two. The -actual mapping calculations are done in complete analogy to cascades. -<>= - subroutine node_assign_mapping_s (feyngraph, node, feyngraph_set) - type (feyngraph_t), intent (inout) :: feyngraph - type (k_node_t), intent (inout) :: node - type (feyngraph_set_t), intent (inout) :: feyngraph_set - real(default) :: eff_mass_sum - logical :: keep - if (.not. node%mapping_assigned) then - if (node%particle%mass > feyngraph_set%phs_par%m_threshold_s) then - node%effective_mass = node%particle%mass + if (present (i_con)) then + p_res = rad_var%xi_ref_momenta(i_con) + L_to_resonance = inverse (boost (p_res, q0)) + pp = L_to_resonance * p + else + pp = p end if - if (associated (node%daughter1) .and. associated (node%daughter2)) then - if (.not. (node%daughter1%keep .and. node%daughter2%keep)) then - node%keep = .false.; return - end if - node%ext_mass_sum = node%daughter1%ext_mass_sum & - + node%daughter2%ext_mass_sum - keep = .false. -!!! Potentially resonant cases [sqrts = m_rea for on-shell decay] - if (node%particle%mass > node%ext_mass_sum & - .and. node%particle%mass <= feyngraph_set%phs_par%sqrts) then - if (node%particle%width /= 0) then - if (node%daughter1%on_shell .or. node%daughter2%on_shell) then - keep = .true. - node%mapping = S_CHANNEL - node%resonant = .true. - end if + if (emitter <= generator%n_in) then + select case (generator%isr_kinematics%isr_mode) + case (SQRTS_FIXED) + if (generator%n_in > 1) then + allocate (pp_decay (size (pp) - 1)) else - call warn_decay (node%particle) - end if -!!! Collinear and IR singular cases - else if (node%particle%mass < feyngraph_set%phs_par%sqrts) then -!!! Massless splitting - if (node%daughter1%effective_mass == 0 & - .and. node%daughter2%effective_mass == 0 & - .and. .not. associated (node%daughter1%daughter1) & - .and. .not. associated (node%daughter1%daughter2) & - .and. .not. associated (node%daughter2%daughter1) & - .and. .not. associated (node%daughter2%daughter2)) then - keep = .true. - node%log_enhanced = .true. - if (node%particle%is_vector) then - if (node%daughter1%particle%is_vector & - .and. node%daughter2%particle%is_vector) then - node%mapping = COLLINEAR !!! three-vector-splitting - else - node%mapping = INFRARED !!! vector spliiting into matter - end if - else - if (node%daughter1%particle%is_vector & - .or. node%daughter2%particle%is_vector) then - node%mapping = COLLINEAR !!! vector radiation off matter - else - node%mapping = INFRARED !!! scalar radiation/splitting - end if - end if -!!! IR radiation off massive particle [cascades] - else if (node%effective_mass > 0 .and. & - node%daughter1%effective_mass > 0 .and. & - node%daughter2%effective_mass == 0 .and. & - (node%daughter1%on_shell .or. & - node%daughter1%mapping == RADIATION) .and. & - abs (node%effective_mass - & - node%daughter1%effective_mass) < feyngraph_set%phs_par%m_threshold_s) & - then - keep = .true. - node%log_enhanced = .true. - node%mapping = RADIATION - else if (node%effective_mass > 0 .and. & - node%daughter2%effective_mass > 0 .and. & - node%daughter1%effective_mass == 0 .and. & - (node%daughter2%on_shell .or. & - node%daughter2%mapping == RADIATION) .and. & - abs (node%effective_mass - & - node%daughter2%effective_mass) < feyngraph_set%phs_par%m_threshold_s) & - then - keep = .true. - node%log_enhanced = .true. - node%mapping = RADIATION - end if - end if -!!! Non-singular cases, including failed resonances [from cascades] - if (.not. keep) then -!!! Two on-shell particles from a virtual mother [from cascades, here eventually more than 2] - if (node%daughter1%on_shell .or. node%daughter2%on_shell) then - keep = .true. - eff_mass_sum = node%daughter1%effective_mass & - + node%daughter2%effective_mass - node%effective_mass = max (node%ext_mass_sum, eff_mass_sum) - if (node%effective_mass < feyngraph_set%phs_par%m_threshold_s) then - node%effective_mass = 0 - end if - end if - end if -!!! Complete and register feyngraph (make copy in case of resonance) - if (keep) then - node%on_shell = node%resonant .or. node%log_enhanced - if (node%resonant) then - if (feyngraph_set%phs_par%keep_nonresonant) then - call k_node_make_nonresonant_copy (node) - end if - node%ext_mass_sum = node%particle%mass + allocate (pp_decay (size (pp))) end if - end if - node%mapping_assigned = .true. - call node_assign_bincode (node) - call node%subtree%add_entry (node) - else !!! external (outgoing) particle - node%ext_mass_sum = node%particle%mass - node%mapping = EXTERNAL_PRT - node%multiplicity = 1 - node%mapping_assigned = .true. - call node%subtree%add_entry (node) - node%on_shell = .true. - if (node%particle%mass >= feyngraph_set%phs_par%m_threshold_s) then - node%effective_mass = node%particle%mass + pp_decay (1) = sum (pp(1:generator%n_in)) + pp_decay (2 : ) = pp (generator%n_in + 1 : ) + xi_max = get_xi_max_isr_decay (pp_decay) + deallocate (pp_decay) + case (SQRTS_VAR) + xi_max = get_xi_max_isr (generator%isr_kinematics%x, y) + end select + else + if (generator%is_massive(emitter)) then + xi_max = get_xi_max_fsr (pp, q0, emitter, generator%m2(emitter), y) + else + xi_max = get_xi_max_fsr (pp, q0, emitter) end if end if - else if (node%is_nonresonant_copy) then - call node_assign_bincode (node) - call node%subtree%add_entry (node) - node%is_nonresonant_copy = .false. - end if - call node_count_specific_properties (node) - if (node%n_off_shell > feyngraph_set%phs_par%off_shell) then - node%keep = .false. - end if - contains - subroutine warn_decay (particle) - type(part_prop_t), intent(in) :: particle - integer :: i - integer, dimension(MAX_WARN_RESONANCE), save :: warned_code = 0 - LOOP_WARNED: do i = 1, MAX_WARN_RESONANCE - if (warned_code(i) == 0) then - warned_code(i) = particle%pdg - write (msg_buffer, "(A)") & - & " Intermediate decay of zero-width particle " & - & // trim(particle%particle_label) & - & // " may be possible." - call msg_warning - exit LOOP_WARNED - else if (warned_code(i) == particle%pdg) then - exit LOOP_WARNED - end if - end do LOOP_WARNED - end subroutine warn_decay - end subroutine node_assign_mapping_s + deallocate (pp) + end associate + end subroutine phs_fks_generator_compute_xi_max -@ %def node_assign_mapping_s -@ We determine the numbers [[n_resonances]], [[multiplicity]], -[[n_off_shell]] and [[n_log_enhanced]] for a given node. -<>= - subroutine node_count_specific_properties (node) - type (k_node_t), intent (inout) :: node - if (associated (node%daughter1) .and. associated(node%daughter2)) then - if (node%resonant) then - node%multiplicity = 1 - node%n_resonances & - = node%daughter1%n_resonances & - + node%daughter2%n_resonances + 1 - else - node%multiplicity & - = node%daughter1%multiplicity & - + node%daughter2%multiplicity - node%n_resonances & - = node%daughter1%n_resonances & - + node%daughter2%n_resonances - end if - if (node%log_enhanced) then - node%n_log_enhanced & - = node%daughter1%n_log_enhanced & - + node%daughter2%n_log_enhanced + 1 - else - node%n_log_enhanced & - = node%daughter1%n_log_enhanced & - + node%daughter2%n_log_enhanced - end if - if (node%resonant) then - node%n_off_shell = 0 - else if (node%log_enhanced) then - node%n_off_shell & - = node%daughter1%n_off_shell & - + node%daughter2%n_off_shell - else - node%n_off_shell & - = node%daughter1%n_off_shell & - + node%daughter2%n_off_shell + 1 - end if - if (node%t_line) then - if (node%daughter1%t_line .or. node%daughter1%incoming) then - node%n_t_channel = node%daughter1%n_t_channel + 1 - else if (node%daughter2%t_line .or. node%daughter2%incoming) then - node%n_t_channel = node%daughter2%n_t_channel + 1 - end if +@ %def phs_fks_generator_compute_xi_max +@ +<>= + procedure :: compute_xi_max_isr_factorized & + => phs_fks_generator_compute_xi_max_isr_factorized +<>= + module subroutine phs_fks_generator_compute_xi_max_isr_factorized & + (generator, i_phs, p) + class(phs_fks_generator_t), intent(inout) :: generator + integer, intent(in) :: i_phs + type(vector4_t), intent(in), dimension(:) :: p + end subroutine phs_fks_generator_compute_xi_max_isr_factorized +<>= + module subroutine phs_fks_generator_compute_xi_max_isr_factorized & + (generator, i_phs, p) + class(phs_fks_generator_t), intent(inout) :: generator + integer, intent(in) :: i_phs + type(vector4_t), intent(in), dimension(:) :: p + generator%real_kinematics%xi_max(i_phs) = get_xi_max_isr_decay (p) + end subroutine phs_fks_generator_compute_xi_max_isr_factorized + +@ %def phs_fks_generator_compute_xi_max_isr_factorized +@ +<>= + procedure :: set_masses => phs_fks_generator_set_masses +<>= + module subroutine phs_fks_generator_set_masses & + (generator, p, phs_identifiers) + class(phs_fks_generator_t), intent(inout) :: generator + type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers + type(vector4_t), intent(in), dimension(:) :: p + end subroutine phs_fks_generator_set_masses +<>= + module subroutine phs_fks_generator_set_masses & + (generator, p, phs_identifiers) + class(phs_fks_generator_t), intent(inout) :: generator + type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers + type(vector4_t), intent(in), dimension(:) :: p + integer :: emitter, i_phs + do i_phs = 1, size (phs_identifiers) + emitter = phs_identifiers(i_phs)%emitter + if (any (generator%emitters == emitter) .and. emitter > 0) then + if (generator%is_massive (emitter) .and. emitter > generator%n_in) & + generator%m2(emitter) = p(emitter)**2 end if - end if - end subroutine node_count_specific_properties + end do + end subroutine phs_fks_generator_set_masses -@ %def node_count_specific_properties -@ The subroutine [[kingraph_assign_mappings_s]] completes kinematical -calculations for a decay process, considering the [[root]] node. -<>= - subroutine kingraph_assign_mappings_s (feyngraph, kingraph, feyngraph_set) - type (feyngraph_t), intent (inout) :: feyngraph - type (kingraph_t), pointer, intent (inout) :: kingraph - type (feyngraph_set_t), intent (inout) :: feyngraph_set - if (.not. (kingraph%root%daughter1%keep .and. kingraph%root%daughter2%keep)) then - kingraph%keep = .false. - call kingraph%tree%final () +@ %def phs_fhs_generator_set_masses +@ +<>= + public :: compute_y_from_emitter +<>= + module subroutine compute_y_from_emitter (r_y, p, n_in, emitter, & + massive, y_max, jac_rand, y, contributors, threshold) + real(default), intent(in) :: r_y + type(vector4_t), intent(in), dimension(:) :: p + integer, intent(in) :: n_in + integer, intent(in) :: emitter + logical, intent(in) :: massive + real(default), intent(in) :: y_max + real(default), intent(inout) :: jac_rand + real(default), intent(out) :: y + integer, intent(in), dimension(:), allocatable, optional :: contributors + logical, intent(in), optional :: threshold + end subroutine compute_y_from_emitter +<>= + module subroutine compute_y_from_emitter (r_y, p, n_in, emitter, & + massive, y_max, jac_rand, y, contributors, threshold) + real(default), intent(in) :: r_y + type(vector4_t), intent(in), dimension(:) :: p + integer, intent(in) :: n_in + integer, intent(in) :: emitter + logical, intent(in) :: massive + real(default), intent(in) :: y_max + real(default), intent(inout) :: jac_rand + real(default), intent(out) :: y + integer, intent(in), dimension(:), allocatable, optional :: contributors + logical, intent(in), optional :: threshold + logical :: thr, resonance + type(vector4_t) :: p_res, p_em + real(default) :: q0 + type(lorentz_transformation_t) :: boost_to_resonance + integer :: i + real(default) :: beta, one_m_beta, one_p_beta + thr = .false.; if (present (threshold)) thr = threshold + p_res = vector4_null + if (present (contributors)) then + resonance = allocated (contributors) + else + resonance = .false. end if - if (kingraph%keep) then - kingraph%root%on_shell = .true. - kingraph%root%mapping = EXTERNAL_PRT - kingraph%root%mapping_assigned = .true. - call node_assign_bincode (kingraph%root) - kingraph%root%ext_mass_sum = & - kingraph%root%daughter1%ext_mass_sum + & - kingraph%root%daughter2%ext_mass_sum - if (kingraph%root%ext_mass_sum >= feyngraph_set%phs_par%sqrts) then - kingraph%root%keep = .false. - kingraph%keep = .false.; call kingraph%tree%final (); return - end if - call kingraph%root%subtree%add_entry (kingraph%root) - kingraph%root%multiplicity & - = kingraph%root%daughter1%multiplicity & - + kingraph%root%daughter2%multiplicity - kingraph%root%n_resonances & - = kingraph%root%daughter1%n_resonances & - + kingraph%root%daughter2%n_resonances - kingraph%root%n_off_shell & - = kingraph%root%daughter1%n_off_shell & - + kingraph%root%daughter2%n_off_shell - kingraph%root%n_log_enhanced & - = kingraph%root%daughter1%n_log_enhanced & - + kingraph%root%daughter2%n_log_enhanced - if (kingraph%root%n_off_shell > feyngraph_set%phs_par%off_shell) then - kingraph%root%keep = .false. - kingraph%keep = .false.; call kingraph%tree%final (); return + if (massive) then + if (resonance) then + do i = 1, size (contributors) + p_res = p_res + p(contributors(i)) + end do + else if (thr) then + p_res = p(ass_boson(thr_leg(emitter))) + p(ass_quark(thr_leg(emitter))) else - kingraph%grove_prop%multiplicity = & - kingraph%root%multiplicity - kingraph%grove_prop%n_resonances = & - kingraph%root%n_resonances - kingraph%grove_prop%n_off_shell = & - kingraph%root%n_off_shell - kingraph%grove_prop%n_log_enhanced = & - kingraph%root%n_log_enhanced + p_res = sum (p(1:n_in)) end if - kingraph%tree = kingraph%root%subtree + q0 = p_res**1 + boost_to_resonance = inverse (boost (p_res, q0)) + p_em = boost_to_resonance * p(emitter) + beta = beta_emitter (q0, p_em) + one_m_beta = one - beta + one_p_beta = one + beta + y = one / beta * (one - one_p_beta * & + exp ( - r_y * log(one_p_beta / one_m_beta))) + jac_rand = jac_rand * & + (one - beta * y) * log(one_p_beta / one_m_beta) / beta + else + y = (one - two * r_y) * y_max + jac_rand = jac_rand * 3 * (one - y**2) * y_max + y = 1.5_default * (y - y**3 / 3) end if - end subroutine kingraph_assign_mappings_s + end subroutine compute_y_from_emitter -@ %def kingraph_assign_mappings_s -@ Compute mappings for the [[t_line]] and [[incoming]] nodes. This is -done recursively using [[node_compute_t_line]]. -<>= - subroutine kingraph_compute_mappings_t_line (feyngraph, kingraph, feyngraph_set) - type (feyngraph_t), intent (inout) :: feyngraph - type (kingraph_t), pointer, intent (inout) :: kingraph - type (feyngraph_set_t), intent (inout) :: feyngraph_set - call node_compute_t_line (feyngraph, kingraph, kingraph%root, feyngraph_set) - if (.not. kingraph%root%keep) then - kingraph%keep = .false. - call kingraph%tree%final () - end if - if (kingraph%keep) kingraph%tree = kingraph%root%subtree - end subroutine kingraph_compute_mappings_t_line +@ %def compute_y_from_emitter +@ +<>= + procedure :: compute_y_real_phs => phs_fks_generator_compute_y_real_phs +<>= + module subroutine phs_fks_generator_compute_y_real_phs & + (generator, r_y, p, phs_identifiers, & + jac_rand, y, threshold) + class(phs_fks_generator_t), intent(inout) :: generator + real(default), intent(in) :: r_y + type(vector4_t), intent(in), dimension(:) :: p + type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers + real(default), intent(inout), dimension(:) :: jac_rand + real(default), intent(out), dimension(:) :: y + logical, intent(in), optional :: threshold + end subroutine phs_fks_generator_compute_y_real_phs +<>= + module subroutine phs_fks_generator_compute_y_real_phs & + (generator, r_y, p, phs_identifiers, & + jac_rand, y, threshold) + class(phs_fks_generator_t), intent(inout) :: generator + real(default), intent(in) :: r_y + type(vector4_t), intent(in), dimension(:) :: p + type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers + real(default), intent(inout), dimension(:) :: jac_rand + real(default), intent(out), dimension(:) :: y + logical, intent(in), optional :: threshold + real(default) :: beta, one_p_beta, one_m_beta + type(lorentz_transformation_t) :: boost_to_resonance + real(default) :: q0 + type(vector4_t) :: p_res, p_em + integer :: i, i_phs, emitter + logical :: thr + logical :: construct_massive_fsr + construct_massive_fsr = .false. + thr = .false.; if (present (threshold)) thr = threshold + do i_phs = 1, size (phs_identifiers) + emitter = phs_identifiers(i_phs)%emitter + !!! We need this additional check because of decay phase spaces + !!! t -> bW has a massive emitter at position 1, which should + !!! not be treated here. + construct_massive_fsr = emitter > generator%n_in + if (construct_massive_fsr) construct_massive_fsr = & + construct_massive_fsr .and. generator%is_massive (emitter) + call compute_y_from_emitter (r_y, p, generator%n_in, & + emitter, construct_massive_fsr, & + generator%y_max, jac_rand(i_phs), y(i_phs), & + phs_identifiers(i_phs)%contributors, threshold) + end do + end subroutine phs_fks_generator_compute_y_real_phs -@ %def kingraph_compute_mappings_t_line -@ Perform the kinematical calculations and mapping assignment for a node -which is either [[incoming]] or [[t_line]]. This is done recursively, -going first to the daughter node which has this property. Therefore we -first set the pointer [[t_node]] to this daughter node and [[s_node]] to -the other one. The mapping determination happens again in the same way as -in [[cascades]]. -<>= - recursive subroutine node_compute_t_line (feyngraph, kingraph, node, feyngraph_set) - type (feyngraph_t), intent (inout) :: feyngraph - type (kingraph_t), intent (inout) :: kingraph - type (k_node_t), intent (inout) :: node - type (feyngraph_set_t), intent (inout) :: feyngraph_set - type (k_node_t), pointer :: s_node - type (k_node_t), pointer :: t_node - type (k_node_t), pointer :: new_s_node - if (.not. (node%daughter1%keep .and. node%daughter2%keep)) then - node%keep = .false. - return - end if - s_node => null () - t_node => null () - new_s_node => null () - if (associated (node%daughter1) .and. associated (node%daughter2)) then - if (node%daughter1%t_line .or. node%daughter1%incoming) then - t_node => node%daughter1; s_node => node%daughter2 - else if (node%daughter2%t_line .or. node%daughter2%incoming) then - t_node => node%daughter2; s_node => node%daughter1 - end if - if (t_node%t_line) then - call node_compute_t_line (feyngraph, kingraph, t_node, feyngraph_set) - if (.not. t_node%keep) then - node%keep = .false. - return - end if - else if (t_node%incoming) then - t_node%mapping = EXTERNAL_PRT - t_node%on_shell = .true. - t_node%ext_mass_sum = t_node%particle%mass - if (t_node%particle%mass >= feyngraph_set%phs_par%m_threshold_t) then - t_node%effective_mass = t_node%particle%mass - end if - call t_node%subtree%add_entry (t_node) - end if -!!! root: - if (.not. node%incoming) then - if (t_node%incoming) then - node%ext_mass_sum = s_node%ext_mass_sum - else - node%ext_mass_sum & - = node%daughter1%ext_mass_sum & - + node%daughter2%ext_mass_sum - end if - if (node%particle%mass > feyngraph_set%phs_par%m_threshold_t) then - node%effective_mass = max (node%particle%mass, & - s_node%effective_mass) - else if (s_node%effective_mass > feyngraph_set%phs_par%m_threshold_t) then - node%effective_mass = s_node%effective_mass - else - node%effective_mass = 0 - end if -!!! Allowed decay of beam particle - if (t_node%incoming & - .and. t_node%particle%mass > s_node%particle%mass & - + node%particle%mass) then - call beam_decay (feyngraph_set%fatal_beam_decay) -!!! Massless splitting - else if (t_node%effective_mass == 0 & - .and. s_node%effective_mass < feyngraph_set%phs_par%m_threshold_t & - .and. node%effective_mass == 0) then - node%mapping = U_CHANNEL - node%log_enhanced = .true. -!!! IR radiation off massive particle - else if (t_node%effective_mass /= 0 & - .and. s_node%effective_mass == 0 & - .and. node%effective_mass /= 0 & - .and. (t_node%on_shell & - .or. t_node%mapping == RADIATION) & - .and. abs (t_node%effective_mass - node%effective_mass) & - < feyngraph_set%phs_par%m_threshold_t) then - node%log_enhanced = .true. - node%mapping = RADIATION - end if - node%mapping_assigned = .true. - call node_assign_bincode (node) - call node%subtree%add_entry (node) - call node_count_specific_properties (node) - if (node%n_off_shell > feyngraph_set%phs_par%off_shell) then - node%keep = .false. - kingraph%keep = .false.; call kingraph%tree%final (); return - else if (node%n_t_channel > feyngraph_set%phs_par%t_channel) then - node%keep = .false.; - kingraph%keep = .false.; call kingraph%tree%final (); return - end if - else - node%mapping = EXTERNAL_PRT - node%on_shell = .true. - node%ext_mass_sum & - = t_node%ext_mass_sum & - + s_node%ext_mass_sum - node%effective_mass = node%particle%mass - if (.not. (node%ext_mass_sum < feyngraph_set%phs_par%sqrts)) then - node%keep = .false. - kingraph%keep = .false.; call kingraph%tree%final (); return - end if - if (kingraph%keep) then - if (t_node%incoming .and. s_node%log_enhanced) then - call s_node%f_node%k_node_list%add_entry (new_s_node, recycle=.false.) - new_s_node = s_node - new_s_node%daughter1 => s_node%daughter1 - new_s_node%daughter2 => s_node%daughter2 - if (s_node%index == node%daughter1%index) then - node%daughter1 => new_s_node - else if (s_node%index == node%daughter2%index) then - node%daughter2 => new_s_node - end if - new_s_node%subtree = s_node%subtree - new_s_node%mapping = NO_MAPPING - new_s_node%log_enhanced = .false. - new_s_node%n_log_enhanced & - = new_s_node%n_log_enhanced - 1 - new_s_node%log_enhanced = .false. - where (new_s_node%subtree%bc == new_s_node%bincode) - new_s_node%subtree%mapping = NO_MAPPING - endwhere - else if ((t_node%t_line .or. t_node%incoming) .and. & - t_node%mapping == U_CHANNEL) then - t_node%mapping = T_CHANNEL - where (t_node%subtree%bc == t_node%bincode) - t_node%subtree%mapping = T_CHANNEL - endwhere - else if (t_node%incoming .and. & - .not. associated (s_node%daughter1) .and. & - .not. associated (s_node%daughter2)) then - call s_node%f_node%k_node_list%add_entry (new_s_node, recycle=.false.) - new_s_node = s_node - new_s_node%mapping = ON_SHELL - new_s_node%daughter1 => s_node%daughter1 - new_s_node%daughter2 => s_node%daughter2 - new_s_node%subtree = s_node%subtree - if (s_node%index == node%daughter1%index) then - node%daughter1 => new_s_node - else if (s_node%index == node%daughter2%index) then - node%daughter2 => new_s_node - end if - where (new_s_node%subtree%bc == new_s_node%bincode) - new_s_node%subtree%mapping = ON_SHELL - endwhere - end if - end if - call node%subtree%add_entry (node) - node%multiplicity & - = node%daughter1%multiplicity & - + node%daughter2%multiplicity - node%n_resonances & - = node%daughter1%n_resonances & - + node%daughter2%n_resonances - node%n_off_shell & - = node%daughter1%n_off_shell & - + node%daughter2%n_off_shell - node%n_log_enhanced & - = node%daughter1%n_log_enhanced & - + node%daughter2%n_log_enhanced - node%n_t_channel & - = node%daughter1%n_t_channel & - + node%daughter2%n_t_channel - if (node%n_off_shell > feyngraph_set%phs_par%off_shell) then - node%keep = .false. - kingraph%keep = .false.; call kingraph%tree%final (); return - else if (node%n_t_channel > feyngraph_set%phs_par%t_channel) then - node%keep = .false. - kingraph%keep = .false.; call kingraph%tree%final (); return +@ %def phs_fks_generator_compute_y_real_phs +@ +<>= + procedure :: compute_y_mismatch => phs_fks_generator_compute_y_mismatch +<>= + module subroutine phs_fks_generator_compute_y_mismatch & + (generator, r_y, jac_rand, y, y_soft) + class(phs_fks_generator_t), intent(inout) :: generator + real(default), intent(in) :: r_y + real(default), intent(inout) :: jac_rand + real(default), intent(out) :: y + real(default), intent(out), dimension(:) :: y_soft + end subroutine phs_fks_generator_compute_y_mismatch +<>= + module subroutine phs_fks_generator_compute_y_mismatch & + (generator, r_y, jac_rand, y, y_soft) + class(phs_fks_generator_t), intent(inout) :: generator + real(default), intent(in) :: r_y + real(default), intent(inout) :: jac_rand + real(default), intent(out) :: y + real(default), intent(out), dimension(:) :: y_soft + y = (one - two * r_y) * generator%y_max + jac_rand = jac_rand * 3 * (one - y**2) * generator%y_max + y = 1.5_default * (y - y**3 / 3) + y_soft = y + end subroutine phs_fks_generator_compute_y_mismatch + +@ %def phs_fks_generator_compute_y_mismatch +@ +<>= + procedure :: compute_y_test => phs_fks_generator_compute_y_test +<>= + module subroutine phs_fks_generator_compute_y_test (generator, y) + class(phs_fks_generator_t), intent(inout) :: generator + real(default), intent(out), dimension(:):: y + end subroutine phs_fks_generator_compute_y_test +<>= + module subroutine phs_fks_generator_compute_y_test (generator, y) + class(phs_fks_generator_t), intent(inout) :: generator + real(default), intent(out), dimension(:):: y + select case (generator%mode) + case (GEN_SOFT_LIMIT_TEST) + y = y_test_soft + case (GEN_COLL_LIMIT_TEST) + y = y_test_coll + case (GEN_ANTI_COLL_LIMIT_TEST) + y = - y_test_coll + case (GEN_SOFT_COLL_LIMIT_TEST) + y = y_test_coll + case (GEN_SOFT_ANTI_COLL_LIMIT_TEST) + y = - y_test_coll + end select + end subroutine phs_fks_generator_compute_y_test + +@ %def phs_fks_generator_compute_y_test +@ +<>= + public :: beta_emitter +<>= + pure module function beta_emitter (q0, p) result (beta) + real(default), intent(in) :: q0 + type(vector4_t), intent(in) :: p + real(default) :: beta + end function beta_emitter +<>= + pure module function beta_emitter (q0, p) result (beta) + real(default), intent(in) :: q0 + type(vector4_t), intent(in) :: p + real(default) :: beta + real(default) :: m2, mrec2, k0_max + m2 = p**2 + mrec2 = (q0 - p%p(0))**2 - p%p(1)**2 - p%p(2)**2 - p%p(3)**2 + k0_max = (q0**2 - mrec2 + m2) / (two * q0) + beta = sqrt(one - m2 / k0_max**2) + end function beta_emitter + +@ %def beta_emitter +@ +<>= + procedure :: compute_xi_tilde => phs_fks_generator_compute_xi_tilde +<>= + pure module subroutine phs_fks_generator_compute_xi_tilde (generator, r) + class(phs_fks_generator_t), intent(inout) :: generator + real(default), intent(in) :: r + end subroutine phs_fks_generator_compute_xi_tilde +<>= + pure module subroutine phs_fks_generator_compute_xi_tilde (generator, r) + class(phs_fks_generator_t), intent(inout) :: generator + real(default), intent(in) :: r + real(default) :: deno + associate (rad_var => generator%real_kinematics) + select case (generator%mode) + case (GEN_REAL_PHASE_SPACE) + if (generator%singular_jacobian) then + rad_var%xi_tilde = (one - generator%xi_min) - (one - r)**2 * & + (one - two * generator%xi_min) + rad_var%jac_rand = rad_var%jac_rand * two * (one - r) * & + (one - two * generator%xi_min) else - kingraph%grove_prop%multiplicity = node%multiplicity - kingraph%grove_prop%n_resonances = node%n_resonances - kingraph%grove_prop%n_off_shell = node%n_off_shell - kingraph%grove_prop%n_log_enhanced = node%n_log_enhanced - kingraph%grove_prop%n_t_channel = node%n_t_channel + rad_var%xi_tilde = generator%xi_min + r * (one - generator%xi_min) + rad_var%jac_rand = rad_var%jac_rand * (one - generator%xi_min) end if - end if - end if - contains - subroutine beam_decay (fatal_beam_decay) - logical, intent(in) :: fatal_beam_decay - write (msg_buffer, "(1x,A,1x,'->',1x,A,1x,A)") & - t_node%particle%particle_label, & - node%particle%particle_label, & - s_node%particle%particle_label - call msg_message - write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") & - t_node%particle%particle_label, t_node%particle%mass - call msg_message - write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") & - node%particle%particle_label, node%particle%mass - call msg_message - write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") & - s_node%particle%particle_label, s_node%particle%mass - call msg_message - if (fatal_beam_decay) then - call msg_fatal (" Phase space: Initial beam particle can decay") - else - call msg_warning (" Phase space: Initial beam particle can decay") - end if - end subroutine beam_decay - end subroutine node_compute_t_line + case (GEN_SOFT_MISMATCH) + deno = one - r + if (deno < tiny_13) deno = tiny_13 + rad_var%xi_mismatch = generator%xi_min + r / deno + rad_var%jac_mismatch = rad_var%jac_mismatch / deno**2 + case (GEN_SOFT_LIMIT_TEST) + rad_var%xi_tilde = r * two * xi_tilde_test_soft + rad_var%jac_rand = two * xi_tilde_test_soft + case (GEN_COLL_LIMIT_TEST) + rad_var%xi_tilde = xi_tilde_test_coll + rad_var%jac_rand = xi_tilde_test_coll + case (GEN_ANTI_COLL_LIMIT_TEST) + rad_var%xi_tilde = xi_tilde_test_coll + rad_var%jac_rand = xi_tilde_test_coll + case (GEN_SOFT_COLL_LIMIT_TEST) + rad_var%xi_tilde = r * two * xi_tilde_test_soft + rad_var%jac_rand = two * xi_tilde_test_soft + case (GEN_SOFT_ANTI_COLL_LIMIT_TEST) + rad_var%xi_tilde = r * two * xi_tilde_test_soft + rad_var%jac_rand = two * xi_tilde_test_soft + end select + end associate + end subroutine phs_fks_generator_compute_xi_tilde -@ %def node_compute_t_line -@ After all pure s-channel subdiagrams have already been created from the -corresponding [[f_nodes]] and mappings have been determined for their -nodes, we complete the calculations here. In a first step, the -[[kingraphs]] have to be created on the basis of the existing -[[k_nodes]], which means in particular that a [[feyngraph]] can give -rise to several [[kingraphs]] which will all be attached to the linked -list of the [[feyngraph]]. The calculations which remain are of different -kinds for decay and scattering processes. In a decay process the -kinematical calculations have to be done for the [[root]] node. In a -scattering process, after the creation of [[kingraphs]] in the first -step, there will be only [[kingraphs]] with the first incoming particle -as the [[root]] of the tree. For these graphs the [[inverse]] variable -has the value [[.false.]]. Before performing any calculations on these -graphs we make a so-called inverse copy of the graph (see below), which -will also be attached to the linked list. Since the s-channel subgraph -calculations have already been completed, only the t-line computations -remain. -<>= - procedure :: make_inverse_kingraphs => feyngraph_make_inverse_kingraphs -<>= - subroutine feyngraph_make_inverse_kingraphs (feyngraph) - class (feyngraph_t), intent (inout) :: feyngraph - type (kingraph_t), pointer :: current - current => feyngraph%kin_first - do while (associated (current)) - if (current%inverse) exit - call current%make_inverse_copy (feyngraph) - current => current%next - enddo - end subroutine feyngraph_make_inverse_kingraphs +@ %def phs_fks_generator_compute_xi_tilde +@ +<>= + procedure :: prepare_generation => phs_fks_generator_prepare_generation +<>= + module subroutine phs_fks_generator_prepare_generation (generator, & + r_in, i_phs, emitter, p_born, phs_identifiers, contributors, i_con) + class(phs_fks_generator_t), intent(inout) :: generator + real(default), dimension(3), intent(in) :: r_in + integer, intent(in) :: i_phs, emitter + type(vector4_t), intent(in), dimension(:) :: p_born + type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers + type(resonance_contributors_t), intent(in), dimension(:), optional :: & + contributors + integer, intent(in), optional :: i_con + end subroutine phs_fks_generator_prepare_generation +<>= + module subroutine phs_fks_generator_prepare_generation (generator, & + r_in, i_phs, emitter, p_born, phs_identifiers, contributors, i_con) + class(phs_fks_generator_t), intent(inout) :: generator + real(default), dimension(3), intent(in) :: r_in + integer, intent(in) :: i_phs, emitter + type(vector4_t), intent(in), dimension(:) :: p_born + type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers + type(resonance_contributors_t), intent(in), dimension(:), optional :: & + contributors + integer, intent(in), optional :: i_con + call generator%generate_radiation_variables (r_in, p_born, phs_identifiers) + call generator%compute_xi_ref_momenta & + (generator%real_kinematics%p_born_lab%phs_point(1)%get (), & + contributors) + call generator%compute_xi_max (emitter, i_phs, p_born, & + generator%real_kinematics%xi_max(i_phs), i_con = i_con) + end subroutine phs_fks_generator_prepare_generation -@ %def feyngraph_make_inverse_kingraphs -<>= - procedure :: compute_mappings => feyngraph_compute_mappings -<>= - subroutine feyngraph_compute_mappings (feyngraph, feyngraph_set) - class (feyngraph_t), intent (inout) :: feyngraph - type (feyngraph_set_t), intent (inout) :: feyngraph_set - type (kingraph_t), pointer :: current - current => feyngraph%kin_first - do while (associated (current)) - if (feyngraph_set%process_type == DECAY) then - call kingraph_assign_mappings_s (feyngraph, current, feyngraph_set) - else if (feyngraph_set%process_type == SCATTERING) then - call kingraph_compute_mappings_t_line (feyngraph, current, feyngraph_set) - end if - current => current%next - enddo - end subroutine feyngraph_compute_mappings +@ %def phs_fks_generator_prepare_generation +@ Get [[xi]] and [[y]] from an external routine (e.g. [[powheg]]) and +generate an FSR phase space. Note that the flag [[supply_xi_max]] is +set to [[.false.]] because it is assumed that the upper bound on [[xi]] +has already been taken into account during its generation. +<>= + procedure :: generate_fsr_from_xi_and_y => & + phs_fks_generator_generate_fsr_from_xi_and_y +<>= + module subroutine phs_fks_generator_generate_fsr_from_xi_and_y & + (generator, xi, y, & + phi, emitter, i_phs, p_born, p_real) + class(phs_fks_generator_t), intent(inout) :: generator + real(default), intent(in) :: xi, y, phi + integer, intent(in) :: emitter, i_phs + type(vector4_t), intent(in), dimension(:) :: p_born + type(vector4_t), intent(inout), dimension(:) :: p_real + end subroutine phs_fks_generator_generate_fsr_from_xi_and_y +<>= + module subroutine phs_fks_generator_generate_fsr_from_xi_and_y & + (generator, xi, y, & + phi, emitter, i_phs, p_born, p_real) + class(phs_fks_generator_t), intent(inout) :: generator + real(default), intent(in) :: xi, y, phi + integer, intent(in) :: emitter, i_phs + type(vector4_t), intent(in), dimension(:) :: p_born + type(vector4_t), intent(inout), dimension(:) :: p_real + associate (rad_var => generator%real_kinematics) + rad_var%supply_xi_max = .false. + rad_var%xi_tilde = xi + rad_var%y(i_phs) = y + rad_var%phi = phi + end associate + call generator%set_sqrts_hat (p_born(1)%p(0) + p_born(2)%p(0)) + call generator%generate_fsr (emitter, i_phs, p_born, p_real) + end subroutine phs_fks_generator_generate_fsr_from_xi_and_y -@ %def feyngraph_compute_mappings -@ Here we control the mapping calculations for the nodes of s-channel -subgraphs. We start with the nodes with the smallest number of subtree -nodes and always increase this number by two because nodes have exactly -zero or two daughter nodes. We create the [[k_nodes]] using the -[[k_node_list]] of each [[f_node]]. The number of nodes which have to -be created depends of the number of existing daughter nodes, which means -that we have to create a node for each combination of existing and -valid (the ones which we [[keep]]) daughter nodes. If the node -corresponds to an external particle, we create only one node, since -there are no daughter nodes. If the particle is not external and -the daughter [[f_nodes]] do not contain any valid [[k_nodes]], we do -not create a new [[k_nodes]] either. When the calculations for all nodes -with the same number of subtree nodes have been completed, we compare -the valid nodes to eliminate equivalences (see below). -<>= - subroutine f_node_list_compute_mappings_s (feyngraph_set) - type (feyngraph_set_t), intent (inout) :: feyngraph_set - type (f_node_ptr_t), dimension(:), allocatable :: set - type (k_node_ptr_t), dimension(:), allocatable :: k_set - type (k_node_entry_t), pointer :: k_entry - type (f_node_entry_t), pointer :: current - type (k_node_list_t), allocatable :: compare_list - integer :: n_entries - integer :: pos - integer :: i, j, k - do i = 1, feyngraph_set%f_node_list%max_tree_size - 2, 2 -!!! Counter number of f_nodes with subtree size i for s channel calculations - n_entries = 0 - if (feyngraph_set%use_dag) then - do j=1, feyngraph_set%dag%n_nodes - if (allocated (feyngraph_set%dag%node(j)%f_node)) then - do k=1, size(feyngraph_set%dag%node(j)%f_node) - if (associated (feyngraph_set%dag%node(j)%f_node(k)%node)) then - if (.not. (feyngraph_set%dag%node(j)%f_node(k)%node%incoming & - .or. feyngraph_set%dag%node(j)%f_node(k)%node%t_line) & - .and. feyngraph_set%dag%node(j)%f_node(k)%node%n_subtree_nodes == i) then - n_entries = n_entries + 1 - end if - end if - enddo - end if - enddo - else - current => feyngraph_set%f_node_list%first - do while (associated (current)) - if (.not. (current%node%incoming .or. current%node%t_line) & - .and. current%node%n_subtree_nodes == i) then - n_entries = n_entries + 1 - end if - current => current%next - enddo - end if - if (n_entries == 0) exit -!!! Create a temporary k node list for comparison - allocate (set(n_entries)) - pos = 0 - if (feyngraph_set%use_dag) then - do j=1, feyngraph_set%dag%n_nodes - if (allocated (feyngraph_set%dag%node(j)%f_node)) then - do k=1, size(feyngraph_set%dag%node(j)%f_node) - if (associated (feyngraph_set%dag%node(j)%f_node(k)%node)) then - if (.not. (feyngraph_set%dag%node(j)%f_node(k)%node%incoming & - .or. feyngraph_set%dag%node(j)%f_node(k)%node%t_line) & - .and. feyngraph_set%dag%node(j)%f_node(k)%node%n_subtree_nodes == i) then - pos = pos + 1 - set(pos)%node => feyngraph_set%dag%node(j)%f_node(k)%node - end if - end if - enddo - end if - enddo - else - current => feyngraph_set%f_node_list%first - do while (associated (current)) - if (.not. (current%node%incoming .or. current%node%t_line) & - .and. current%node%n_subtree_nodes == i) then - pos = pos + 1 - set(pos)%node => current%node - end if - current => current%next - enddo - end if - allocate (compare_list) - compare_list%observer = .true. - do j = 1, n_entries - call k_node_init_from_f_node (set(j)%node, k_set, & - feyngraph_set) - if (allocated (k_set)) deallocate (k_set) - enddo - !$OMP PARALLEL DO PRIVATE (k_entry) - do j = 1, n_entries - k_entry => set(j)%node%k_node_list%first - do while (associated (k_entry)) - call node_assign_mapping_s(feyngraph_set%first, k_entry%node, feyngraph_set) - k_entry => k_entry%next - enddo - enddo - !$OMP END PARALLEL DO - do j = 1, size (set) - k_entry => set(j)%node%k_node_list%first - do while (associated (k_entry)) - if (k_entry%node%keep) then - if (k_entry%node%mapping == NO_MAPPING .or. k_entry%node%mapping == NONRESONANT) then - call compare_list%add_pointer (k_entry%node) - end if - end if - k_entry => k_entry%next - enddo - enddo - deallocate (set) - call compare_list%check_subtree_equivalences(feyngraph_set%model) - call compare_list%final - deallocate (compare_list) - enddo - end subroutine f_node_list_compute_mappings_s +@ %def phs_fks_generator_generate_fsr_from_xi_and_y +@ +<>= + procedure :: get_radiation_variables => & + phs_fks_generator_get_radiation_variables +<>= + pure module subroutine phs_fks_generator_get_radiation_variables & + (generator, i_phs, xi, y, phi) + class(phs_fks_generator_t), intent(in) :: generator + integer, intent(in) :: i_phs + real(default), intent(out) :: xi, y + real(default), intent(out), optional :: phi + end subroutine phs_fks_generator_get_radiation_variables +<>= + pure module subroutine phs_fks_generator_get_radiation_variables & + (generator, i_phs, xi, y, phi) + class(phs_fks_generator_t), intent(in) :: generator + integer, intent(in) :: i_phs + real(default), intent(out) :: xi, y + real(default), intent(out), optional :: phi + associate (rad_var => generator%real_kinematics) + xi = rad_var%xi_max(i_phs) * rad_var%xi_tilde + y = rad_var%y(i_phs) + if (present (phi)) phi = rad_var%phi + end associate + end subroutine phs_fks_generator_get_radiation_variables -@ %def f_node_list_compute_mappings_s +@ %def phs_fks_generator_get_radiation_variables @ -\subsection{Fill the grove list} -Find the [[grove]] within the [[grove_list]] for a [[kingraph]] for -which the kinematical calculations and mapping assignments have been completed. The [[groves]] -are defined by the [[grove_prop]] entries and the value of the resonance -hash ([[res_hash]]). Whenever a matching grove does not exist, we -create one. In a first step we consider only part of the grove properties -(see [[grove_prop_match]]) and the resonance hash is ignored, which leads -to a preliminary grove list. In the end all numbers in [[grove_prop]] as -well as the resonance hash are compared, i.e. we create a new -[[grove_list]]. -<>= - procedure :: get_grove => grove_list_get_grove -<>= - subroutine grove_list_get_grove (grove_list, kingraph, return_grove, preliminary) - class (grove_list_t), intent (inout) :: grove_list - type (kingraph_t), intent (in), pointer :: kingraph - type (grove_t), intent (inout), pointer :: return_grove - logical, intent (in) :: preliminary - type (grove_t), pointer :: current_grove - return_grove => null () - if (.not. associated(grove_list%first)) then - allocate (grove_list%first) - grove_list%first%grove_prop = kingraph%grove_prop - return_grove => grove_list%first - return +<>= + procedure :: write => phs_fks_generator_write +<>= + module subroutine phs_fks_generator_write (generator, unit) + class(phs_fks_generator_t), intent(in) :: generator + integer, intent(in), optional :: unit + end subroutine phs_fks_generator_write +<>= + module subroutine phs_fks_generator_write (generator, unit) + class(phs_fks_generator_t), intent(in) :: generator + integer, intent(in), optional :: unit + integer :: u + type(string_t) :: massive_phsp + u = given_output_unit (unit); if (u < 0) return + if (generator%massive_phsp) then + massive_phsp = " massive " + else + massive_phsp = " massless " end if - current_grove => grove_list%first - do while (associated (current_grove)) - if ((preliminary .and. (current_grove%grove_prop .match. kingraph%grove_prop)) .or. & - (.not. preliminary .and. current_grove%grove_prop == kingraph%grove_prop)) then - return_grove => current_grove - exit - else if (.not. associated (current_grove%next)) then - allocate (current_grove%next) - current_grove%next%grove_prop = kingraph%grove_prop - if (size (kingraph%tree%bc) < 9) & - current_grove%compare_tree%depth = 1 - return_grove => current_grove%next - exit - end if - if (associated (current_grove%next)) then - current_grove => current_grove%next - end if - enddo - end subroutine grove_list_get_grove - -@ %def grove_list_get_grove -@ Add a valid [[kingraph]] to a [[grove_list]]. We first look for the -[[grove]] which has the grove properties of the [[kingraph]]. If no such -[[grove]] exists so far, it is created. -<>= - procedure :: add_kingraph => grove_list_add_kingraph -<>= - subroutine grove_list_add_kingraph (grove_list, kingraph, preliminary, check, model) - class (grove_list_t), intent (inout) :: grove_list - type (kingraph_t), pointer, intent (inout) :: kingraph - logical, intent (in) :: preliminary - logical, intent (in) :: check - type (model_data_t), optional, intent (in) :: model - type (grove_t), pointer :: grove - type (kingraph_t), pointer :: current - integer, save :: index = 0 - grove => null () - current => null () - if (preliminary) then - if (kingraph%index == 0) then - index = index + 1 - kingraph%index = index - end if + write (u, "(A)") char ("This is a generator for a" & + // massive_phsp // "phase space") + if (associated (generator%real_kinematics)) then + call generator%real_kinematics%write () + else + write (u, "(A)") "Warning: There are no real " // & + "kinematics associated with this generator" end if - call grove_list%get_grove (kingraph, grove, preliminary) - if (check) then - call grove%compare_tree%check_kingraph (kingraph, model, preliminary) + call write_separator (u) + write (u, "(A," // FMT_17 // ",1X)") "sqrts : ", generator%sqrts + write (u, "(A," // FMT_17 // ",1X)") "E_gluon : ", generator%E_gluon + write (u, "(A," // FMT_17 // ",1X)") "mrec2 : ", generator%mrec2 + end subroutine phs_fks_generator_write + +@ %def phs_fks_generator_write +@ +<>= + procedure :: compute_isr_kinematics => phs_fks_compute_isr_kinematics +<>= + module subroutine phs_fks_compute_isr_kinematics (phs, r) + class(phs_fks_t), intent(inout) :: phs + real(default), intent(in) :: r + end subroutine phs_fks_compute_isr_kinematics +<>= + module subroutine phs_fks_compute_isr_kinematics (phs, r) + class(phs_fks_t), intent(inout) :: phs + real(default), intent(in) :: r + if (.not. phs%config%lab_is_cm) then + call phs%generator%compute_isr_kinematics & + (r, phs%lt_cm_to_lab * phs%phs_wood_t%p) + else + call phs%generator%compute_isr_kinematics (r, phs%phs_wood_t%p) end if - if (kingraph%keep) then - if (associated (grove%first)) then - grove%last%grove_next => kingraph - grove%last => kingraph - else - grove%first => kingraph - grove%last => kingraph + end subroutine phs_fks_compute_isr_kinematics + +@ %def phs_fks_compute_isr_kinematics +@ +<>= + procedure :: final => phs_fks_final +<>= + module subroutine phs_fks_final (object) + class(phs_fks_t), intent(inout) :: object + end subroutine phs_fks_final +<>= + module subroutine phs_fks_final (object) + class(phs_fks_t), intent(inout) :: object + call object%forest%final () + call object%generator%final () + end subroutine phs_fks_final + +@ %def phs_fks_final +@ +<>= + subroutine filter_particles_from_resonances & + (res_hist, exclusion_list, & + model, res_hist_filtered) + type(resonance_history_t), intent(in), dimension(:) :: res_hist + type(string_t), intent(in), dimension(:) :: exclusion_list + type(model_t), intent(in) :: model + type(resonance_history_t), intent(out), dimension(:), allocatable :: & + res_hist_filtered + integer :: i_hist, i_flv, i_new, n_orig + logical, dimension(size (res_hist)) :: to_filter + type(flavor_t) :: flv + to_filter = .false. + n_orig = size (res_hist) + do i_flv = 1, size (exclusion_list) + call flv%init (exclusion_list (i_flv), model) + do i_hist = 1, size (res_hist) + if (res_hist(i_hist)%has_flavor (flv)) to_filter (i_hist) = .true. + end do + end do + allocate (res_hist_filtered (n_orig - count (to_filter))) + i_new = 1 + do i_hist = 1, size (res_hist) + if (.not. to_filter (i_hist)) then + res_hist_filtered (i_new) = res_hist (i_hist) + i_new = i_new + 1 end if + end do + end subroutine filter_particles_from_resonances + +@ %def filter_particles_from_resonances +@ +<>= + subroutine clean_resonance_histories & + (res_hist, n_in, flv, res_hist_clean, success) + type(resonance_history_t), intent(in), dimension(:) :: res_hist + integer, intent(in) :: n_in + integer, intent(in), dimension(:) :: flv + type(resonance_history_t), intent(out), dimension(:), allocatable :: & + res_hist_clean + logical, intent(out) :: success + integer :: i_hist + type(resonance_history_t), dimension(:), allocatable :: & + res_hist_colored, res_hist_contracted + + if (debug_on) call msg_debug (D_SUBTRACTION, "resonance_mapping_init") + if (debug_active (D_SUBTRACTION)) then + call msg_debug (D_SUBTRACTION, "Original resonances:") + do i_hist = 1, size(res_hist) + call res_hist(i_hist)%write () + end do end if - end subroutine grove_list_add_kingraph -@ %ref grove_list_add_kingraph -@ For a given [[feyngraph]] we store all valid [[kingraphs]] in the -[[grove_list]]. -<>= - procedure :: add_feyngraph => grove_list_add_feyngraph -<>= - subroutine grove_list_add_feyngraph (grove_list, feyngraph, model) - class (grove_list_t), intent (inout) :: grove_list - type (feyngraph_t), intent (inout) :: feyngraph - type (model_data_t), intent (in) :: model - type (kingraph_t), pointer :: current_kingraph, add_kingraph - do while (associated (feyngraph%kin_first)) - if (feyngraph%kin_first%keep) then - add_kingraph => feyngraph%kin_first - feyngraph%kin_first => feyngraph%kin_first%next - add_kingraph%next => null () - call grove_list%add_kingraph (kingraph=add_kingraph, & - preliminary=.true., check=.true., model=model) - else - exit - end if - enddo - if (associated (feyngraph%kin_first)) then - current_kingraph => feyngraph%kin_first - do while (associated (current_kingraph%next)) - if (current_kingraph%next%keep) then - add_kingraph => current_kingraph%next - current_kingraph%next => current_kingraph%next%next - add_kingraph%next => null () - call grove_list%add_kingraph (kingraph=add_kingraph, & - preliminary=.true., check=.true., model=model) - else - current_kingraph => current_kingraph%next - end if - enddo + call remove_uncolored_resonances () + call contract_resonances (res_hist_colored, res_hist_contracted) + call remove_subresonances (res_hist_contracted, res_hist_clean) + !!! Here, we are still not sure whether we actually would rather use + !!! call remove_multiple_resonances (res_hist_contracted, res_hist_clean) + if (debug_active (D_SUBTRACTION)) then + call msg_debug (D_SUBTRACTION, "Resonances after removing uncolored and duplicates: ") + do i_hist = 1, size (res_hist_clean) + call res_hist_clean(i_hist)%write () + end do + end if + if (size (res_hist_clean) == 0) then + call msg_warning ("No resonances found. Proceed in usual FKS mode.") + success = .false. + else + success = .true. end if - end subroutine grove_list_add_feyngraph -@ %def grove_list_add_feyngraph -@ Compare two [[grove_prop]] objects. The [[.match.]] operator is used -for preliminary groves in which the [[kingraphs]] share only the 3 -numbers [[n_resonances]], [[n_log_enhanced]] and [[n_t_channel]]. These -groves are only used for comparing the kingraphs, because only graphs -within these preliminary groves can be equivalent (the numbers which are -compared here are unambigously fixed by the combination of mappings in -these channels). -<>= - interface operator (.match.) - module procedure grove_prop_match - end interface operator (.match.) -<>= - function grove_prop_match (grove_prop1, grove_prop2) result (gp_match) - type (grove_prop_t), intent (in) :: grove_prop1 - type (grove_prop_t), intent (in) :: grove_prop2 - logical :: gp_match - gp_match = (grove_prop1%n_resonances == grove_prop2%n_resonances) & - .and. (grove_prop1%n_log_enhanced == grove_prop2%n_log_enhanced) & - .and. (grove_prop1%n_t_channel == grove_prop2%n_t_channel) - end function grove_prop_match + contains + subroutine remove_uncolored_resonances () + type(resonance_history_t), dimension(:), allocatable :: res_hist_tmp + integer :: n_hist, nleg_out, n_removed + integer :: i_res, i_hist + n_hist = size (res_hist) + nleg_out = size (flv) - n_in + allocate (res_hist_tmp (n_hist)) + allocate (res_hist_colored (n_hist)) + do i_hist = 1, n_hist + res_hist_tmp(i_hist) = res_hist(i_hist) + call res_hist_tmp(i_hist)%add_offset (n_in) + n_removed = 0 + do i_res = 1, res_hist_tmp(i_hist)%n_resonances + associate (resonance => res_hist_tmp(i_hist)%resonances(i_res - n_removed)) + if (.not. any (is_colored (flv (resonance%contributors%c))) & + .or. size (resonance%contributors%c) == nleg_out) then + call res_hist_tmp(i_hist)%remove_resonance (i_res - n_removed) + n_removed = n_removed + 1 + end if + end associate + end do + if (allocated (res_hist_tmp(i_hist)%resonances)) then + if (any (res_hist_colored == res_hist_tmp(i_hist))) then + cycle + else + do i_res = 1, res_hist_tmp(i_hist)%n_resonances + associate (resonance => res_hist_tmp(i_hist)%resonances(i_res)) + call res_hist_colored(i_hist)%add_resonance (resonance) + end associate + end do + end if + end if + end do + end subroutine remove_uncolored_resonances -@ %def grove_prop_match -@ The equal operator on the other hand will be used when all valid -[[kingraphs]] have been created and mappings have been determined, to -split up the existing (preliminary) grove list, i.e. to create new -groves which are determined by all entries in [[grove_prop_t]]. -<>= - interface operator (==) - module procedure grove_prop_equal - end interface operator (==) -<>= - function grove_prop_equal (grove_prop1, grove_prop2) result (gp_equal) - type (grove_prop_t), intent (in) :: grove_prop1 - type (grove_prop_t), intent (in) :: grove_prop2 - logical :: gp_equal - gp_equal = (grove_prop1%res_hash == grove_prop2%res_hash) & - .and. (grove_prop1%n_resonances == grove_prop2%n_resonances) & - .and. (grove_prop1%n_log_enhanced == grove_prop2%n_log_enhanced) & - .and. (grove_prop1%n_off_shell == grove_prop2%n_off_shell) & - .and. (grove_prop1%multiplicity == grove_prop2%multiplicity) & - .and. (grove_prop1%n_t_channel == grove_prop2%n_t_channel) - end function grove_prop_equal + subroutine contract_resonances (res_history_in, res_history_out) + type(resonance_history_t), intent(in), dimension(:) :: res_history_in + type(resonance_history_t), intent(out), dimension(:), allocatable :: res_history_out + logical, dimension(:), allocatable :: i_non_zero + integer :: n_hist_non_zero, n_hist + integer :: i_hist_new + n_hist = size (res_history_in); n_hist_non_zero = 0 + allocate (i_non_zero (n_hist)) + i_non_zero = .false. + do i_hist = 1, n_hist + if (res_history_in(i_hist)%n_resonances /= 0) then + n_hist_non_zero = n_hist_non_zero + 1 + i_non_zero(i_hist) = .true. + end if + end do + allocate (res_history_out (n_hist_non_zero)) + i_hist_new = 1 + do i_hist = 1, n_hist + if (i_non_zero (i_hist)) then + res_history_out (i_hist_new) = res_history_in (i_hist) + i_hist_new = i_hist_new + 1 + end if + end do + end subroutine contract_resonances -@ %def grove_prop_equal + subroutine remove_subresonances (res_history_in, res_history_out) + type(resonance_history_t), intent(in), dimension(:) :: res_history_in + type(resonance_history_t), intent(out), dimension(:), allocatable :: res_history_out + logical, dimension(:), allocatable :: i_non_sub_res + integer :: n_hist, n_hist_non_sub_res + integer :: i_hist1, i_hist2 + logical :: is_not_subres + n_hist = size (res_history_in); n_hist_non_sub_res = 0 + allocate (i_non_sub_res (n_hist)); i_non_sub_res = .false. + do i_hist1 = 1, n_hist + is_not_subres = .true. + do i_hist2 = 1, n_hist + if (i_hist1 == i_hist2) cycle + is_not_subres = is_not_subres .and. & + .not.(res_history_in(i_hist2) .contains. res_history_in(i_hist1)) + end do + if (is_not_subres) then + n_hist_non_sub_res = n_hist_non_sub_res + 1 + i_non_sub_res (i_hist1) = .true. + end if + end do + + allocate (res_history_out (n_hist_non_sub_res)) + i_hist2 = 1 + do i_hist1 = 1, n_hist + if (i_non_sub_res (i_hist1)) then + res_history_out (i_hist2) = res_history_in (i_hist1) + i_hist2 = i_hist2 + 1 + end if + end do + end subroutine remove_subresonances + + subroutine remove_multiple_resonances (res_history_in, res_history_out) + type(resonance_history_t), intent(in), dimension(:) :: res_history_in + type(resonance_history_t), intent(out), dimension(:), allocatable :: res_history_out + integer :: n_hist, n_hist_single + logical, dimension(:), allocatable :: i_hist_single + integer :: i_hist, j + n_hist = size (res_history_in) + n_hist_single = 0 + allocate (i_hist_single (n_hist)); i_hist_single = .false. + do i_hist = 1, n_hist + if (res_history_in(i_hist)%n_resonances == 1) then + n_hist_single = n_hist_single + 1 + i_hist_single(i_hist) = .true. + end if + end do + + allocate (res_history_out (n_hist_single)) + j = 1 + do i_hist = 1, n_hist + if (i_hist_single(i_hist)) then + res_history_out(j) = res_history_in(i_hist) + j = j + 1 + end if + end do + end subroutine remove_multiple_resonances + end subroutine clean_resonance_histories + +@ %def clean_resonance_histories @ -\subsection{Remove equivalent channels} -Here we define the equivalence condition for completed [[kingraphs]]. -The aim is to keep those [[kingraphs]] which describe the strongest -peaks of the amplitude. The [[bincodes]] and [[mappings]] have to be -the same for an equivalence, but the [[pdgs]] can be different. At -the same time we check if the trees are exacly the same (up to the -sign of pdg codes) in which case we do not keep both of them. This -can be the case when the incoming particles are the same or their -mutual anti-particles and there are no t-channel lines in the -Feynman diagram to which the kingraph belongs. -<>= - integer, parameter :: EMPTY = -999 -<>= - function kingraph_eqv (kingraph1, kingraph2) result (eqv) - type (kingraph_t), intent (in) :: kingraph1 - type (kingraph_t), intent (inout) :: kingraph2 - logical :: eqv - integer :: i - logical :: equal - eqv = .false. - do i = kingraph1%tree%n_entries, 1, -1 - if (kingraph1%tree%bc(i) /= kingraph2%tree%bc(i)) return - enddo - do i = kingraph1%tree%n_entries, 1, -1 - if ( .not. (kingraph1%tree%mapping(i) == kingraph2%tree%mapping(i) & - .or. ((kingraph1%tree%mapping(i) == NO_MAPPING .or. & - kingraph1%tree%mapping(i) == NONRESONANT) .and. & - (kingraph2%tree%mapping(i) == NO_MAPPING .or. & - kingraph2%tree%mapping(i) == NONRESONANT)))) return - enddo - equal = .true. - do i = kingraph1%tree%n_entries, 1, -1 - if (abs(kingraph1%tree%pdg(i)) /= abs(kingraph2%tree%pdg(i))) then - equal = .false.; - select case (kingraph1%tree%mapping(i)) - case (S_CHANNEL, RADIATION) - select case (kingraph2%tree%mapping(i)) - case (S_CHANNEL, RADIATION) - return - end select - end select - end if - enddo - if (equal) then - kingraph2%keep = .false. - call kingraph2%tree%final () +<>= + public :: get_filtered_resonance_histories +<>= + module subroutine get_filtered_resonance_histories & + (phs_config, n_in, flv_state, model, excluded_resonances, & + resonance_histories_filtered, success) + type(phs_fks_config_t), intent(inout) :: phs_config + integer, intent(in) :: n_in + integer, intent(in), dimension(:,:), allocatable :: flv_state + type(model_t), intent(in) :: model + type(string_t), intent(in), dimension(:), allocatable :: & + excluded_resonances + type(resonance_history_t), intent(out), dimension(:), & + allocatable :: resonance_histories_filtered + logical, intent(out) :: success + end subroutine get_filtered_resonance_histories +<>= + module subroutine get_filtered_resonance_histories & + (phs_config, n_in, flv_state, model, excluded_resonances, & + resonance_histories_filtered, success) + type(phs_fks_config_t), intent(inout) :: phs_config + integer, intent(in) :: n_in + integer, intent(in), dimension(:,:), allocatable :: flv_state + type(model_t), intent(in) :: model + type(string_t), intent(in), dimension(:), allocatable :: & + excluded_resonances + type(resonance_history_t), intent(out), dimension(:), & + allocatable :: resonance_histories_filtered + logical, intent(out) :: success + type(resonance_history_t), dimension(:), allocatable :: resonance_histories + type(resonance_history_t), dimension(:), allocatable :: & + resonance_histories_clean!, resonance_histories_filtered + allocate (resonance_histories (size (phs_config%get_resonance_histories ()))) + resonance_histories = phs_config%get_resonance_histories () + call clean_resonance_histories (resonance_histories, & + n_in, flv_state (:,1), resonance_histories_clean, success) + if (success .and. allocated (excluded_resonances)) then + call filter_particles_from_resonances (resonance_histories_clean, & + excluded_resonances, model, resonance_histories_filtered) else - eqv = .true. + allocate (resonance_histories_filtered (size (resonance_histories_clean))) + resonance_histories_filtered = resonance_histories_clean end if - end function kingraph_eqv + end subroutine get_filtered_resonance_histories -@ %def kingraph_eqv -@ Select between two [[kingraphs]] which fulfill the equivalence -condition above. This is done by comparing the [[pdg]] values of the -[[tree]] for increasing bincode. If the particles are different at -some place, we usually choose the one which would be returned first by the -subroutine [[match_vertex]] of the model for the daughter [[pdg]] codes. -Since we work here only on the basis of the the [[trees]] of the -completed [[kingraphs]], we have to use the [[bc]] array to determine -the positions of the daughter nodes' entries in the array. The graph -which has to be kept should correspond to the stronger peak at the place -which is compared. -<>= - subroutine kingraph_select (kingraph1, kingraph2, model, preliminary) - type (kingraph_t), intent (inout) :: kingraph1 - type (kingraph_t), intent (inout) :: kingraph2 - type (model_data_t), intent (in) :: model - logical, intent (in) :: preliminary - integer(TC), dimension(:), allocatable :: tmp_bc, daughter_bc - integer, dimension(:), allocatable :: tmp_pdg, daughter_pdg - integer, dimension (:), allocatable :: pdg_match - integer :: i, j - integer :: n_ext1, n_ext2 - if (kingraph_eqv (kingraph1, kingraph2)) then - if (.not. preliminary) then - kingraph2%keep = .false.; call kingraph2%tree%final () - return - end if - do i=1, size (kingraph1%tree%bc) - if (abs(kingraph1%tree%pdg(i)) /= abs(kingraph2%tree%pdg(i))) then - if (kingraph1%tree%mapping(i) /= EXTERNAL_PRT) then - n_ext1 = popcnt (kingraph1%tree%bc(i)) - n_ext2 = n_ext1 - do j=i+1, size (kingraph1%tree%bc) - if (abs(kingraph1%tree%pdg(j)) /= abs(kingraph2%tree%pdg(j))) then - n_ext2 = popcnt (kingraph1%tree%bc(j)) - if (n_ext2 < n_ext1) exit - end if - enddo - if (n_ext2 < n_ext1) cycle - allocate (tmp_bc(i-1)) - tmp_bc = kingraph1%tree%bc(:i-1) - allocate (tmp_pdg(i-1)) - tmp_pdg = kingraph1%tree%pdg(:i-1) - do j=i-1, 1, - 1 - where (iand (tmp_bc(:j-1),tmp_bc(j)) /= 0 & - .or. iand(tmp_bc(:j-1),kingraph1%tree%bc(i)) == 0) - tmp_bc(:j-1) = 0 - tmp_pdg(:j-1) = 0 - endwhere - enddo - allocate (daughter_bc(size(pack(tmp_bc, tmp_bc /= 0)))) - daughter_bc = pack (tmp_bc, tmp_bc /= 0) - allocate (daughter_pdg(size(pack(tmp_pdg, tmp_pdg /= 0)))) - daughter_pdg = pack (tmp_pdg, tmp_pdg /= 0) - if (size (daughter_pdg) == 2) then - call model%match_vertex(daughter_pdg(1), daughter_pdg(2), pdg_match) - end if - do j=1, size (pdg_match) - if (abs(pdg_match(j)) == abs(kingraph1%tree%pdg(i))) then - kingraph2%keep = .false.; call kingraph2%tree%final () - exit - else if (abs(pdg_match(j)) == abs(kingraph2%tree%pdg(i))) then - kingraph1%keep = .false.; call kingraph1%tree%final () - exit - end if - enddo - deallocate (tmp_bc, tmp_pdg, daughter_bc, daughter_pdg, pdg_match) - if (.not. (kingraph1%keep .and. kingraph2%keep)) exit - end if - end if - enddo - end if - end subroutine kingraph_select +@ %def get_filtered_resonance_histories +@ +\clearpage +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Unit tests} +Test module for FKS phase space, followed by the corresponding implementation module. +<<[[phs_fks_ut.f90]]>>= +<> -@ %def kingraph_select -@ At the beginning we do not care about the resonance hash, but only -about part of the grove properties, which is defined in -[[grove_prop_match]]. In these resulting preliminary groves the kingraphs -can be equivalent, i.e. we do not have to compare all graphs with each -other but only all graphs within each of these preliminary groves. In the -end we create a new grove list where the grove properties of the -[[kingraphs]] within a [[grove]] have to be exactly the same and in -addition the groves are distinguished by the resonance hash values. Here -the kingraphs are not compared any more, which means that the number of -channels is not reduced any more. -<>= - procedure :: merge => grove_list_merge -<>= - subroutine grove_list_merge (target_list, grove_list, model, prc_component) - class (grove_list_t), intent (inout) :: target_list - type (grove_list_t), intent (inout) :: grove_list - type (model_data_t), intent (in) :: model - integer, intent (in) :: prc_component - type (grove_t), pointer :: current_grove - type (kingraph_t), pointer :: current_graph - current_grove => grove_list%first - do while (associated (current_grove)) - do while (associated (current_grove%first)) - current_graph => current_grove%first - current_grove%first => current_grove%first%grove_next - current_graph%grove_next => null () - if (current_graph%keep) then - current_graph%prc_component = prc_component - call target_list%add_kingraph(kingraph=current_graph, & - preliminary=.false., check=.true., model=model) - else - call current_graph%final () - deallocate (current_graph) - end if - enddo - current_grove => current_grove%next - enddo - end subroutine grove_list_merge +module phs_fks_ut + use unit_tests + use phs_fks_uti -@ %def grove_list_merge -@ Recreate a grove list where we have different groves for different -resonance hashes. -<>= - procedure :: rebuild => grove_list_rebuild -<>= - subroutine grove_list_rebuild (grove_list) - class (grove_list_t), intent (inout) :: grove_list - type (grove_list_t) :: tmp_list - type (grove_t), pointer :: current_grove - type (grove_t), pointer :: remove_grove - type (kingraph_t), pointer :: current_graph - type (kingraph_t), pointer :: next_graph - tmp_list%first => grove_list%first - grove_list%first => null () - current_grove => tmp_list%first - do while (associated (current_grove)) - current_graph => current_grove%first - do while (associated (current_graph)) - call current_graph%assign_resonance_hash () - next_graph => current_graph%grove_next - current_graph%grove_next => null () - if (current_graph%keep) then - call grove_list%add_kingraph (kingraph=current_graph, & - preliminary=.false., check=.false.) - end if - current_graph => next_graph - enddo - current_grove => current_grove%next - enddo - call tmp_list%final - end subroutine grove_list_rebuild +<> -@ %def grove_list_rebuild +<> + +contains + +<> + +end module phs_fks_ut +@ %def phs_fks_ut @ -\subsection{Write the phase-space file} -The phase-space file is written from the graphs which survive the -calculations and equivalence checks and are in the grove list. It is -written grove by grove. The output should be the same as in the -corresponding procedure [[cascade_set_write_file_format]] of -[[cascades]], up to the order of groves and channels. -<>= - public :: feyngraph_set_write_file_format -<>= - subroutine feyngraph_set_write_file_format (feyngraph_set, u) - type (feyngraph_set_t), intent (in) :: feyngraph_set - integer, intent (in) :: u - type (grove_t), pointer :: grove - integer :: channel_number - integer :: grove_number - channel_number = 0 - grove_number = 0 - grove => feyngraph_set%grove_list%first - do while (associated (grove)) - grove_number = grove_number + 1 - call grove%write_file_format (feyngraph_set, grove_number, channel_number, u) - grove => grove%next - enddo - end subroutine feyngraph_set_write_file_format +<<[[phs_fks_uti.f90]]>>= +<> -@ %def feyngraph_set_write_file_format -@ Write the relevant information of the [[kingraphs]] of a [[grove]] and -the grove properties in the file format. -<>= - procedure :: write_file_format => grove_write_file_format -<>= - recursive subroutine grove_write_file_format (grove, feyngraph_set, gr_number, ch_number, u) - class (grove_t), intent (in) :: grove - type (feyngraph_set_t), intent (in) :: feyngraph_set - integer, intent (in) :: u - integer, intent (inout) :: gr_number - integer, intent (inout) :: ch_number - type (kingraph_t), pointer :: current -1 format(3x,A,1x,40(1x,I4)) - write (u, "(A)") - write (u, "(1x,'!',1x,A,1x,I0,A)", advance='no') & - 'Multiplicity =', grove%grove_prop%multiplicity, "," - select case (grove%grove_prop%n_resonances) - case (0) - write (u, '(1x,A)', advance='no') 'no resonances, ' - case (1) - write (u, '(1x,A)', advance='no') '1 resonance, ' - case default - write (u, '(1x,I0,1x,A)', advance='no') & - grove%grove_prop%n_resonances, 'resonances, ' - end select - write (u, '(1x,I0,1x,A)', advance='no') & - grove%grove_prop%n_log_enhanced, 'logs, ' - write (u, '(1x,I0,1x,A)', advance='no') & - grove%grove_prop%n_off_shell, 'off-shell, ' - select case (grove%grove_prop%n_t_channel) - case (0); write (u, '(1x,A)') 's-channel graph' - case (1); write (u, '(1x,A)') '1 t-channel line' - case default - write(u,'(1x,I0,1x,A)') & - grove%grove_prop%n_t_channel, 't-channel lines' - end select - write (u, '(1x,A,I0)') 'grove #', gr_number - current => grove%first - do while (associated (current)) - if (current%keep) then - ch_number = ch_number + 1 - call current%write_file_format (feyngraph_set, ch_number, u) - end if - current => current%grove_next - enddo - end subroutine grove_write_file_format +module phs_fks_uti -@ %def grove_write_file_format -@ Write the relevant information of a valid [[kingraph]] in the file -format. The information is extracted from the [[tree]]. -<>= - procedure :: write_file_format => kingraph_write_file_format -<>= - subroutine kingraph_write_file_format (kingraph, feyngraph_set, ch_number, u) - class (kingraph_t), intent (in) :: kingraph - type (feyngraph_set_t), intent (in) :: feyngraph_set - integer, intent (in) :: ch_number - integer, intent (in) :: u - integer :: i - integer(TC) :: bincode_incoming -2 format(3X,'map',1X,I3,1X,A,1X,I9,1X,'!',1X,A) -!!! determine bincode of incoming particle from tree - bincode_incoming = maxval (kingraph%tree%bc) - write (unit=u, fmt='(1X,A,I0)') '! Channel #', ch_number - write (unit=u, fmt='(3X,A,1X)', advance='no') 'tree' - do i=1, size (kingraph%tree%bc) - if (kingraph%tree%mapping(i) >=0 .or. kingraph%tree%mapping(i) == NONRESONANT & - .or. (kingraph%tree%bc(i) == bincode_incoming & - .and. feyngraph_set%process_type == DECAY)) then - write (unit=u, fmt='(1X,I0)', advance='no') kingraph%tree%bc(i) - end if - enddo - write (unit=u, fmt='(A)', advance='yes') - do i=1, size(kingraph%tree%bc) - select case (kingraph%tree%mapping(i)) - case (NO_MAPPING, NONRESONANT, EXTERNAL_PRT) - case (S_CHANNEL) - write (unit=u, fmt=2) kingraph%tree%bc(i), 's_channel', & - kingraph%tree%pdg(i), & - trim(get_particle_name (feyngraph_set, kingraph%tree%pdg(i))) - case (T_CHANNEL) - write (unit=u, fmt=2) kingraph%tree%bc(i), 't_channel', & - abs (kingraph%tree%pdg(i)), & - trim(get_particle_name (feyngraph_set, abs(kingraph%tree%pdg(i)))) - case (U_CHANNEL) - write (unit=u, fmt=2) kingraph%tree%bc(i), 'u_channel', & - abs (kingraph%tree%pdg(i)), & - trim(get_particle_name (feyngraph_set, abs(kingraph%tree%pdg(i)))) - case (RADIATION) - write (unit=u, fmt=2) kingraph%tree%bc(i), 'radiation', & - kingraph%tree%pdg(i), & - trim(get_particle_name (feyngraph_set, kingraph%tree%pdg(i))) - case (COLLINEAR) - write (unit=u, fmt=2) kingraph%tree%bc(i), 'collinear', & - kingraph%tree%pdg(i), & - trim(get_particle_name (feyngraph_set, kingraph%tree%pdg(i))) - case (INFRARED) - write (unit=u, fmt=2) kingraph%tree%bc(i), 'infrared ', & - kingraph%tree%pdg(i), & - trim(get_particle_name (feyngraph_set, kingraph%tree%pdg(i))) - case (ON_SHELL) - write (unit=u, fmt=2) kingraph%tree%bc(i), 'on_shell ', & - kingraph%tree%pdg(i), & - trim(get_particle_name (feyngraph_set, kingraph%tree%pdg(i))) - case default - call msg_bug (" Impossible mapping mode encountered") - end select - enddo - end subroutine kingraph_write_file_format +<> + use format_utils, only: write_separator, pac_fmt + use format_defs, only: FMT_15, FMT_19 + use numeric_utils, only: nearly_equal + use constants, only: tiny_07, zero, one, two + use lorentz + use phs_points, only: assignment(=) -@ %def kingraph_write_file_format -@ Get the particle name from the [[particle]] array of the -[[feyngraph_set]]. This is needed for the phs file creation. -<>= - function get_particle_name (feyngraph_set, pdg) result (particle_name) - type (feyngraph_set_t), intent (in) :: feyngraph_set - integer, intent (in) :: pdg - character (len=LABEL_LEN) :: particle_name - integer :: i - do i=1, size (feyngraph_set%particle) - if (feyngraph_set%particle(i)%pdg == pdg) then - particle_name = feyngraph_set%particle(i)%particle_label - exit - end if - enddo - end function get_particle_name + use physics_defs, only: THR_POS_B, THR_POS_BBAR, THR_POS_WP, THR_POS_WM, THR_POS_GLUON + use physics_defs, only: thr_leg -@ %def get_particle_name + use resonances, only: resonance_contributors_t + use phs_fks + +<> + +<> + +contains + +<> + +end module phs_fks_uti +@ %def phs_fks_uti +@ API: driver for the unit tests below. +<>= + public :: phs_fks_generator_test +<>= + subroutine phs_fks_generator_test (u, results) + integer, intent(in) :: u + type(test_results_t), intent(inout) :: results + call test(phs_fks_generator_1, "phs_fks_generator_1", & + "Test the generation of FKS phase spaces", u, results) + call test(phs_fks_generator_2, "phs_fks_generator_2", & + "Test the generation of an ISR FKS phase space", u, results) + call test(phs_fks_generator_3, "phs_fks_generator_3", & + "Test the generation of a real phase space for decays", & + u, results) + call test(phs_fks_generator_4, "phs_fks_generator_4", & + "Test the generation of an FSR phase space with "& + &"conserved invariant resonance masses", u, results) + call test(phs_fks_generator_5, "phs_fks_generator_5", & + "Test on-shell projection of a Born phase space and the generation"& + &" of a real phase-space from that", u, results) + call test(phs_fks_generator_6, "phs_fks_generator_6", & + "Test the generation of a real phase space for 1 -> 3 decays", & + u, results) + call test(phs_fks_generator_7, "phs_fks_generator_7", & + "Test the generation of an ISR FKS phase space for fixed beam energy", & + u, results) + end subroutine phs_fks_generator_test + +@ %def phs_fks_generator_test @ -\subsection{Invert a graph} -All Feynman diagrams given by O'Mega look like a decay. The [[feyngraph]] -which is constructed from this output also looks like a decay, where one -of the incoming particles is the decaying particle (or the root of the -tree). The calculations can in principle be done on this data structure. -However, it is also performed with the other incoming particle as -the root. The first part of the calculation is the same for both cases. -For the second part we need to transform/turn the graphs such that the -other incoming particle becomes the root. This is done by identifying -the incoming particles from the O'Mega output (the first one is simply -the root of the existing tree, the second contains [2] in the -[[particle_label]]) and the nodes/particles which connect both incoming -particles (here we set [[t_line = .true.]]). At the same time we set the -pointers [[inverse_daughter1]] and [[inverse_daughter2]] for the -corresponding node, which point to the mother node and the other daughter -of the mother node; these will be the daughters of the node in the -inverted [[feyngraph]]. -<>= - procedure :: make_invertible => feyngraph_make_invertible -<>= - subroutine feyngraph_make_invertible (feyngraph) - class (feyngraph_t), intent (inout) :: feyngraph - logical :: t_line_found - feyngraph%root%incoming = .true. - t_line_found = .false. - if (associated (feyngraph%root%daughter1)) then - call f_node_t_line_check (feyngraph%root%daughter1, t_line_found) - if (.not. t_line_found) then - if (associated (feyngraph%root%daughter2)) then - call f_node_t_line_check (feyngraph%root%daughter2, t_line_found) - end if - end if - end if +<>= + public :: phs_fks_generator_1 +<>= + subroutine phs_fks_generator_1 (u) + integer, intent(in) :: u + type(phs_fks_generator_t) :: generator + type(vector4_t), dimension(:), allocatable :: p_born + type(vector4_t), dimension(:), allocatable :: p_real + integer :: emitter, i_phs + real(default) :: x1, x2, x3 + real(default), parameter :: sqrts = 250.0_default + type(phs_identifier_t), dimension(2) :: phs_identifiers + write (u, "(A)") "* Test output: phs_fks_generator_1" + write (u, "(A)") "* Purpose: Create massless fsr phase space" + write (u, "(A)") - contains + allocate (p_born (4)) + p_born(1)%p(0) = 125.0_default + p_born(1)%p(1:2) = 0.0_default + p_born(1)%p(3) = 125.0_default + p_born(2)%p(0) = 125.0_default + p_born(2)%p(1:2) = 0.0_default + p_born(2)%p(3) = -125.0_default + p_born(3)%p(0) = 125.0_default + p_born(3)%p(1) = -39.5618_default + p_born(3)%p(2) = -20.0791_default + p_born(3)%p(3) = -114.6957_default + p_born(4)%p(0) = 125.0_default + p_born(4)%p(1:3) = -p_born(3)%p(1:3) -<> - end subroutine feyngraph_make_invertible + allocate (generator%isr_kinematics) + generator%n_in = 2 + generator%isr_kinematics%isr_mode = SQRTS_FIXED + call generator%set_xi_and_y_bounds () -@ %def feyngraph_make_invertible -@ Check if a node has to be [[t_line]] or [[incoming]] and assign -inverse daughter pointers. -<>= - recursive subroutine f_node_t_line_check (node, t_line_found) - type (f_node_t), target, intent (inout) :: node - integer :: pos - logical, intent (inout) :: t_line_found - if (associated (node%daughter1)) then - call f_node_t_line_check (node%daughter1, t_line_found) - if (node%daughter1%incoming .or. node%daughter1%t_line) then - node%t_line = .true. - else if (associated (node%daughter2)) then - call f_node_t_line_check (node%daughter2, t_line_found) - if (node%daughter2%incoming .or. node%daughter2%t_line) then - node%t_line = .true. - end if - end if - else - pos = index (node%particle_label, '[') + 1 - if (node%particle_label(pos:pos) == '2') then - node%incoming = .true. - t_line_found = .true. - end if - end if - end subroutine f_node_t_line_check + call generator%set_sqrts_hat (sqrts) -@ %def k_node_t_line_check -@ Make an inverted copy of a [[kingraph]] using the inverse daughter -pointers. -<>= - procedure :: make_inverse_copy => kingraph_make_inverse_copy -<>= - subroutine kingraph_make_inverse_copy (original_kingraph, feyngraph) - class (kingraph_t), intent (inout) :: original_kingraph - type (feyngraph_t), intent (inout) :: feyngraph - type (kingraph_t), pointer :: kingraph_copy - type (k_node_t), pointer :: potential_root - allocate (kingraph_copy) - if (associated (feyngraph%kin_last)) then - allocate (feyngraph%kin_last%next) - feyngraph%kin_last => feyngraph%kin_last%next - else - allocate(feyngraph%kin_first) - feyngraph%kin_last => feyngraph%kin_first - end if - kingraph_copy => feyngraph%kin_last - call kingraph_set_inverse_daughters (original_kingraph) - kingraph_copy%inverse = .true. - kingraph_copy%n_nodes = original_kingraph%n_nodes - kingraph_copy%keep = original_kingraph%keep - potential_root => original_kingraph%root - do while (.not. potential_root%incoming .or. & - (associated (potential_root%daughter1) .and. associated (potential_root%daughter2))) - if (potential_root%daughter1%incoming .or. potential_root%daughter1%t_line) then - potential_root => potential_root%daughter1 - else if (potential_root%daughter2%incoming .or. potential_root%daughter2%t_line) then - potential_root => potential_root%daughter2 - end if - enddo - call node_inverse_deep_copy (potential_root, kingraph_copy%root) - end subroutine kingraph_make_inverse_copy + write (u, "(A)") "* Use four-particle phase space containing: " + call vector4_write_set (p_born, u, testflag = .true., ultra = .true.) + write (u, "(A)") "***********************" + write (u, "(A)") -@ %def kingraph_make_inverse_copy -@ Recursively deep-copy nodes, but along the t-line the inverse daughters -become the new daughters. We need a deep copy only for the [[incoming]] -or [[t_line]] nodes. For the other nodes (of s-channel subgraphs) we set -only pointers to the existing nodes of the non-inverted graph. -<>= - recursive subroutine node_inverse_deep_copy (original_node, node_copy) - type (k_node_t), intent (in) :: original_node - type (k_node_t), pointer, intent (out) :: node_copy - call original_node%f_node%k_node_list%add_entry(node_copy, recycle=.false.) - node_copy = original_node - if (node_copy%t_line .or. node_copy%incoming) then - node_copy%particle => original_node%particle%anti - else - node_copy%particle => original_node%particle - end if - if (associated (original_node%inverse_daughter1) .and. associated (original_node%inverse_daughter2)) then - if (original_node%inverse_daughter1%incoming .or. original_node%inverse_daughter1%t_line) then - node_copy%daughter2 => original_node%inverse_daughter2 - call node_inverse_deep_copy (original_node%inverse_daughter1, & - node_copy%daughter1) - else if (original_node%inverse_daughter2%incoming .or. original_node%inverse_daughter2%t_line) then - node_copy%daughter1 => original_node%inverse_daughter1 - call node_inverse_deep_copy (original_node%inverse_daughter2, & - node_copy%daughter2) - end if - end if - end subroutine node_inverse_deep_copy + x1 = 0.5_default; x2 = 0.25_default; x3 = 0.75_default + write (u, "(A)" ) "* Use random numbers: " + write (u, "(A,F3.2,1X,A,F3.2,1X,A,F3.2)") & + "x1: ", x1, "x2: ", x2, "x3: ", x3 -@ %def node_inverse_deep_copy + allocate (generator%real_kinematics) + call generator%real_kinematics%init (4, 2, 2, 1) + + allocate (generator%emitters (2)) + generator%emitters(1) = 3; generator%emitters(2) = 4 + allocate (generator%m2 (4)) + generator%m2 = zero + allocate (generator%is_massive (4)) + generator%is_massive(1:2) = .false. + generator%is_massive(3:4) = .true. + phs_identifiers(1)%emitter = 3 + phs_identifiers(2)%emitter = 4 + call generator%compute_xi_ref_momenta (p_born) + call generator%generate_radiation_variables ([x1,x2,x3], p_born, phs_identifiers) + do i_phs = 1, 2 + emitter = phs_identifiers(i_phs)%emitter + call generator%compute_xi_max (emitter, i_phs, p_born, & + generator%real_kinematics%xi_max(i_phs)) + end do + write (u, "(A)") & + "* With these, the following radiation variables have been produced:" + associate (rad_var => generator%real_kinematics) + write (u, "(A,F3.2)") "xi_tilde: ", rad_var%xi_tilde + write (u, "(A,F3.2)") "y: " , rad_var%y(1) + write (u, "(A,F3.2)") "phi: ", rad_var%phi + end associate + call write_separator (u) + write (u, "(A)") "Produce real momenta: " + i_phs = 1; emitter = phs_identifiers(i_phs)%emitter + write (u, "(A,I1)") "emitter: ", emitter + + allocate (p_real (5)) + call generator%generate_fsr (emitter, i_phs, p_born, p_real) + call vector4_write_set (p_real, u, testflag = .true., ultra = .true.) + call write_separator (u) + write (u, "(A)") + write (u, "(A)") "* Test output end: phs_fks_generator_1" + + end subroutine phs_fks_generator_1 + +@ %def phs_fks_generator_1 @ -\subsection{Find phase-space parametrizations} -Perform all mapping calculations for a single process and store valid -[[kingraphs]] (channels) into the grove list, without caring for instance -about the resonance hash values. -<>= - public :: feyngraph_set_generate_single -<>= - subroutine feyngraph_set_generate_single (feyngraph_set, model, n_in, n_out, & - phs_par, fatal_beam_decay, u_in) - type(feyngraph_set_t), intent(inout) :: feyngraph_set - type(model_data_t), target, intent(in) :: model - integer, intent(in) :: n_in, n_out - type(phs_parameters_t), intent(in) :: phs_par - logical, intent(in) :: fatal_beam_decay - integer, intent(in) :: u_in - feyngraph_set%n_in = n_in - feyngraph_set%n_out = n_out - feyngraph_set%process_type = n_in - feyngraph_set%phs_par = phs_par - feyngraph_set%model => model - if (debug_on) call msg_debug (D_PHASESPACE, "Construct relevant Feynman diagrams from Omega output") - call feyngraph_set%build (u_in) - if (debug_on) call msg_debug (D_PHASESPACE, "Find phase-space parametrizations") - call feyngraph_set_find_phs_parametrizations(feyngraph_set) - end subroutine feyngraph_set_generate_single +<>= + public :: phs_fks_generator_2 +<>= + subroutine phs_fks_generator_2 (u) + integer, intent(in) :: u + type(phs_fks_generator_t) :: generator + type(vector4_t), dimension(:), allocatable :: p_born + type(vector4_t), dimension(:), allocatable :: p_real + integer :: emitter, i_phs + real(default) :: x1, x2, x3 + real(default), parameter :: sqrts_hadronic = 250.0_default + type(phs_identifier_t), dimension(2) :: phs_identifiers + write (u, "(A)") "* Test output: phs_fks_generator_2" + write (u, "(A)") "* Purpose: Create massless ISR phase space" + write (u, "(A)") -@ %def feyngraph_set_generate_single -@ Find the phase space parametrizations. We start with the computation -of pure s-channel subtrees, i.e. we determine mappings and compare -subtrees in order to reduce the number of channels. This can be -parallelized easily. When all s-channel [[k_nodes]] exist, the possible -[[kingraphs]] are created using these nodes and we determine mappings for -t-channel nodes. -<>= - subroutine feyngraph_set_find_phs_parametrizations (feyngraph_set) - class (feyngraph_set_t), intent (inout) :: feyngraph_set - type (feyngraph_t), pointer :: current => null () - type (feyngraph_ptr_t), dimension (:), allocatable :: set - integer :: pos - integer :: i - allocate (set (feyngraph_set%n_graphs)) - pos = 0 - current => feyngraph_set%first - do while (associated (current)) - pos = pos + 1 - set(pos)%graph => current - current => current%next - enddo - if (feyngraph_set%process_type == SCATTERING) then - !$OMP PARALLEL DO - do i=1, feyngraph_set%n_graphs - if (set(i)%graph%keep) then - call set(i)%graph%make_invertible () - end if - enddo - !$OMP END PARALLEL DO - end if - call f_node_list_compute_mappings_s (feyngraph_set) - do i=1, feyngraph_set%n_graphs - if (set(i)%graph%keep) then - call set(i)%graph%make_kingraphs (feyngraph_set) - end if - enddo - if (feyngraph_set%process_type == SCATTERING) then - do i=1, feyngraph_set%n_graphs - if (set(i)%graph%keep) then - call set(i)%graph%make_inverse_kingraphs () - end if - enddo - end if - do i=1, feyngraph_set%n_graphs - if (set(i)%graph%keep) then - call set(i)%graph%compute_mappings (feyngraph_set) - end if - enddo - do i=1, feyngraph_set%n_graphs - if (set(i)%graph%keep) then - call feyngraph_set%grove_list%add_feyngraph (set(i)%graph, & - feyngraph_set%model) - end if - enddo - end subroutine feyngraph_set_find_phs_parametrizations -@ %def feyngraph_set_find_phs_parametrizations -@ Compare objects of type [[tree_t]]. -<>= - interface operator (==) - module procedure tree_equal - end interface operator (==) -<>= - elemental function tree_equal (tree1, tree2) result (flag) - type (tree_t), intent (in) :: tree1, tree2 - logical :: flag - if (tree1%n_entries == tree2%n_entries) then - if (tree1%bc(size(tree1%bc)) == tree2%bc(size(tree2%bc))) then - flag = all (tree1%mapping == tree2%mapping) .and. & - all (tree1%bc == tree2%bc) .and. & - all (abs(tree1%pdg) == abs(tree2%pdg)) - else - flag = .false. - end if - else - flag = .false. - end if - end function tree_equal + allocate (p_born (4)) + p_born(1)%p(0) = 114.661_default + p_born(1)%p(1:2) = 0.0_default + p_born(1)%p(3) = 114.661_default + p_born(2)%p(0) = 121.784_default + p_born(2)%p(1:2) = 0.0_default + p_born(2)%p(3) = -121.784_default + p_born(3)%p(0) = 115.148_default + p_born(3)%p(1) = -46.250_default + p_born(3)%p(2) = -37.711_default + p_born(3)%p(3) = 98.478_default + p_born(4)%p(0) = 121.296_default + p_born(4)%p(1:2) = -p_born(3)%p(1:2) + p_born(4)%p(3) = -105.601_default -@ %def tree_equal -@ Select between equivalent subtrees (type [[tree_t]]). This is similar -to [[kingraph_select]], but we compare only positions with mappings -[[NONRESONANT]] and [[NO_MAPPING]]. -<>= - interface operator (.eqv.) - module procedure subtree_eqv - end interface operator (.eqv.) -<>= - pure function subtree_eqv (subtree1, subtree2) result (eqv) - type (tree_t), intent (in) :: subtree1, subtree2 - logical :: eqv - integer :: root_pos - integer :: i - logical :: equal - eqv = .false. - if (subtree1%n_entries /= subtree2%n_entries) return - root_pos = subtree1%n_entries - if (subtree1%mapping(root_pos) == NONRESONANT .or. & - subtree2%mapping(root_pos) == NONRESONANT .or. & - (subtree1%mapping(root_pos) == NO_MAPPING .and. & - subtree2%mapping(root_pos) == NO_MAPPING .and. & - abs(subtree1%pdg(root_pos)) == abs(subtree2%pdg(root_pos)))) then - do i = subtree1%n_entries, 1, -1 - if (subtree1%bc(i) /= subtree2%bc(i)) return - enddo - equal = .true. - do i = subtree1%n_entries, 1, -1 - if (abs(subtree1%pdg(i)) /= abs (subtree2%pdg(i))) then - select case (subtree1%mapping(i)) - case (NO_MAPPING, NONRESONANT) - select case (subtree2%mapping(i)) - case (NO_MAPPING, NONRESONANT) - equal = .false. - case default - return - end select - case default - return - end select - end if - enddo - do i = subtree1%n_entries, 1, -1 - if (subtree1%mapping(i) /= subtree2%mapping(i)) then - select case (subtree1%mapping(i)) - case (NO_MAPPING, NONRESONANT) - select case (subtree2%mapping(i)) - case (NO_MAPPING, NONRESONANT) - case default - return - end select - case default - return - end select - end if - enddo - if (.not. equal) eqv = .true. - end if - end function subtree_eqv + phs_identifiers(1)%emitter = 1 + phs_identifiers(2)%emitter = 2 -@ %def subtree_eqv -<>= - subroutine subtree_select (subtree1, subtree2, model) - type (tree_t), intent (inout) :: subtree1, subtree2 - type (model_data_t), intent (in) :: model - integer :: j, k - integer(TC), dimension(:), allocatable :: tmp_bc, daughter_bc - integer, dimension(:), allocatable :: tmp_pdg, daughter_pdg - integer, dimension (:), allocatable :: pdg_match - if (subtree1 .eqv. subtree2) then - do j=1, subtree1%n_entries - if (abs(subtree1%pdg(j)) /= abs(subtree2%pdg(j))) then - tmp_bc = subtree1%bc(:j-1); tmp_pdg = subtree1%pdg(:j-1) - do k=j-1, 1, - 1 - where (iand (tmp_bc(:k-1),tmp_bc(k)) /= 0 & - .or. iand(tmp_bc(:k-1),subtree1%bc(j)) == 0) - tmp_bc(:k-1) = 0 - tmp_pdg(:k-1) = 0 - endwhere - enddo - daughter_bc = pack (tmp_bc, tmp_bc /= 0) - daughter_pdg = pack (tmp_pdg, tmp_pdg /= 0) - if (size (daughter_pdg) == 2) then - call model%match_vertex(daughter_pdg(1), daughter_pdg(2), pdg_match) - if (.not. allocated (pdg_match)) then -!!! Relevant if tree contains only abs (pdg). In this case, changing the -!!! sign of one of the pdg codes should give a result. - call model%match_vertex(-daughter_pdg(1), daughter_pdg(2), pdg_match) - end if - end if - do k=1, size (pdg_match) - if (abs(pdg_match(k)) == abs(subtree1%pdg(j))) then - if (subtree1%keep) subtree2%keep = .false. - exit - else if (abs(pdg_match(k)) == abs(subtree2%pdg(j))) then - if (subtree2%keep) subtree1%keep = .false. - exit - end if - enddo - deallocate (tmp_bc, tmp_pdg, daughter_bc, daughter_pdg, pdg_match) - if (.not. (subtree1%keep .and. subtree2%keep)) exit - end if - enddo - end if - end subroutine subtree_select + allocate (generator%emitters (2)) + allocate (generator%isr_kinematics) + generator%emitters(1) = 1; generator%emitters(2) = 2 + generator%sqrts = sqrts_hadronic + allocate (generator%isr_kinematics%beam_energy(2)) + generator%isr_kinematics%beam_energy = sqrts_hadronic / two + call generator%set_sqrts_hat (sqrts_hadronic) + call generator%set_isr_kinematics (p_born) + generator%n_in = 2 + generator%isr_kinematics%isr_mode = SQRTS_VAR + call generator%set_xi_and_y_bounds () + write (u, "(A)") "* Use four-particle phase space containing: " + call vector4_write_set (p_born, u, testflag = .true., ultra = .true.) + write (u, "(A)") "***********************" + write (u, "(A)") -@ %def subtree_select -@ Assign a resonance hash value to a [[kingraph]], like in [[cascades]], -but here without the array [[tree_resonant]]. -<>= - procedure :: assign_resonance_hash => kingraph_assign_resonance_hash -<>= - subroutine kingraph_assign_resonance_hash (kingraph) - class (kingraph_t), intent (inout) :: kingraph - logical, dimension (:), allocatable :: tree_resonant - integer(i8), dimension(1) :: mold - allocate (tree_resonant (kingraph%tree%n_entries)) - tree_resonant = (kingraph%tree%mapping == S_CHANNEL) - kingraph%grove_prop%res_hash = hash (transfer & - ([sort (pack (kingraph%tree%pdg, tree_resonant)), & - sort (pack (abs (kingraph%tree%pdg), & - kingraph%tree%mapping == T_CHANNEL .or. & - kingraph%tree%mapping == U_CHANNEL))], mold)) - deallocate (tree_resonant) - end subroutine kingraph_assign_resonance_hash + x1=0.5_default; x2=0.25_default; x3=0.65_default + write (u, "(A)" ) "* Use random numbers: " + write (u, "(A,F3.2,1X,A,F3.2,1X,A,F3.2)") & + "x1: ", x1, "x2: ", x2, "x3: ", x3 -@ %def kingraph_assign_resonance_hash -@ Write the process in the bincode format. This is again a copy of the -corresponding procedure in [[cascades]], using [[feyngraph_set]] instead -of [[cascade_set]] as an argument. -<>= - public :: feyngraph_set_write_process_bincode_format -<>= - subroutine feyngraph_set_write_process_bincode_format (feyngraph_set, unit) - type(feyngraph_set_t), intent(in), target :: feyngraph_set - integer, intent(in), optional :: unit - integer, dimension(:), allocatable :: bincode, field_width - integer :: n_in, n_out, n_tot, n_flv - integer :: u, f, i, bc - character(20) :: str - type(string_t) :: fmt_head - type(string_t), dimension(:), allocatable :: fmt_proc - u = given_output_unit (unit); if (u < 0) return - if (.not. allocated (feyngraph_set%flv)) return - write (u, "('!',1x,A)") "List of subprocesses with particle bincodes:" - n_in = feyngraph_set%n_in - n_out = feyngraph_set%n_out - n_tot = n_in + n_out - n_flv = size (feyngraph_set%flv, 2) - allocate (bincode (n_tot), field_width (n_tot), fmt_proc (n_tot)) - bc = 1 - do i = 1, n_out - bincode(n_in + i) = bc - bc = 2 * bc + allocate (generator%real_kinematics) + call generator%real_kinematics%init (4, 2, 2, 1) + call generator%real_kinematics%p_born_lab%set_momenta (1, p_born) + + allocate (generator%m2 (2)) + generator%m2(1) = 0._default; generator%m2(2) = 0._default + allocate (generator%is_massive (4)) + generator%is_massive = .false. + call generator%generate_radiation_variables ([x1,x2,x3], p_born, phs_identifiers) + call generator%compute_xi_ref_momenta (p_born) + do i_phs = 1, 2 + emitter = phs_identifiers(i_phs)%emitter + call generator%compute_xi_max (emitter, i_phs, p_born, & + generator%real_kinematics%xi_max(i_phs)) end do - do i = n_in, 1, -1 - bincode(i) = bc - bc = 2 * bc + write (u, "(A)") & + "* With these, the following radiation variables have been produced:" + associate (rad_var => generator%real_kinematics) + write (u, "(A,F3.2)") "xi_tilde: ", rad_var%xi_tilde + write (u, "(A,F3.2)") "y: " , rad_var%y(1) + write (u, "(A,F3.2)") "phi: ", rad_var%phi + end associate + write (u, "(A)") "Initial-state momentum fractions: " + associate (xb => generator%isr_kinematics%x) + write (u, "(A,F3.2)") "x_born_plus: ", xb(1) + write (u, "(A,F3.2)") "x_born_minus: ", xb(2) + end associate + call write_separator (u) + write (u, "(A)") "Produce real momenta: " + i_phs = 1; emitter = phs_identifiers(i_phs)%emitter + write (u, "(A,I1)") "emitter: ", emitter + allocate (p_real(5)) + call generator%generate_isr (i_phs, p_born, p_real) + call vector4_write_set (p_real, u, testflag = .true., ultra = .true.) + call write_separator (u) + write (u, "(A)") + write (u, "(A)") "* Test output end: phs_fks_generator_2" + + end subroutine phs_fks_generator_2 + +@ %def phs_fks_generator_2 +@ +<>= + public :: phs_fks_generator_3 +<>= + subroutine phs_fks_generator_3 (u) + integer, intent(in) :: u + type(phs_fks_generator_t) :: generator + type(vector4_t), dimension(:), allocatable :: p_born + type(vector4_t), dimension(:), allocatable :: p_real + real(default) :: x1, x2, x3 + real(default) :: mB, mW, mT + integer :: i, emitter, i_phs + type(phs_identifier_t), dimension(2) :: phs_identifiers + + write (u, "(A)") "* Test output: phs_fks_generator_3" + write (u, "(A)") "* Puropse: Create real phase space for particle decays" + write (u, "(A)") + + allocate (p_born(3)) + p_born(1)%p(0) = 172._default + p_born(1)%p(1) = 0._default + p_born(1)%p(2) = 0._default + p_born(1)%p(3) = 0._default + p_born(2)%p(0) = 104.72866679_default + p_born(2)%p(1) = 45.028053213_default + p_born(2)%p(2) = 29.450337581_default + p_born(2)%p(3) = -5.910229156_default + p_born(3)%p(0) = 67.271333209_default + p_born(3)%p(1:3) = -p_born(2)%p(1:3) + + generator%n_in = 1 + allocate (generator%isr_kinematics) + generator%isr_kinematics%isr_mode = SQRTS_FIXED + call generator%set_xi_and_y_bounds () + + mB = 4.2_default + mW = 80.376_default + mT = 172._default + + generator%sqrts = mT + + write (u, "(A)") "* Use three-particle phase space containing: " + call vector4_write_set (p_born, u, testflag = .true., ultra = .true.) + write (u, "(A)") "**********************" + write (u, "(A)") + + x1 = 0.5_default; x2 = 0.25_default; x3 = 0.6_default + write (u, "(A)") "* Use random numbers: " + write (u, "(A,F3.2,1X,A,F3.2,A,1X,F3.2)") & + "x1: ", x1, "x2: ", x2, "x3: ", x3 + + allocate (generator%real_kinematics) + call generator%real_kinematics%init (3, 2, 2, 1) + call generator%real_kinematics%p_born_lab%set_momenta (1, p_born) + + allocate (generator%emitters(2)) + generator%emitters(1) = 1 + generator%emitters(2) = 3 + allocate (generator%m2 (3), generator%is_massive(3)) + generator%m2(1) = mT**2 + generator%m2(2) = mW**2 + generator%m2(3) = mB**2 + generator%is_massive = .true. + phs_identifiers(1)%emitter = 1 + phs_identifiers(2)%emitter = 3 + + call generator%generate_radiation_variables ([x1,x2,x3], p_born, phs_identifiers) + call generator%compute_xi_ref_momenta (p_born) + do i_phs = 1, 2 + emitter = phs_identifiers(i_phs)%emitter + call generator%compute_xi_max (emitter, i_phs, p_born, & + generator%real_kinematics%xi_max(i_phs)) end do - do i = 1, n_tot - write (str, "(I0)") bincode(i) - field_width(i) = len_trim (str) - do f = 1, n_flv - field_width(i) = max (field_width(i), & - len (feyngraph_set%flv(i,f)%get_name ())) - end do + + write (u, "(A)") & + "* With these, the following radiation variables have been produced: " + associate (rad_var => generator%real_kinematics) + write (u, "(A,F4.2)") "xi_tilde: ", rad_var%xi_tilde + do i = 1, 2 + write (u, "(A,I1,A,F5.2)") "i: ", i, "y: " , rad_var%y(i) + end do + write (u, "(A,F4.2)") "phi: ", rad_var%phi + end associate + + call write_separator (u) + write (u, "(A)") "Produce real momenta via initial-state emission: " + i_phs = 1; emitter = phs_identifiers(i_phs)%emitter + write (u, "(A,I1)") "emitter: ", emitter + allocate (p_real (4)) + call generator%generate_isr_fixed_beam_energy (i_phs, p_born, p_real) + call pacify (p_real, 1E-6_default) + call vector4_write_set (p_real, u, testflag = .true., ultra = .true.) + call write_separator(u) + write (u, "(A)") "Produce real momenta via final-state emisson: " + i_phs = 2; emitter = phs_identifiers(i_phs)%emitter + write (u, "(A,I1)") "emitter: ", emitter + call generator%generate_fsr (emitter, i_phs, p_born, p_real) + call pacify (p_real, 1E-6_default) + call vector4_write_set (p_real, u, testflag = .true., ultra = .true.) + write (u, "(A)") + write (u, "(A)") "* Test output end: phs_fks_generator_3" + + end subroutine phs_fks_generator_3 + +@ %def phs_fks_generator_3 +@ +<>= + public :: phs_fks_generator_4 +<>= + subroutine phs_fks_generator_4 (u) + integer, intent(in) :: u + type(phs_fks_generator_t) :: generator + type(vector4_t), dimension(:), allocatable :: p_born + type(vector4_t), dimension(:), allocatable :: p_real + integer, dimension(:), allocatable :: emitters + integer, dimension(:,:), allocatable :: resonance_lists + type(resonance_contributors_t), dimension(2) :: alr_contributors + real(default) :: x1, x2, x3 + real(default), parameter :: sqrts = 250.0_default + integer, parameter :: nlegborn = 6 + integer :: i_phs, i_con, emitter + real(default) :: m_inv_born, m_inv_real + character(len=7) :: fmt + type(phs_identifier_t), dimension(2) :: phs_identifiers + + call pac_fmt (fmt, FMT_19, FMT_15, .true.) + + write (u, "(A)") "* Test output: phs_fks_generator_4" + write (u, "(A)") "* Purpose: Create FSR phase space with fixed resonances" + write (u, "(A)") + + allocate (p_born (nlegborn)) + p_born(1)%p(0) = 250._default + p_born(1)%p(1) = 0._default + p_born(1)%p(2) = 0._default + p_born(1)%p(3) = 250._default + p_born(2)%p(0) = 250._default + p_born(2)%p(1) = 0._default + p_born(2)%p(2) = 0._default + p_born(2)%p(3) = -250._default + p_born(3)%p(0) = 145.91184486_default + p_born(3)%p(1) = 50.39727589_default + p_born(3)%p(2) = 86.74156041_default + p_born(3)%p(3) = -69.03608748_default + p_born(4)%p(0) = 208.1064784_default + p_born(4)%p(1) = -44.07610020_default + p_born(4)%p(2) = -186.34264578_default + p_born(4)%p(3) = 13.48038407_default + p_born(5)%p(0) = 26.25614471_default + p_born(5)%p(1) = -25.12258068_default + p_born(5)%p(2) = -1.09540228_default + p_born(5)%p(3) = -6.27703505_default + p_born(6)%p(0) = 119.72553196_default + p_born(6)%p(1) = 18.80140499_default + p_born(6)%p(2) = 100.69648766_default + p_born(6)%p(3) = 61.83273846_default + + allocate (generator%isr_kinematics) + generator%n_in = 2 + generator%isr_kinematics%isr_mode = SQRTS_FIXED + call generator%set_xi_and_y_bounds () + + call generator%set_sqrts_hat (sqrts) + + write (u, "(A)") "* Test process: e+ e- -> W+ W- b b~" + write (u, "(A)") "* Resonance pairs: (3,5) and (4,6)" + write (u, "(A)") "* Use four-particle phase space containing: " + call vector4_write_set (p_born, u, testflag = .true., ultra = .true.) + write (u, "(A)") "******************************" + write (u, "(A)") + + x1 = 0.5_default; x2 = 0.25_default; x3 = 0.75_default + write (u, "(A)") "* Use random numbers: " + write (u, "(A,F3.2,1X,A,F3.2,1X,A,F3.2)") & + "x1: ", x1, "x2: ", x2, "x3: ", x3 + + allocate (generator%real_kinematics) + call generator%real_kinematics%init (nlegborn, 2, 2, 2) + + allocate (generator%emitters (2)) + generator%emitters(1) = 5; generator%emitters(2) = 6 + allocate (generator%m2 (nlegborn)) + generator%m2 = p_born**2 + allocate (generator%is_massive (nlegborn)) + generator%is_massive (1:2) = .false. + generator%is_massive (3:6) = .true. + + phs_identifiers(1)%emitter = 5 + phs_identifiers(2)%emitter = 6 + do i_phs = 1, 2 + allocate (phs_identifiers(i_phs)%contributors (2)) end do - fmt_head = "('!'" - do i = 1, n_tot - fmt_head = fmt_head // ",1x," - fmt_proc(i) = "(1x," - write (str, "(I0)") field_width(i) - fmt_head = fmt_head // "I" // trim(str) - fmt_proc(i) = fmt_proc(i) // "A" // trim(str) - if (i == n_in) then - fmt_head = fmt_head // ",1x,' '" + allocate (resonance_lists (2, 2)) + resonance_lists (1,:) = [3,5] + resonance_lists (2,:) = [4,6] + !!! Here is obviously some redundance. Surely we can improve on this. + do i_phs = 1, 2 + phs_identifiers(i_phs)%contributors = resonance_lists(i_phs,:) + end do + do i_con = 1, 2 + allocate (alr_contributors(i_con)%c (size (resonance_lists(i_con,:)))) + alr_contributors(i_con)%c = resonance_lists(i_con,:) + end do + call generator%generate_radiation_variables & + ([x1, x2, x3], p_born, phs_identifiers) + + allocate (p_real(nlegborn + 1)) + call generator%compute_xi_ref_momenta (p_born, alr_contributors) + !!! Keep the distinction between i_phs and i_con because in general, + !!! they are not the same. + do i_phs = 1, 2 + i_con = i_phs + emitter = phs_identifiers(i_phs)%emitter + write (u, "(A,I1,1X,A,I1,A,I1,A)") & + "* Generate FSR phase space for emitter ", emitter, & + "and resonance pair (", resonance_lists (i_con, 1), ",", & + resonance_lists (i_con, 2), ")" + call generator%compute_xi_max (emitter, i_phs, p_born, & + generator%real_kinematics%xi_max(i_phs), i_con = i_con) + call generator%generate_fsr (emitter, i_phs, i_con, p_born, p_real) + call vector4_write_set (p_real, u, testflag = .true., ultra = .true.) + call write_separator(u) + write (u, "(A)") "* Check if resonance masses are conserved: " + m_inv_born = compute_resonance_mass (p_born, resonance_lists (i_con,:)) + m_inv_real = compute_resonance_mass (p_real, resonance_lists (i_con,:), 7) + write (u, "(A,1X, " // fmt // ")") "m_inv_born = ", m_inv_born + write (u, "(A,1X, " // fmt // ")") "m_inv_real = ", m_inv_real + if (abs (m_inv_born - m_inv_real) < tiny_07) then + write (u, "(A)") " Success! " + else + write (u, "(A)") " Failure! " end if + call write_separator(u) + call write_separator(u) end do - do i = 1, n_tot - fmt_proc(i) = fmt_proc(i) // ")" + deallocate (p_real) + write (u, "(A)") + write (u, "(A)") "* Test output end: phs_fks_generator_4" + end subroutine phs_fks_generator_4 + +@ %def phs_fks_generator_4 +@ +<>= + public :: phs_fks_generator_5 +<>= + subroutine phs_fks_generator_5 (u) + use ttv_formfactors, only: init_parameters + integer, intent(in) :: u + type(phs_fks_generator_t) :: generator + type(vector4_t), dimension(:), allocatable :: p_born, pb1 + type(vector4_t), dimension(:), allocatable :: p_born_onshell, pb1_os + type(vector4_t), dimension(:), allocatable :: p_real + real(default) :: x1, x2, x3 + real(default) :: mB, mW, mtop, mcheck + integer :: i, emitter, i_phs + type(phs_identifier_t), dimension(2) :: phs_identifiers + type(lorentz_transformation_t) :: L_to_cms + real(default), parameter :: sqrts = 360._default + real(default), parameter :: momentum_tolerance = 1E-10_default + real(default) :: mpole, gam_out + + write (u, "(A)") "* Test output: phs_fks_generator_5" + write (u, "(A)") "* Puropse: Perform threshold on-shell projection of " + write (u, "(A)") "* Born momenta and create a real phase-space " + write (u, "(A)") "* point from those. " + write (u, "(A)") + + allocate (p_born(6), p_born_onshell(6)) + p_born(1)%p(0) = sqrts / two + p_born(1)%p(1:2) = zero + p_born(1)%p(3) = sqrts / two + p_born(2)%p(0) = sqrts / two + p_born(2)%p(1:2) = zero + p_born(2)%p(3) = -sqrts / two + p_born(3)%p(0) = 117.1179139230_default + p_born(3)%p(1) = 56.91215483880_default + p_born(3)%p(2) = -40.02386013017_default + p_born(3)%p(3) = -49.07634310496_default + p_born(4)%p(0) = 98.91904548743_default + p_born(4)%p(1) = 56.02241403836_default + p_born(4)%p(2) = -8.302977504723_default + p_born(4)%p(3) = -10.50293716131_default + p_born(5)%p(0) = 62.25884689208_default + p_born(5)%p(1) = -60.00786540278_default + p_born(5)%p(2) = 4.753602375910_default + p_born(5)%p(3) = 15.32916731546_default + p_born(6)%p(0) = 81.70419369751_default + p_born(6)%p(1) = -52.92670347439_default + p_born(6)%p(2) = 43.57323525898_default + p_born(6)%p(3) = 44.25011295081_default + + generator%n_in = 2 + allocate (generator%isr_kinematics) + generator%isr_kinematics%isr_mode = SQRTS_FIXED + call generator%set_xi_and_y_bounds () + + mB = 4.2_default + mW = 80.376_default + mtop = 172._default + + generator%sqrts = sqrts + + !!! Dummy-initialization of the threshold model because generate_fsr_threshold + !!! uses m1s_to_mpole to determine if it is above or below threshold. + call init_parameters (mpole, gam_out, mtop, one, one / 1.5_default, 125._default, & + 0.47_default, 0.118_default, 91._default, 80._default, 4.2_default, & + one, one, one, one, zero, zero, zero, zero, zero, zero, .false., zero) + + write (u, "(A)") "* Use four-particle phase space containing: " + call vector4_write_set (p_born, u, testflag = .true., ultra = .true.) + call vector4_check_momentum_conservation & + (p_born, 2, unit = u, abs_smallness = momentum_tolerance, verbose = .true.) + write (u, "(A)") "**********************" + write (u, "(A)") + + allocate (generator%real_kinematics) + call generator%real_kinematics%init (7, 2, 2, 2) + call generator%real_kinematics%init_onshell (7, 2) + generator%real_kinematics%p_born_cms%phs_point(1) = p_born + + write (u, "(A)") "Get boost projection system -> CMS: " + L_to_cms = get_boost_for_threshold_projection (p_born, sqrts, mtop) + call L_to_cms%write (u, testflag = .true., ultra = .true.) + write (u, "(A)") "**********************" + write (u, "(A)") + + write (u, "(A)") "* Perform onshell-projection:" + pb1 = generator%real_kinematics%p_born_cms%phs_point(1) + call threshold_projection_born (mtop, L_to_cms, pb1, p_born_onshell) + generator%real_kinematics%p_born_onshell%phs_point(1) = p_born_onshell + + call generator%real_kinematics%p_born_onshell%write & + (1, unit = u, testflag = .true., ultra = .true.) + + pb1_os = generator%real_kinematics%p_born_onshell%phs_point(1) + call check_phsp (pb1_os, 0) + + allocate (generator%emitters (2)) + generator%emitters(1) = THR_POS_B; generator%emitters(2) = THR_POS_BBAR + + allocate (generator%m2 (6), generator%is_massive(6)) + generator%m2 = p_born**2 + generator%is_massive (1:2) = .false. + generator%is_massive (3:6) = .true. + + phs_identifiers(1)%emitter = THR_POS_B + phs_identifiers(2)%emitter = THR_POS_BBAR + + x1 = 0.5_default; x2 = 0.25_default; x3 = 0.6_default + write (u, "(A)") "* Use random numbers: " + write (u, "(A,F3.2,1X,A,F3.2,A,1X,F3.2)") & + "x1: ", x1, "x2: ", x2, "x3: ", x3 + + + call generator%generate_radiation_variables ([x1,x2,x3], p_born_onshell, phs_identifiers) + do i_phs = 1, 2 + emitter = phs_identifiers(i_phs)%emitter + call generator%compute_xi_ref_momenta_threshold (p_born_onshell) + call generator%compute_xi_max (emitter, i_phs, p_born_onshell, & + generator%real_kinematics%xi_max(i_phs), i_con = thr_leg(emitter)) end do - fmt_head = fmt_head // ")" - write (u, char (fmt_head)) bincode - do f = 1, n_flv - write (u, "('!')", advance="no") - do i = 1, n_tot - write (u, char (fmt_proc(i)), advance="no") & - char (feyngraph_set%flv(i,f)%get_name ()) - if (i == n_in) write (u, "(1x,'=>')", advance="no") - end do - write (u, *) + write (u, "(A)") & + "* With these, the following radiation variables have been produced: " + associate (rad_var => generator%real_kinematics) + write (u, "(A,F4.2)") "xi_tilde: ", rad_var%xi_tilde + write (u, "(A)") "xi_max: " + write (u, "(2F5.2)") rad_var%xi_max(1), rad_var%xi_max(2) + write (u, "(A)") "y: " + write (u, "(2F5.2)") rad_var%y(1), rad_var%y(2) + write (u, "(A,F4.2)") "phi: ", rad_var%phi + end associate + + call write_separator (u) + write (u, "(A)") "* Produce real momenta from on-shell phase space: " + allocate (p_real(7)) + do i_phs = 1, 2 + emitter = phs_identifiers(i_phs)%emitter + write (u, "(A,I1)") "emitter: ", emitter + call generator%generate_fsr_threshold (emitter, i_phs, p_born_onshell, p_real) + call check_phsp (p_real, emitter) end do - write (u, char (fmt_head)) bincode - end subroutine feyngraph_set_write_process_bincode_format -@ %def feyngraph_set_write_process_bincode_format -@ Write tex file for graphical display of channels. -<>= - public :: feyngraph_set_write_graph_format -<>= - subroutine feyngraph_set_write_graph_format (feyngraph_set, filename, process_id, unit) - type(feyngraph_set_t), intent(in), target :: feyngraph_set - type(string_t), intent(in) :: filename, process_id - integer, intent(in), optional :: unit - type(kingraph_t), pointer :: kingraph - type(grove_t), pointer :: grove - integer :: u, n_grove, count, pgcount - logical :: first_in_grove - u = given_output_unit (unit); if (u < 0) return - write (u, '(A)') "\documentclass[10pt]{article}" - write (u, '(A)') "\usepackage{amsmath}" - write (u, '(A)') "\usepackage{feynmp}" - write (u, '(A)') "\usepackage{url}" - write (u, '(A)') "\usepackage{color}" - write (u, *) - write (u, '(A)') "\textwidth 18.5cm" - write (u, '(A)') "\evensidemargin -1.5cm" - write (u, '(A)') "\oddsidemargin -1.5cm" - write (u, *) - write (u, '(A)') "\newcommand{\blue}{\color{blue}}" - write (u, '(A)') "\newcommand{\green}{\color{green}}" - write (u, '(A)') "\newcommand{\red}{\color{red}}" - write (u, '(A)') "\newcommand{\magenta}{\color{magenta}}" - write (u, '(A)') "\newcommand{\cyan}{\color{cyan}}" - write (u, '(A)') "\newcommand{\sm}{\footnotesize}" - write (u, '(A)') "\setlength{\parindent}{0pt}" - write (u, '(A)') "\setlength{\parsep}{20pt}" - write (u, *) - write (u, '(A)') "\begin{document}" - write (u, '(A)') "\begin{fmffile}{" // char (filename) // "}" - write (u, '(A)') "\fmfcmd{color magenta; magenta = red + blue;}" - write (u, '(A)') "\fmfcmd{color cyan; cyan = green + blue;}" - write (u, '(A)') "\begin{fmfshrink}{0.5}" - write (u, '(A)') "\begin{flushleft}" - write (u, *) - write (u, '(A)') "\noindent" // & - & "\textbf{\large\texttt{WHIZARD} phase space channels}" // & - & "\hfill\today" - write (u, *) - write (u, '(A)') "\vspace{10pt}" - write (u, '(A)') "\noindent" // & - & "\textbf{Process:} \url{" // char (process_id) // "}" - call feyngraph_set_write_process_tex_format (feyngraph_set, u) - write (u, *) - write (u, '(A)') "\noindent" // & - & "\textbf{Note:} These are pseudo Feynman graphs that " - write (u, '(A)') "visualize phase-space parameterizations " // & - & "(``integration channels''). " - write (u, '(A)') "They do \emph{not} indicate Feynman graphs used for the " // & - & "matrix element." - write (u, *) - write (u, '(A)') "\textbf{Color code:} " // & - & "{\blue resonance,} " // & - & "{\cyan t-channel,} " // & - & "{\green radiation,} " - write (u, '(A)') "{\red infrared,} " // & - & "{\magenta collinear,} " // & - & "external/off-shell" - write (u, *) - write (u, '(A)') "\noindent" // & - & "\textbf{Black square:} Keystone, indicates ordering of " // & - & "phase space parameters." - write (u, *) - write (u, '(A)') "\vspace{-20pt}" - count = 0 - pgcount = 0 - n_grove = 0 - grove => feyngraph_set%grove_list%first - do while (associated (grove)) - n_grove = n_grove + 1 - write (u, *) - write (u, '(A)') "\vspace{20pt}" - write (u, '(A)') "\begin{tabular}{l}" - write (u, '(A,I5,A)') & - & "\fbox{\bf Grove \boldmath$", n_grove, "$} \\[10pt]" - write (u, '(A,I1,A)') "Multiplicity: ", & - grove%grove_prop%multiplicity, "\\" - write (u, '(A,I1,A)') "Resonances: ", & - grove%grove_prop%n_resonances, "\\" - write (u, '(A,I1,A)') "Log-enhanced: ", & - grove%grove_prop%n_log_enhanced, "\\" - write (u, '(A,I1,A)') "Off-shell: ", & - grove%grove_prop%n_off_shell, "\\" - write (u, '(A,I1,A)') "t-channel: ", & - grove%grove_prop%n_t_channel, "" - write (u, '(A)') "\end{tabular}" - kingraph => grove%first - do while (associated (kingraph)) - count = count + 1 - call kingraph_write_graph_format (kingraph, count, unit) - kingraph => kingraph%grove_next - enddo - grove => grove%next - enddo - write (u, '(A)') "\end{flushleft}" - write (u, '(A)') "\end{fmfshrink}" - write (u, '(A)') "\end{fmffile}" - write (u, '(A)') "\end{document}" - end subroutine feyngraph_set_write_graph_format + call write_separator(u) + write (u, "(A)") + write (u, "(A)") "* Test output end: phs_fks_generator_5" -@ %def feyngraph_set_write_graph_format -@ Write the process as a \LaTeX\ expression. This is a slightly modified -copy of [[cascade_set_write_process_tex_format]] which has only been -adapted to the types which are used here. -<>= - subroutine feyngraph_set_write_process_tex_format (feyngraph_set, unit) - type(feyngraph_set_t), intent(in), target :: feyngraph_set - integer, intent(in), optional :: unit - integer :: n_tot - integer :: u, f, i - n_tot = feyngraph_set%n_in + feyngraph_set%n_out - u = given_output_unit (unit); if (u < 0) return - if (.not. allocated (feyngraph_set%flv)) return - write (u, "(A)") "\begin{align*}" - do f = 1, size (feyngraph_set%flv, 2) - do i = 1, feyngraph_set%n_in - if (i > 1) write (u, "(A)", advance="no") "\quad " - write (u, "(A)", advance="no") & - char (feyngraph_set%flv(i,f)%get_tex_name ()) - end do - write (u, "(A)", advance="no") "\quad &\to\quad " - do i = feyngraph_set%n_in + 1, n_tot - if (i > feyngraph_set%n_in + 1) write (u, "(A)", advance="no") "\quad " - write (u, "(A)", advance="no") & - char (feyngraph_set%flv(i,f)%get_tex_name ()) - end do - if (f < size (feyngraph_set%flv, 2)) then - write (u, "(A)") "\\" + contains + subroutine check_phsp (p, emitter) + type(vector4_t), intent(inout), dimension(:) :: p + integer, intent(in) :: emitter + type(vector4_t) :: pp + real(default) :: E_tot + logical :: check + write (u, "(A)") "* Check momentum conservation: " + call vector4_check_momentum_conservation & + (p, 2, unit = u, abs_smallness = momentum_tolerance, verbose = .true.) + write (u, "(A)") "* Check invariant masses: " + write (u, "(A)", advance = "no") "inv(W+, b, gl): " + pp = p(THR_POS_WP) + p(THR_POS_B) + if (emitter == THR_POS_B) pp = pp + p(THR_POS_GLUON) + if (nearly_equal (pp**1, mtop)) then + write (u, "(A)") "CHECK" else - write (u, "(A)") "" + write (u, "(A,F7.3)") "FAIL: ", pp**1 + end if + write (u, "(A)", advance = "no") "inv(W-, bbar): " + pp = p(THR_POS_WM) + p(THR_POS_BBAR) + if (emitter == THR_POS_BBAR) pp = pp + p(THR_POS_GLUON) + if (nearly_equal (pp**1, mtop)) then + write (u, "(A)") "CHECK" + else + write (u, "(A,F7.3)") "FAIL: ", pp**1 + end if + write (u, "(A)") "* Sum of energies equal to sqrts?" + E_tot = sum(p(1:2)%p(0)); check = nearly_equal (E_tot, sqrts) + write (u, "(A,L1)") "Initial state: ", check + if (.not. check) write (u, "(A,F7.3)") "E_tot: ", E_tot + if (emitter > 0) then + E_tot = sum(p(3:7)%p(0)) + else + E_tot = sum(p(3:6)%p(0)) end if + check = nearly_equal (E_tot, sqrts) + write (u, "(A,L1)") "Final state : ", check + if (.not. check) write (u, "(A,F7.3)") "E_tot: ", E_tot + call pacify (p, 1E-6_default) + call vector4_write_set (p, u, testflag = .true., ultra = .true.) + + end subroutine check_phsp + end subroutine phs_fks_generator_5 + +@ %def phs_fks_generator_5 +@ + +<>= + public :: phs_fks_generator_6 +<>= + subroutine phs_fks_generator_6 (u) + integer, intent(in) :: u + type(phs_fks_generator_t) :: generator + type(vector4_t), dimension(:), allocatable :: p_born + type(vector4_t), dimension(:), allocatable :: p_real + real(default) :: x1, x2, x3 + real(default) :: mB, mW, mT + integer :: i, emitter, i_phs + type(phs_identifier_t), dimension(2) :: phs_identifiers + + write (u, "(A)") "* Test output: phs_fks_generator_6" + write (u, "(A)") "* Puropse: Create real phase space for particle decays" + write (u, "(A)") + + allocate (p_born(4)) + p_born(1)%p(0) = 173.1_default + p_born(1)%p(1) = zero + p_born(1)%p(2) = zero + p_born(1)%p(3) = zero + p_born(2)%p(0) = 68.17074462929_default + p_born(2)%p(1) = -37.32578717617_default + p_born(2)%p(2) = 30.99675959336_default + p_born(2)%p(3) = -47.70321718398_default + p_born(3)%p(0) = 65.26639312326_default + p_born(3)%p(1) = -1.362927648502_default + p_born(3)%p(2) = -33.25327150840_default + p_born(3)%p(3) = 56.14324922494_default + p_born(4)%p(0) = 39.66286224745_default + p_born(4)%p(1) = 38.68871482467_default + p_born(4)%p(2) = 2.256511915049_default + p_born(4)%p(3) = -8.440032040958_default + + generator%n_in = 1 + allocate (generator%isr_kinematics) + generator%isr_kinematics%isr_mode = SQRTS_FIXED + call generator%set_xi_and_y_bounds () + + mB = 4.2_default + mW = 80.376_default + mT = 173.1_default + + generator%sqrts = mT + + write (u, "(A)") "* Use four-particle phase space containing: " + call vector4_write_set (p_born, u, testflag = .true., ultra = .true.) + write (u, "(A)") "**********************" + write (u, "(A)") + + x1=0.5_default; x2=0.25_default; x3=0.6_default + write (u, "(A)") "* Use random numbers: " + write (u, "(A,F3.2,1X,A,F3.2,A,1X,F3.2)") & + "x1: ", x1, "x2: ", x2, "x3: ", x3 + + allocate (generator%real_kinematics) + call generator%real_kinematics%init (3, 2, 2, 1) + call generator%real_kinematics%p_born_lab%set_momenta (1, p_born) + + allocate (generator%emitters(2)) + generator%emitters(1) = 1 + generator%emitters(2) = 2 + allocate (generator%m2 (4), generator%is_massive(4)) + generator%m2(1) = mT**2 + generator%m2(2) = mB**2 + generator%m2(3) = zero + generator%m2(4) = zero + generator%is_massive(1:2) = .true. + generator%is_massive(3:4) = .false. + phs_identifiers(1)%emitter = 1 + phs_identifiers(2)%emitter = 2 + + call generator%generate_radiation_variables ([x1,x2,x3], p_born, phs_identifiers) + call generator%compute_xi_ref_momenta (p_born) + do i_phs = 1, 2 + emitter = phs_identifiers(i_phs)%emitter + call generator%compute_xi_max (emitter, i_phs, p_born, & + generator%real_kinematics%xi_max(i_phs)) end do - write (u, "(A)") "\end{align*}" - end subroutine feyngraph_set_write_process_tex_format -@ %def feyngraph_set_write_process_tex_format -@ This creates metapost source for graphical display for a given [[kingraph]]. -It is the analogon to [[cascade_write_graph_format]] (a modified copy). -<>= - subroutine kingraph_write_graph_format (kingraph, count, unit) - type(kingraph_t), intent(in) :: kingraph - integer, intent(in) :: count - integer, intent(in), optional :: unit - integer :: u - type(string_t) :: left_str, right_str - u = given_output_unit (unit); if (u < 0) return - left_str = "" - right_str = "" - write (u, '(A)') "\begin{minipage}{105pt}" - write (u, '(A)') "\vspace{30pt}" - write (u, '(A)') "\begin{center}" - write (u, '(A)') "\begin{fmfgraph*}(55,55)" - call graph_write_node (kingraph%root) - write (u, '(A)') "\fmfleft{" // char (extract (left_str, 2)) // "}" - write (u, '(A)') "\fmfright{" // char (extract (right_str, 2)) // "}" - write (u, '(A)') "\end{fmfgraph*}\\" - write (u, '(A,I5,A)') "\fbox{$", count, "$}" - write (u, '(A)') "\end{center}" - write (u, '(A)') "\end{minipage}" - write (u, '(A)') "%" - contains - recursive subroutine graph_write_node (node) - type(k_node_t), intent(in) :: node - if (associated (node%daughter1) .or. associated (node%daughter2)) then - if (node%daughter2%t_line .or. node%daughter2%incoming) then - call vertex_write (node, node%daughter2) - call vertex_write (node, node%daughter1) - else - call vertex_write (node, node%daughter1) - call vertex_write (node, node%daughter2) - end if - if (node%mapping == EXTERNAL_PRT) then - call line_write (node%bincode, 0, node%particle) - call external_write (node%bincode, node%particle%tex_name, & - left_str) - write (u, '(A,I0,A)') "\fmfv{d.shape=square}{v0}" - end if - else - if (node%incoming) then - call external_write (node%bincode, node%particle%anti%tex_name, & - left_str) - else - call external_write (node%bincode, node%particle%tex_name, & - right_str) - end if - end if - end subroutine graph_write_node - recursive subroutine vertex_write (node, daughter) - type(k_node_t), intent(in) :: node, daughter - integer :: bincode - if (associated (node%daughter1) .and. associated (node%daughter2) & - .and. node%mapping == EXTERNAL_PRT) then - bincode = 0 - else - bincode = node%bincode - end if - call graph_write_node (daughter) - if (associated (node%daughter1) .or. associated (node%daughter2)) then - call line_write (bincode, daughter%bincode, daughter%particle, & - mapping=daughter%mapping) - else - call line_write (bincode, daughter%bincode, daughter%particle) - end if - end subroutine vertex_write - subroutine line_write (i1, i2, particle, mapping) - integer(TC), intent(in) :: i1, i2 - type(part_prop_t), intent(in) :: particle - integer, intent(in), optional :: mapping - integer :: k1, k2 - type(string_t) :: prt_type - select case (particle%spin_type) - case (SCALAR); prt_type = "plain" - case (SPINOR); prt_type = "fermion" - case (VECTOR); prt_type = "boson" - case (VECTORSPINOR); prt_type = "fermion" - case (TENSOR); prt_type = "dbl_wiggly" - case default; prt_type = "dashes" - end select - if (particle%pdg < 0) then -!!! anti-particle - k1 = i2; k2 = i1 - else - k1 = i1; k2 = i2 - end if - if (present (mapping)) then - select case (mapping) - case (S_CHANNEL) - write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & - & ",f=blue,lab=\sm\blue$" // & - & char (particle%tex_name) // "$}" // & - & "{v", k1, ",v", k2, "}" - case (T_CHANNEL, U_CHANNEL) - write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & - & ",f=cyan,lab=\sm\cyan$" // & - & char (particle%tex_name) // "$}" // & - & "{v", k1, ",v", k2, "}" - case (RADIATION) - write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & - & ",f=green,lab=\sm\green$" // & - & char (particle%tex_name) // "$}" // & - & "{v", k1, ",v", k2, "}" - case (COLLINEAR) - write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & - & ",f=magenta,lab=\sm\magenta$" // & - & char (particle%tex_name) // "$}" // & - & "{v", k1, ",v", k2, "}" - case (INFRARED) - write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & - & ",f=red,lab=\sm\red$" // & - & char (particle%tex_name) // "$}" // & - & "{v", k1, ",v", k2, "}" - case default - write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & - & ",f=black}" // & - & "{v", k1, ",v", k2, "}" - end select - else - write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & - & "}" // & - & "{v", k1, ",v", k2, "}" - end if - end subroutine line_write - subroutine external_write (bincode, name, ext_str) - integer(TC), intent(in) :: bincode - type(string_t), intent(in) :: name - type(string_t), intent(inout) :: ext_str - character(len=20) :: str - write (str, '(A2,I0)') ",v", bincode - ext_str = ext_str // trim (str) - write (u, '(A,I0,A,I0,A)') "\fmflabel{\sm$" & - // char (name) & - // "\,(", bincode, ")" & - // "$}{v", bincode, "}" - end subroutine external_write - end subroutine kingraph_write_graph_format + write (u, "(A)") & + "* With these, the following radiation variables have been produced: " + associate (rad_var => generator%real_kinematics) + write (u, "(A,F4.2)") "xi_tilde: ", rad_var%xi_tilde + do i = 1, 2 + write (u, "(A,I1,A,F5.2)") "i: ", i, "y: " , rad_var%y(i) + end do + write (u, "(A,F4.2)") "phi: ", rad_var%phi + end associate -@ %def kingraph_write_graph_format -@ Generate a [[feyngraph_set]] for several subprocesses. Mapping -calculations are performed separately, but the final grove list is shared -between the subsets [[fset]] of the [[feyngraph_set]]. -<>= - public :: feyngraph_set_generate -<>= - subroutine feyngraph_set_generate & - (feyngraph_set, model, n_in, n_out, flv, phs_par, fatal_beam_decay, & - u_in, vis_channels, use_dag) - type(feyngraph_set_t), intent(out) :: feyngraph_set - class(model_data_t), intent(in), target :: model - integer, intent(in) :: n_in, n_out - type(flavor_t), dimension(:,:), intent(in) :: flv - type(phs_parameters_t), intent(in) :: phs_par - logical, intent(in) :: fatal_beam_decay - integer, intent(in) :: u_in - logical, intent(in) :: vis_channels - logical, optional, intent(in) :: use_dag - type(grove_t), pointer :: grove - integer :: i, j - type(kingraph_t), pointer :: kingraph - if (phase_space_vanishes (phs_par%sqrts, n_in, flv)) return - if (present (use_dag)) feyngraph_set%use_dag = use_dag - feyngraph_set%process_type = n_in - feyngraph_set%n_in = n_in - feyngraph_set%n_out = n_out - allocate (feyngraph_set%flv (size (flv, 1), size (flv, 2))) - do i = 1, size (flv, 2) - do j = 1, size (flv, 1) - call feyngraph_set%flv(j,i)%init (flv(j,i)%get_pdg (), model) - end do + call write_separator (u) + write (u, "(A)") "Produce real momenta via initial-state emission: " + i_phs = 1; emitter = phs_identifiers(i_phs)%emitter + write (u, "(A,I1)") "emitter: ", emitter + allocate (p_real(5)) + call generator%generate_isr_fixed_beam_energy (i_phs, p_born, p_real) + call pacify (p_real, 1E-6_default) + call vector4_write_set (p_real, u, testflag = .true., ultra = .true.) + call write_separator(u) + write (u, "(A)") "Produce real momenta via final-state emisson: " + i_phs = 2; emitter = phs_identifiers(i_phs)%emitter + write (u, "(A,I1)") "emitter: ", emitter + call generator%generate_fsr (emitter, i_phs, p_born, p_real) + call pacify (p_real, 1E-6_default) + call vector4_write_set (p_real, u, testflag = .true., ultra = .true.) + write (u, "(A)") + write (u, "(A)") "* Test output end: phs_fks_generator_6" + + end subroutine phs_fks_generator_6 + +@ %def phs_fks_generator_6 +@ +<>= + public :: phs_fks_generator_7 +<>= + subroutine phs_fks_generator_7 (u) + integer, intent(in) :: u + type(phs_fks_generator_t) :: generator + type(vector4_t), dimension(:), allocatable :: p_born + type(vector4_t), dimension(:), allocatable :: p_real + real(default) :: x1, x2, x3 + integer :: i, emitter, i_phs + type(phs_identifier_t), dimension(2) :: phs_identifiers + real(default), parameter :: sqrts = 1000.0_default + + write (u, "(A)") "* Test output: phs_fks_generator_7" + write (u, "(A)") "* Puropse: Create real phase space for scattering ISR" + write (u, "(A)") "* keeping the beam energy fixed." + write (u, "(A)") + + allocate (p_born(4)) + p_born(1)%p(0) = 500._default + p_born(1)%p(1) = 0._default + p_born(1)%p(2) = 0._default + p_born(1)%p(3) = 500._default + p_born(2)%p(0) = 500._default + p_born(2)%p(1) = 0._default + p_born(2)%p(2) = 0._default + p_born(2)%p(3) = -500._default + p_born(3)%p(0) = 500._default + p_born(3)%p(1) = 11.275563070_default + p_born(3)%p(2) = -13.588797663_default + p_born(3)%p(3) = 486.93070588_default + p_born(4)%p(0) = 500._default + p_born(4)%p(1:3) = -p_born(3)%p(1:3) + + phs_identifiers(1)%emitter = 1 + phs_identifiers(2)%emitter = 2 + + allocate (generator%emitters(2)) + generator%n_in = 2 + allocate (generator%isr_kinematics) + generator%isr_kinematics%isr_mode = SQRTS_FIXED + call generator%set_xi_and_y_bounds () + generator%emitters(1) = 1; generator%emitters(2) = 2 + generator%sqrts = sqrts + + write (u, "(A)") "* Use 2 -> 2 phase space containing: " + call vector4_write_set (p_born, u, testflag = .true., ultra = .true.) + write (u, "(A)") "**********************" + write (u, "(A)") + + x1 = 0.5_default; x2 = 0.25_default; x3 = 0.6_default + write (u, "(A)") "* Use random numbers: " + write (u, "(A,F3.2,1X,A,F3.2,A,1X,F3.2)") & + "x1: ", x1, "x2: ", x2, "x3: ", x3 + + allocate (generator%real_kinematics) + call generator%real_kinematics%init (4, 2, 2, 1) + call generator%real_kinematics%p_born_lab%set_momenta (1, p_born) + + allocate (generator%m2 (4)) + generator%m2 = 0._default + allocate (generator%is_massive(4)) + generator%is_massive = .false. + call generator%generate_radiation_variables ([x1,x2,x3], p_born, phs_identifiers) + call generator%compute_xi_ref_momenta (p_born) + do i_phs = 1, 2 + emitter = phs_identifiers(i_phs)%emitter + call generator%compute_xi_max (emitter, i_phs, p_born, & + generator%real_kinematics%xi_max(i_phs)) end do - allocate (feyngraph_set%particle (PRT_ARRAY_SIZE)) - allocate (feyngraph_set%grove_list) - allocate (feyngraph_set%fset (size (flv, 2))) - do i = 1, size (feyngraph_set%fset) - feyngraph_set%fset(i)%use_dag = feyngraph_set%use_dag - allocate (feyngraph_set%fset(i)%flv(size (flv,1),1)) - feyngraph_set%fset(i)%flv(:,1) = flv(:,i) - feyngraph_set%fset(i)%particle => feyngraph_set%particle - allocate (feyngraph_set%fset(i)%grove_list) - call feyngraph_set_generate_single (feyngraph_set%fset(i), & - model, n_in, n_out, phs_par, fatal_beam_decay, u_in) - call feyngraph_set%grove_list%merge (feyngraph_set%fset(i)%grove_list, model, i) - if (.not. vis_channels) call feyngraph_set%fset(i)%final() - enddo - call feyngraph_set%grove_list%rebuild () - end subroutine feyngraph_set_generate -@ %def feyngraph_set_generate -@ Check whether the [[grove_list]] of the [[feyngraph_set]] contains any -[[kingraphs]] which are valid, i.e. where the [[keep]] variable has the -value [[.true.]]. This is necessary to write a non-empty phase-space -file. The function is the pendant to [[cascade_set_is_valid]]. -<>= - public :: feyngraph_set_is_valid -<>= - function feyngraph_set_is_valid (feyngraph_set) result (flag) - class (feyngraph_set_t), intent(in) :: feyngraph_set - type (kingraph_t), pointer :: kingraph - type (grove_t), pointer :: grove - logical :: flag - flag = .false. - if (associated (feyngraph_set%grove_list)) then - grove => feyngraph_set%grove_list%first - do while (associated (grove)) - kingraph => grove%first - do while (associated (kingraph)) - if (kingraph%keep) then - flag = .true. - return - end if - kingraph => kingraph%next - enddo - grove => grove%next - enddo - end if - end function feyngraph_set_is_valid + write (u, "(A)") & + "* With these, the following radiation variables have been produced: " + associate (rad_var => generator%real_kinematics) + write (u, "(A,F4.2)") "xi_tilde: ", rad_var%xi_tilde + do i = 1, 2 + write (u, "(A,I1,A,F5.2)") "i: ", i, "y: " , rad_var%y(i) + end do + write (u, "(A,F4.2)") "phi: ", rad_var%phi + end associate -@ %def feyngraph_set_is_valid + call write_separator (u) + write (u, "(A)") "Produce real momenta via initial-state emission: " + i_phs = 1; emitter = phs_identifiers(i_phs)%emitter + write (u, "(A,I1)") "emitter: ", emitter + allocate (p_real(5)) + call generator%generate_isr_fixed_beam_energy (i_phs, p_born, p_real) + call pacify (p_real, 1E-6_default) + call vector4_write_set (p_real, u, testflag = .true., ultra = .true.) + call write_separator(u) + i_phs = 2; emitter = phs_identifiers(i_phs)%emitter + write (u, "(A,I1)") "emitter: ", emitter + call generator%generate_isr_fixed_beam_energy (i_phs, p_born, p_real) + call pacify (p_real, 1E-6_default) + call vector4_write_set (p_real, u, testflag = .true., ultra = .true.) + write (u, "(A)") + write (u, "(A)") "* Test output end: phs_fks_generator_7" + + end subroutine phs_fks_generator_7 + +@ %def phs_fks_generator_3 @ -\subsection{Return the resonance histories for subtraction} -The following procedures are copies of corresponding procedures in -[[cascades]], which only have been adapted to the new types used in -this module.\\ -Extract the resonance set from a valid [[kingraph]] which is kept in the -final grove list. -<>= - procedure :: extract_resonance_history => kingraph_extract_resonance_history -<>= - subroutine kingraph_extract_resonance_history & - (kingraph, res_hist, model, n_out) - class(kingraph_t), intent(in), target :: kingraph - type(resonance_history_t), intent(out) :: res_hist - class(model_data_t), intent(in), target :: model - integer, intent(in) :: n_out - type(resonance_info_t) :: resonance - integer :: i, mom_id, pdg - if (debug_on) call msg_debug2 (D_PHASESPACE, "kingraph_extract_resonance_history") - if (kingraph%grove_prop%n_resonances > 0) then - if (associated (kingraph%root%daughter1) .or. & - associated (kingraph%root%daughter2)) then - if (debug_on) call msg_debug2 (D_PHASESPACE, "kingraph has resonances, root has children") - do i = 1, kingraph%tree%n_entries - if (kingraph%tree%mapping(i) == S_CHANNEL) then - mom_id = kingraph%tree%bc (i) - pdg = kingraph%tree%pdg (i) - call resonance%init (mom_id, pdg, model, n_out) - if (debug2_active (D_PHASESPACE)) then - print *, 'D: Adding resonance' - call resonance%write () - end if - call res_hist%add_resonance (resonance) - end if - end do - end if +\section{Dispatch} +<<[[dispatch_phase_space.f90]]>>= +<> + +module dispatch_phase_space + +<> +<> + use variables, only: var_list_t + use os_interface, only: os_data_t + + use sf_mappings, only: sf_channel_t + use beam_structures, only: beam_structure_t + use dispatch_beams, only: sf_prop_t, strfun_mode + + use mappings + use phs_forests, only: phs_parameters_t + use phs_base + +<> + +<> + + interface +<> + end interface + +end module dispatch_phase_space +@ %def dispatch_phase_space +@ +<<[[dispatch_phase_space_sub.f90]]>>= +<> + +submodule (dispatch_phase_space) dispatch_phase_space_s + + use io_units, only: free_unit + use diagnostics + use phs_none + use phs_single + use phs_rambo + use phs_wood + use phs_fks + + implicit none + +contains + +<> + +end submodule dispatch_phase_space_s + +@ %def dispatch_phase_space_s +@ +Allocate a phase-space object according to the variable [[$phs_method]]. +<>= + public :: dispatch_phs +<>= + module subroutine dispatch_phs (phs, var_list, os_data, process_id, & + mapping_defaults, phs_par, phs_method_in) + class(phs_config_t), allocatable, intent(inout) :: phs + type(var_list_t), intent(in) :: var_list + type(os_data_t), intent(in) :: os_data + type(string_t), intent(in) :: process_id + type(mapping_defaults_t), intent(in), optional :: mapping_defaults + type(phs_parameters_t), intent(in), optional :: phs_par + type(string_t), intent(in), optional :: phs_method_in + end subroutine dispatch_phs +<>= + module subroutine dispatch_phs (phs, var_list, os_data, process_id, & + mapping_defaults, phs_par, phs_method_in) + class(phs_config_t), allocatable, intent(inout) :: phs + type(var_list_t), intent(in) :: var_list + type(os_data_t), intent(in) :: os_data + type(string_t), intent(in) :: process_id + type(mapping_defaults_t), intent(in), optional :: mapping_defaults + type(phs_parameters_t), intent(in), optional :: phs_par + type(string_t), intent(in), optional :: phs_method_in + type(string_t) :: phs_method, phs_file, run_id + logical :: use_equivalences, vis_channels, fatal_beam_decay + integer :: u_phs + logical :: exist + if (present (phs_method_in)) then + phs_method = phs_method_in + else + phs_method = & + var_list%get_sval (var_str ("$phs_method")) end if - end subroutine kingraph_extract_resonance_history + phs_file = & + var_list%get_sval (var_str ("$phs_file")) + use_equivalences = & + var_list%get_lval (var_str ("?use_vamp_equivalences")) + vis_channels = & + var_list%get_lval (var_str ("?vis_channels")) + fatal_beam_decay = & + var_list%get_lval (var_str ("?fatal_beam_decay")) + run_id = & + var_list%get_sval (var_str ("$run_id")) + select case (char (phs_method)) + case ("none") + allocate (phs_none_config_t :: phs) + case ("single") + allocate (phs_single_config_t :: phs) + if (vis_channels) then + call msg_warning ("Visualizing phase space channels not " // & + "available for method 'single'.") + end if + case ("rambo") + allocate (phs_rambo_config_t :: phs) + if (vis_channels) & + call msg_warning ("Visualizing phase space channels not " // & + "available for method 'rambo'.") + case ("fks") + allocate (phs_fks_config_t :: phs) + if (use_equivalences) then + select type (phs) + type is (phs_fks_config_t) + call phs%enable_equivalences () + end select + end if + case ("wood", "default", "fast_wood") + call dispatch_wood () + case default + call msg_fatal ("Phase space: parameterization method '" & + // char (phs_method) // "' not implemented") + end select + contains + <> + end subroutine dispatch_phs -@ %def kingraph_extract_resonance_history -@ Determine the number of valid [[kingraphs]] in [[grove_list]]. -<>= - public :: grove_list_get_n_trees -<>= - function grove_list_get_n_trees (grove_list) result (n) - class (grove_list_t), intent (in) :: grove_list - integer :: n - type(kingraph_t), pointer :: kingraph - type(grove_t), pointer :: grove - if (debug_on) call msg_debug (D_PHASESPACE, "grove_list_get_n_trees") - n = 0 - grove => grove_list%first - do while (associated (grove)) - kingraph => grove%first - do while (associated (kingraph)) - if (kingraph%keep) n = n + 1 - kingraph => kingraph%grove_next - enddo - grove => grove%next - enddo - if (debug_on) call msg_debug (D_PHASESPACE, "n", n) - end function grove_list_get_n_trees +@ %def dispatch_phs +@ +<>= + subroutine dispatch_wood () + allocate (phs_wood_config_t :: phs) + select type (phs) + type is (phs_wood_config_t) + if (phs_file /= "") then + inquire (file = char (phs_file), exist = exist) + if (exist) then + call msg_message ("Phase space: reading configuration from '" & + // char (phs_file) // "'") + u_phs = free_unit () + open (u_phs, file = char (phs_file), & + action = "read", status = "old") + call phs%set_input (u_phs) + else + call msg_fatal ("Phase space: configuration file '" & + // char (phs_file) // "' not found") + end if + end if + if (present (phs_par)) & + call phs%set_parameters (phs_par) + if (use_equivalences) & + call phs%enable_equivalences () + if (present (mapping_defaults)) & + call phs%set_mapping_defaults (mapping_defaults) + if (phs_method == "fast_wood") phs%use_cascades2 = .true. + phs%vis_channels = vis_channels + phs%fatal_beam_decay = fatal_beam_decay + phs%os_data = os_data + phs%run_id = run_id + end select + end subroutine dispatch_wood -@ %def grove_list_get_n_trees -@ Extract the resonance histories from the [[feyngraph_set]], in complete -analogy to [[cascade_set_get_resonance_histories]] -<>= - public :: feyngraph_set_get_resonance_histories -<>= - subroutine feyngraph_set_get_resonance_histories (feyngraph_set, n_filter, res_hists) - type(feyngraph_set_t), intent(in), target :: feyngraph_set - integer, intent(in), optional :: n_filter - type(resonance_history_t), dimension(:), allocatable, intent(out) :: res_hists - type(kingraph_t), pointer :: kingraph - type(grove_t), pointer :: grove - type(resonance_history_t) :: res_hist - type(resonance_history_set_t) :: res_hist_set - integer :: i_grove - if (debug_on) call msg_debug (D_PHASESPACE, "grove_list_get_resonance_histories") - call res_hist_set%init (n_filter = n_filter) - grove => feyngraph_set%grove_list%first - i_grove = 0 - do while (associated (grove)) - i_grove = i_grove + 1 - kingraph => grove%first - do while (associated (kingraph)) - if (kingraph%keep) then - if (debug_on) call msg_debug2 (D_PHASESPACE, "grove", i_grove) - call kingraph%extract_resonance_history & - (res_hist, feyngraph_set%model, feyngraph_set%n_out) - call res_hist_set%enter (res_hist) +@ +@ Configure channel mappings, using some conditions +from the phase space configuration. If there are no structure +functions, we enable a default setup with a single (dummy) +structure-function channel. Otherwise, we look at the channel +collection that we got from the phase-space configuration step. Each +entry should be translated into an independent structure-function +channel, where typically there is one default entry, which could be +mapped using a standard s-channel mapping if the structure function +setup recommends this, and other entries with s-channel resonances. +The latter need to be translated into global mappings from the +structure-function chain. +<>= + public :: dispatch_sf_channels +<>= + module subroutine dispatch_sf_channels (sf_channel, sf_string, sf_prop, & + coll, var_list, sqrts, beam_structure) + type(sf_channel_t), dimension(:), allocatable, intent(out) :: sf_channel + type(string_t), intent(out) :: sf_string + type(sf_prop_t), intent(in) :: sf_prop + type(phs_channel_collection_t), intent(in) :: coll + type(var_list_t), intent(in) :: var_list + real(default), intent(in) :: sqrts + type(beam_structure_t), intent(in) :: beam_structure + end subroutine dispatch_sf_channels +<>= + module subroutine dispatch_sf_channels (sf_channel, sf_string, sf_prop, & + coll, var_list, sqrts, beam_structure) + type(sf_channel_t), dimension(:), allocatable, intent(out) :: sf_channel + type(string_t), intent(out) :: sf_string + type(sf_prop_t), intent(in) :: sf_prop + type(phs_channel_collection_t), intent(in) :: coll + type(var_list_t), intent(in) :: var_list + real(default), intent(in) :: sqrts + type(beam_structure_t), intent(in) :: beam_structure + type(beam_structure_t) :: beam_structure_tmp + class(channel_prop_t), allocatable :: prop + integer :: n_strfun, n_sf_channel, i + logical :: sf_allow_s_mapping, circe1_map, circe1_generate + logical :: s_mapping_enable, endpoint_mapping, power_mapping + logical :: single_parameter + integer, dimension(:), allocatable :: s_mapping, single_mapping + real(default) :: s_mapping_power + real(default) :: circe1_mapping_slope, endpoint_mapping_slope + real(default) :: power_mapping_eps + beam_structure_tmp = beam_structure + call beam_structure_tmp%expand (strfun_mode) + n_strfun = beam_structure_tmp%get_n_record () + sf_string = beam_structure_tmp%to_string (sf_only = .true.) + sf_allow_s_mapping = & + var_list%get_lval (var_str ("?sf_allow_s_mapping")) + circe1_generate = & + var_list%get_lval (var_str ("?circe1_generate")) + circe1_map = & + var_list%get_lval (var_str ("?circe1_map")) + circe1_mapping_slope = & + var_list%get_rval (var_str ("circe1_mapping_slope")) + s_mapping_enable = .false. + s_mapping_power = 1 + endpoint_mapping = .false. + endpoint_mapping_slope = 1 + power_mapping = .false. + single_parameter = .false. + select case (char (sf_string)) + case ("", "[any particles]") + case ("pdf_builtin, none", & + "pdf_builtin_photon, none", & + "none, pdf_builtin", & + "none, pdf_builtin_photon", & + "lhapdf, none", & + "lhapdf_photon, none", & + "none, lhapdf", & + "none, lhapdf_photon") + single_parameter = .true. + case ("pdf_builtin, none => none, pdf_builtin", & + "pdf_builtin, none => none, pdf_builtin_photon", & + "pdf_builtin_photon, none => none, pdf_builtin", & + "pdf_builtin_photon, none => none, pdf_builtin_photon", & + "lhapdf, none => none, lhapdf", & + "lhapdf, none => none, lhapdf_photon", & + "lhapdf_photon, none => none, lhapdf", & + "lhapdf_photon, none => none, lhapdf_photon") + allocate (s_mapping (2), source = [1, 2]) + s_mapping_enable = .true. + s_mapping_power = 2 + case ("pdf_builtin, none => none, pdf_builtin => epa, none => none, epa", & + "pdf_builtin, none => none, pdf_builtin => ewa, none => none, ewa", & + "pdf_builtin, none => none, pdf_builtin => ewa, none => none, epa", & + "pdf_builtin, none => none, pdf_builtin => epa, none => none, ewa") + allocate (s_mapping (2), source = [1, 2]) + s_mapping_enable = .true. + s_mapping_power = 2 + case ("isr, none", & + "none, isr") + allocate (single_mapping (1), source = [1]) + single_parameter = .true. + case ("isr, none => none, isr") + allocate (s_mapping (2), source = [1, 2]) + power_mapping = .true. + power_mapping_eps = minval (sf_prop%isr_eps) + case ("isr, none => none, isr => epa, none => none, epa", & + "isr, none => none, isr => ewa, none => none, ewa", & + "isr, none => none, isr => ewa, none => none, epa", & + "isr, none => none, isr => epa, none => none, ewa") + allocate (s_mapping (2), source = [1, 2]) + power_mapping = .true. + power_mapping_eps = minval (sf_prop%isr_eps) + case ("circe1 => isr, none => none, isr => epa, none => none, epa", & + "circe1 => isr, none => none, isr => ewa, none => none, ewa", & + "circe1 => isr, none => none, isr => ewa, none => none, epa", & + "circe1 => isr, none => none, isr => epa, none => none, ewa") + if (circe1_generate) then + allocate (s_mapping (2), source = [2, 3]) + else + allocate (s_mapping (3), source = [1, 2, 3]) + endpoint_mapping = .true. + endpoint_mapping_slope = circe1_mapping_slope + end if + power_mapping = .true. + power_mapping_eps = minval (sf_prop%isr_eps) + case ("pdf_builtin, none => none, isr", & + "pdf_builtin_photon, none => none, isr", & + "lhapdf, none => none, isr", & + "lhapdf_photon, none => none, isr") + allocate (single_mapping (1), source = [2]) + case ("isr, none => none, pdf_builtin", & + "isr, none => none, pdf_builtin_photon", & + "isr, none => none, lhapdf", & + "isr, none => none, lhapdf_photon") + allocate (single_mapping (1), source = [1]) + case ("epa, none", & + "none, epa") + allocate (single_mapping (1), source = [1]) + single_parameter = .true. + case ("epa, none => none, epa") + allocate (single_mapping (2), source = [1, 2]) + case ("epa, none => none, isr", & + "isr, none => none, epa", & + "ewa, none => none, isr", & + "isr, none => none, ewa") + allocate (single_mapping (2), source = [1, 2]) + case ("pdf_builtin, none => none, epa", & + "pdf_builtin_photon, none => none, epa", & + "lhapdf, none => none, epa", & + "lhapdf_photon, none => none, epa") + allocate (single_mapping (1), source = [2]) + case ("pdf_builtin, none => none, ewa", & + "pdf_builtin_photon, none => none, ewa", & + "lhapdf, none => none, ewa", & + "lhapdf_photon, none => none, ewa") + allocate (single_mapping (1), source = [2]) + case ("epa, none => none, pdf_builtin", & + "epa, none => none, pdf_builtin_photon", & + "epa, none => none, lhapdf", & + "epa, none => none, lhapdf_photon") + allocate (single_mapping (1), source = [1]) + case ("ewa, none => none, pdf_builtin", & + "ewa, none => none, pdf_builtin_photon", & + "ewa, none => none, lhapdf", & + "ewa, none => none, lhapdf_photon") + allocate (single_mapping (1), source = [1]) + case ("ewa, none", & + "none, ewa") + allocate (single_mapping (1), source = [1]) + single_parameter = .true. + case ("ewa, none => none, ewa") + allocate (single_mapping (2), source = [1, 2]) + case ("energy_scan, none => none, energy_scan") + allocate (s_mapping (2), source = [1, 2]) + case ("sf_test_1, none => none, sf_test_1") + allocate (s_mapping (2), source = [1, 2]) + case ("circe1") + if (circe1_generate) then + !!! no mapping + else if (circe1_map) then + allocate (s_mapping (1), source = [1]) + endpoint_mapping = .true. + endpoint_mapping_slope = circe1_mapping_slope + else + allocate (s_mapping (1), source = [1]) + s_mapping_enable = .true. + end if + case ("circe1 => isr, none => none, isr") + if (circe1_generate) then + allocate (s_mapping (2), source = [2, 3]) + else + allocate (s_mapping (3), source = [1, 2, 3]) + endpoint_mapping = .true. + endpoint_mapping_slope = circe1_mapping_slope + end if + power_mapping = .true. + power_mapping_eps = minval (sf_prop%isr_eps) + case ("circe1 => isr, none", & + "circe1 => none, isr") + allocate (single_mapping (1), source = [2]) + case ("circe1 => epa, none => none, epa") + if (circe1_generate) then + allocate (single_mapping (2), source = [2, 3]) + else + call msg_fatal ("CIRCE/EPA: supported with ?circe1_generate=true & + &only") + end if + case ("circe1 => ewa, none => none, ewa") + if (circe1_generate) then + allocate (single_mapping (2), source = [2, 3]) + else + call msg_fatal ("CIRCE/EWA: supported with ?circe1_generate=true & + &only") + end if + case ("circe1 => epa, none", & + "circe1 => none, epa") + if (circe1_generate) then + allocate (single_mapping (1), source = [2]) + else + call msg_fatal ("CIRCE/EPA: supported with ?circe1_generate=true & + &only") + end if + case ("circe1 => epa, none => none, isr", & + "circe1 => isr, none => none, epa", & + "circe1 => ewa, none => none, isr", & + "circe1 => isr, none => none, ewa") + if (circe1_generate) then + allocate (single_mapping (2), source = [2, 3]) + else + call msg_fatal ("CIRCE/EPA: supported with ?circe1_generate=true & + &only") + end if + case ("circe2", & + "gaussian", & + "beam_events") + !!! no mapping + case ("circe2 => isr, none => none, isr", & + "gaussian => isr, none => none, isr", & + "beam_events => isr, none => none, isr") + allocate (s_mapping (2), source = [2, 3]) + power_mapping = .true. + power_mapping_eps = minval (sf_prop%isr_eps) + case ("circe2 => isr, none", & + "circe2 => none, isr", & + "gaussian => isr, none", & + "gaussian => none, isr", & + "beam_events => isr, none", & + "beam_events => none, isr") + allocate (single_mapping (1), source = [2]) + case ("circe2 => epa, none => none, epa", & + "gaussian => epa, none => none, epa", & + "beam_events => epa, none => none, epa") + allocate (single_mapping (2), source = [2, 3]) + case ("circe2 => epa, none", & + "circe2 => none, epa", & + "circe2 => ewa, none", & + "circe2 => none, ewa", & + "gaussian => epa, none", & + "gaussian => none, epa", & + "gaussian => ewa, none", & + "gaussian => none, ewa", & + "beam_events => epa, none", & + "beam_events => none, epa", & + "beam_events => ewa, none", & + "beam_events => none, ewa") + allocate (single_mapping (1), source = [2]) + case ("circe2 => epa, none => none, isr", & + "circe2 => isr, none => none, epa", & + "circe2 => ewa, none => none, isr", & + "circe2 => isr, none => none, ewa", & + "gaussian => epa, none => none, isr", & + "gaussian => isr, none => none, epa", & + "gaussian => ewa, none => none, isr", & + "gaussian => isr, none => none, ewa", & + "beam_events => epa, none => none, isr", & + "beam_events => isr, none => none, epa", & + "beam_events => ewa, none => none, isr", & + "beam_events => isr, none => none, ewa") + allocate (single_mapping (2), source = [2, 3]) + case ("energy_scan") + case default + call msg_fatal ("Beam structure: " & + // char (sf_string) // " not supported") + end select + if (sf_allow_s_mapping .and. coll%n > 0) then + n_sf_channel = coll%n + allocate (sf_channel (n_sf_channel)) + do i = 1, n_sf_channel + call sf_channel(i)%init (n_strfun) + if (allocated (single_mapping)) then + call sf_channel(i)%activate_mapping (single_mapping) + end if + if (allocated (prop)) deallocate (prop) + call coll%get_entry (i, prop) + if (allocated (prop)) then + if (endpoint_mapping .and. power_mapping) then + select type (prop) + type is (resonance_t) + call sf_channel(i)%set_eir_mapping (s_mapping, & + a = endpoint_mapping_slope, eps = power_mapping_eps, & + m = prop%mass / sqrts, w = prop%width / sqrts) + type is (on_shell_t) + call sf_channel(i)%set_eio_mapping (s_mapping, & + a = endpoint_mapping_slope, eps = power_mapping_eps, & + m = prop%mass / sqrts) + end select + else if (endpoint_mapping) then + select type (prop) + type is (resonance_t) + call sf_channel(i)%set_epr_mapping (s_mapping, & + a = endpoint_mapping_slope, & + m = prop%mass / sqrts, w = prop%width / sqrts) + type is (on_shell_t) + call sf_channel(i)%set_epo_mapping (s_mapping, & + a = endpoint_mapping_slope, & + m = prop%mass / sqrts) + end select + else if (power_mapping) then + select type (prop) + type is (resonance_t) + call sf_channel(i)%set_ipr_mapping (s_mapping, & + eps = power_mapping_eps, & + m = prop%mass / sqrts, w = prop%width / sqrts) + type is (on_shell_t) + call sf_channel(i)%set_ipo_mapping (s_mapping, & + eps = power_mapping_eps, & + m = prop%mass / sqrts) + end select + else if (allocated (s_mapping)) then + select type (prop) + type is (resonance_t) + call sf_channel(i)%set_res_mapping (s_mapping, & + m = prop%mass / sqrts, w = prop%width / sqrts, & + single = single_parameter) + type is (on_shell_t) + call sf_channel(i)%set_os_mapping (s_mapping, & + m = prop%mass / sqrts, & + single = single_parameter) + end select + else if (allocated (single_mapping)) then + select type (prop) + type is (resonance_t) + call sf_channel(i)%set_res_mapping (single_mapping, & + m = prop%mass / sqrts, w = prop%width / sqrts, & + single = single_parameter) + type is (on_shell_t) + call sf_channel(i)%set_os_mapping (single_mapping, & + m = prop%mass / sqrts, & + single = single_parameter) + end select + end if + else if (endpoint_mapping .and. power_mapping) then + call sf_channel(i)%set_ei_mapping (s_mapping, & + a = endpoint_mapping_slope, eps = power_mapping_eps) + else if (endpoint_mapping .and. .not. allocated (single_mapping)) then + call sf_channel(i)%set_ep_mapping (s_mapping, & + a = endpoint_mapping_slope) + else if (power_mapping .and. .not. allocated (single_mapping)) then + call sf_channel(i)%set_ip_mapping (s_mapping, & + eps = power_mapping_eps) + else if (s_mapping_enable .and. .not. allocated (single_mapping)) then + call sf_channel(i)%set_s_mapping (s_mapping, & + power = s_mapping_power) end if - kingraph => kingraph%grove_next end do - end do - call res_hist_set%freeze () - call res_hist_set%to_array (res_hists) - end subroutine feyngraph_set_get_resonance_histories + else if (sf_allow_s_mapping) then + allocate (sf_channel (1)) + call sf_channel(1)%init (n_strfun) + if (allocated (single_mapping)) then + call sf_channel(1)%activate_mapping (single_mapping) + else if (endpoint_mapping .and. power_mapping) then + call sf_channel(i)%set_ei_mapping (s_mapping, & + a = endpoint_mapping_slope, eps = power_mapping_eps) + else if (endpoint_mapping) then + call sf_channel(1)%set_ep_mapping (s_mapping, & + a = endpoint_mapping_slope) + else if (power_mapping) then + call sf_channel(1)%set_ip_mapping (s_mapping, & + eps = power_mapping_eps) + else if (s_mapping_enable) then + call sf_channel(1)%set_s_mapping (s_mapping, & + power = s_mapping_power) + end if + else + allocate (sf_channel (1)) + call sf_channel(1)%init (n_strfun) + if (allocated (single_mapping)) then + call sf_channel(1)%activate_mapping (single_mapping) + end if + end if + end subroutine dispatch_sf_channels -@ %def feyngraph_set_get_resonance_histories -<<[[cascades2_ut.f90]]>>= +@ %def dispatch_sf_channels +@ +@ +\subsection{Unit tests} +Test module, followed by the corresponding implementation module. +<<[[dispatch_phs_ut.f90]]>>= <> -module cascades2_ut +module dispatch_phs_ut use unit_tests - use cascades2_uti + use dispatch_phs_uti <> -<> +<> contains -<> +<> -end module cascades2_ut -@ %def cascades2_ut +end module dispatch_phs_ut +@ %def dispatch_phs_ut @ -<<[[cascades2_uti.f90]]>>= +<<[[dispatch_phs_uti.f90]]>>= <> -module cascades2_uti +module dispatch_phs_uti <> <> - use numeric_utils - - use cascades2 - use flavors - use phs_forests, only: phs_parameters_t + use variables + use io_units, only: free_unit + use os_interface, only: os_data_t + use process_constants use model_data + use models + use phs_base + use phs_none + use phs_forests + use phs_wood + use mappings + use dispatch_phase_space <> -<> +<> contains -<> +<> -end module cascades2_uti -@ %def cascades2_uti +end module dispatch_phs_uti +@ %def dispatch_phs_ut @ API: driver for the unit tests below. -<>= - public :: cascades2_test -<>= - subroutine cascades2_test (u, results) +<>= + public ::dispatch_phs_test +<>= + subroutine dispatch_phs_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results - <> - end subroutine cascades2_test - -@ %def cascades2_test + <> + end subroutine dispatch_phs_test +@ %def dispatch_phs_test @ -<>= - call test (cascades2_1, "cascades2_1", & - "make phase-space", u, results) - call test (cascades2_2, "cascades2_2", & - "make phase-space (scattering)", u, results) -<>= - public :: cascades2_1 -<>= - subroutine cascades2_1 (u) +\subsubsection{Select type: phase-space configuration object} +<>= + call test (dispatch_phs_1, "dispatch_phs_1", & + "phase-space configuration", & + u, results) +<>= + public :: dispatch_phs_1 +<>= + subroutine dispatch_phs_1 (u) integer, intent(in) :: u - type (feyngraph_set_t) :: feyngraph_set - type (model_data_t) :: model - integer :: n_in = 1 - integer :: n_out = 6 - type(flavor_t), dimension(7,1) :: flv - type (phs_parameters_t) :: phs_par - logical :: fatal_beam_decay = .true. - integer :: u_in = 8 + type(var_list_t) :: var_list + class(phs_config_t), allocatable :: phs + type(phs_parameters_t) :: phs_par + type(os_data_t) :: os_data + type(mapping_defaults_t) :: mapping_defs - write (u, "(A)") "* Test output: cascades2_1" - write (u, "(A)") "* Purpose: create a test phs file (decay) with the forest" - write (u, "(A)") "* output of O'Mega" + write (u, "(A)") "* Test output: dispatch_phs_1" + write (u, "(A)") "* Purpose: select phase-space configuration method" write (u, "(A)") - write (u, "(A)") "* Initializing" + call var_list%init_defaults (0) + + write (u, "(A)") "* Allocate PHS as phs_none_t" write (u, "(A)") - call init_sm_full_test (model) + call var_list%set_string (& + var_str ("$phs_method"), & + var_str ("none"), is_known = .true.) + call dispatch_phs (phs, var_list, os_data, var_str ("dispatch_phs_1")) + call phs%write (u) - call flv(1,1)%init (6, model) - call flv(2,1)%init (5, model) - call flv(3,1)%init (-11, model) - call flv(4,1)%init (12, model) - call flv(5,1)%init (21, model) - call flv(6,1)%init (22, model) - call flv(7,1)%init (21, model) + call phs%final () + deallocate (phs) - phs_par%sqrts = 173.1_default - phs_par%m_threshold_s = 50._default - phs_par%m_threshold_t = 100._default - phs_par%keep_nonresonant = .true. - phs_par%off_shell = 2 + write (u, "(A)") + write (u, "(A)") "* Allocate PHS as phs_single_t" + write (u, "(A)") - open (unit=u_in, file="cascades2_1.fds", status='old', action='read') + call var_list%set_string (& + var_str ("$phs_method"), & + var_str ("single"), is_known = .true.) + call dispatch_phs (phs, var_list, os_data, var_str ("dispatch_phs_1")) + call phs%write (u) + + call phs%final () + deallocate (phs) write (u, "(A)") - write (u, "(A)") "* Generating phase-space parametrizations" + write (u, "(A)") "* Allocate PHS as phs_wood_t" write (u, "(A)") - call feyngraph_set_generate (feyngraph_set, model, n_in, n_out, & - flv, phs_par, fatal_beam_decay, u_in, use_dag = .false., & - vis_channels = .false.) - call feyngraph_set_write_process_bincode_format (feyngraph_set, u) - call feyngraph_set_write_file_format (feyngraph_set, u) + call var_list%set_string (& + var_str ("$phs_method"), & + var_str ("wood"), is_known = .true.) + call dispatch_phs (phs, var_list, os_data, var_str ("dispatch_phs_1")) + call phs%write (u) - write (u, "(A)") "* Cleanup" + call phs%final () + deallocate (phs) + + write (u, "(A)") + write (u, "(A)") "* Setting parameters for phs_wood_t" write (u, "(A)") - close (u_in) - call feyngraph_set%final () - call model%final () + phs_par%m_threshold_s = 123 + phs_par%m_threshold_t = 456 + phs_par%t_channel = 42 + phs_par%off_shell = 17 + phs_par%keep_nonresonant = .false. + mapping_defs%energy_scale = 987 + mapping_defs%invariant_mass_scale = 654 + mapping_defs%momentum_transfer_scale = 321 + mapping_defs%step_mapping = .false. + mapping_defs%step_mapping_exp = .false. + mapping_defs%enable_s_mapping = .true. + call dispatch_phs (phs, var_list, os_data, var_str ("dispatch_phs_1"), & + mapping_defs, phs_par) + call phs%write (u) - write (u, *) - write (u, "(A)") "* Test output end: cascades2_1" - end subroutine cascades2_1 + call phs%final () -@ %def cascades2_1 + call var_list%final () + + write (u, "(A)") + write (u, "(A)") "* Test output end: dispatch_phs_1" + + end subroutine dispatch_phs_1 + +@ %def dispatch_phs_1 @ -<>= - public :: cascades2_2 -<>= - subroutine cascades2_2 (u) +\subsubsection{Phase-space configuration with file} +<>= + call test (dispatch_phs_2, "dispatch_phs_2", & + "configure phase space using file", & + u, results) +<>= + public :: dispatch_phs_2 +<>= + subroutine dispatch_phs_2 (u) + use phs_base_ut, only: init_test_process_data + use phs_wood_ut, only: write_test_phs_file + use phs_forests integer, intent(in) :: u - type (feyngraph_set_t) :: feyngraph_set - type (model_data_t) :: model - integer :: n_in = 2 - integer :: n_out = 5 - type(flavor_t), dimension(7,1) :: flv - type (phs_parameters_t) :: phs_par - logical :: fatal_beam_decay = .true. - integer :: u_in = 8 + type(var_list_t) :: var_list + type(os_data_t) :: os_data + type(process_constants_t) :: process_data + type(model_list_t) :: model_list + type(model_t), pointer :: model + class(phs_config_t), allocatable :: phs + integer :: u_phs - write (u, "(A)") "* Test output: cascades2_2" - write (u, "(A)") "* Purpose: create a test phs file (scattering) with the" - write (u, "(A)") "* parsable DAG output of O'Mega" + write (u, "(A)") "* Test output: dispatch_phs_2" + write (u, "(A)") "* Purpose: select 'wood' phase-space & + &for a test process" + write (u, "(A)") "* and read phs configuration from file" write (u, "(A)") - write (u, "(A)") "* Initializing" + write (u, "(A)") "* Initialize a process" write (u, "(A)") - call init_sm_full_test (model) + call var_list%init_defaults (0) + call os_data%init () + call syntax_model_file_init () + call model_list%read_model & + (var_str ("Test"), var_str ("Test.mdl"), os_data, model) - call flv(1,1)%init (-11, model) - call flv(2,1)%init (11, model) - call flv(3,1)%init (-11, model) - call flv(4,1)%init (12, model) - call flv(5,1)%init (1, model) - call flv(6,1)%init (-2, model) - call flv(7,1)%init (22, model) + call syntax_phs_forest_init () - phs_par%sqrts = 500._default - phs_par%m_threshold_s = 50._default - phs_par%m_threshold_t = 100._default - phs_par%keep_nonresonant = .true. - phs_par%off_shell = 2 - phs_par%t_channel = 6 + call init_test_process_data (var_str ("dispatch_phs_2"), process_data) - open (unit=u_in, file="cascades2_2.fds", & - status='old', action='read') + write (u, "(A)") "* Write phase-space file" + + u_phs = free_unit () + open (u_phs, file = "dispatch_phs_2.phs", action = "write", status = "replace") + call write_test_phs_file (u_phs, var_str ("dispatch_phs_2")) + close (u_phs) write (u, "(A)") - write (u, "(A)") "* Generating phase-space parametrizations" + write (u, "(A)") "* Allocate PHS as phs_wood_t" write (u, "(A)") - call feyngraph_set_generate (feyngraph_set, model, n_in, n_out, & - flv, phs_par, fatal_beam_decay, u_in, use_dag = .true., & - vis_channels = .false.) - call feyngraph_set_write_process_bincode_format (feyngraph_set, u) - call feyngraph_set_write_file_format (feyngraph_set, u) + call var_list%set_string (& + var_str ("$phs_method"), & + var_str ("wood"), is_known = .true.) + call var_list%set_string (& + var_str ("$phs_file"), & + var_str ("dispatch_phs_2.phs"), is_known = .true.) + call dispatch_phs (phs, var_list, os_data, var_str ("dispatch_phs_2")) - write (u, "(A)") "* Cleanup" + call phs%init (process_data, model) + call phs%configure (sqrts = 1000._default) + + call phs%write (u) write (u, "(A)") + select type (phs) + type is (phs_wood_config_t) + call phs%write_forest (u) + end select - close (u_in) - call feyngraph_set%final () - call model%final () + call phs%final () - write (u, *) - write (u, "(A)") "* Test output end: cascades2_2" - end subroutine cascades2_2 + call var_list%final () + call syntax_model_file_final () -@ %def cascades2_2 + write (u, "(A)") + write (u, "(A)") "* Test output end: dispatch_phs_2" + + end subroutine dispatch_phs_2 + +@ %def dispatch_phs_2 +@ Index: trunk/src/recola/recola.nw =================================================================== --- trunk/src/recola/recola.nw (revision 8793) +++ trunk/src/recola/recola.nw (revision 8794) @@ -1,3481 +1,3481 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: interface to Recola 1-loop library @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Recola Interface} \section{Recola wrapper} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% <<[[recola_wrapper.f90]]>>= <> module recola_wrapper use recola !NODEP! use kinds <> <> use constants, only: zero use diagnostics, only: msg_fatal, msg_message, msg_debug, msg_debug2, D_ME_METHODS use io_units, only: given_output_unit <> <> <> <> <> contains <> end module recola_wrapper @ %def recola_wrapper @ <>= public :: rclwrap_is_active <>= logical, parameter :: rclwrap_is_active = .true. @ %def rclwrap_is_active @ Returns the particle string corresponding to a pdg code used in the Recola process definition <>= public :: get_recola_particle_string <>= elemental function get_recola_particle_string (pdg) result (name) type(string_t) :: name integer, intent(in) :: pdg select case (pdg) case (1) name = var_str ("d") case (-1) name = var_str ("d~") case (2) name = var_str ("u") case (-2) name = var_str ("u~") case (3) name = var_str ("s") case (-3) name = var_str ("s~") case (4) name = var_str ("c") case (-4) name = var_str ("c~") case (5) name = var_str ("b") case (-5) name = var_str ("b~") case (6) name = var_str ("t") case (-6) name = var_str ("t~") case (11) name = var_str ("e-") case (-11) name = var_str ("e+") case (12) name = var_str ("nu_e") case (-12) name = var_str ("nu_e~") case (13) name = var_str ("mu-") case (-13) name = var_str ("mu+") case (14) name = var_str ("nu_mu") case (-14) name = var_str ("nu_mu~") case (15) name = var_str ("tau-") case (-15) name = var_str ("tau+") case (16) name = var_str ("nu_tau") case (-16) name = var_str ("nu_tau~") case (21) name = var_str ("g") case (22) name = var_str ("A") case (23) name = var_str ("Z") case (24) name = var_str ("W+") case (-24) name = var_str ("W-") case (25) name = var_str ("H") end select end function get_recola_particle_string @ %def get_recola_particle_string @ <>= subroutine rclwrap_define_process (id, process_string, order) integer, intent(in) :: id type(string_t), intent(in) :: process_string type(string_t), intent(in) :: order if (debug_on) call msg_debug2 (D_ME_METHODS, "define_process_rcl") call define_process_rcl (id, char (process_string), char (order)) end subroutine rclwrap_define_process @ %def rclwrap_define_process @ This defines a wrapper for the information required to define a RECOLA process. It is used to collect the process definitions in an array. <>= type :: rcl_process_t private integer :: id type(string_t) :: process_string type(string_t) :: order contains <> end type rcl_process_t @ %def rcl_process_t @ <>= interface rcl_process_t module procedure new_rcl_process_t end interface @ %def rcl_process_t @ <>= function new_rcl_process_t (id, process_string, order) integer, intent(in) :: id type(string_t), intent(in) :: process_string, order type(rcl_process_t) :: new_rcl_process_t new_rcl_process_t%id = id new_rcl_process_t%process_string = process_string new_rcl_process_t%order = order end function new_rcl_process_t @ %def new_rcl_process_t <>= procedure :: get_params => rcl_process_get_params <>= subroutine rcl_process_get_params (prc, id, process_string, order) class(rcl_process_t), intent(in) :: prc integer, intent(out) :: id type(string_t), intent(out) :: process_string type(string_t), intent(out) :: order id = prc%id process_string = prc%process_string order = prc%order end subroutine rcl_process_get_params @ %def rcl_process_get_params @ Output. <>= procedure :: write => rcl_process_write <>= subroutine rcl_process_write (object, unit) class(rcl_process_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A,I0,2(1x,A,1x))") "RECOLA process:", & "id=", object%id, "process_string=", char(object%process_string), & "order=", char(object%order) end subroutine rcl_process_write @ %def rcl_process_write @ This defines a singleton object, located in this module only, that controls RECOLA initialization and process management. When WHIZARD compiles processes, it should also run the RECOLA "`controller"', which actually initializes RECOLA for integration and manages process information in an array. The main complication is that this has to be done after all processes have been registered, and cannot be redone. We could work with module variables directly, but the singleton pattern, e.g., allows us to work with multiple RECOLA instances, if this becomes possible in the future. Type and object can be private. <>= type :: rcl_controller_t private logical :: active = .false. logical :: defined = .false. logical :: done = .false. integer :: recola_id = 0 type(rcl_process_t), dimension (:), allocatable :: processes integer :: n_processes = 0 contains <> end type rcl_controller_t @ %def rcl_controller_t <>= type(rcl_controller_t), target, save :: rcl_controller @ %def rcl_controller @ Add a RECOLA process to the controller. This will make sure that processes can be redefined if additional definitions are to be made after process generation. <>= procedure :: add_process => rcl_controller_add_process <>= subroutine rcl_controller_add_process (rcl, process) class(rcl_controller_t), intent(inout) :: rcl type(rcl_process_t), intent(in) :: process type(rcl_process_t), dimension (:), allocatable :: temp if (rcl%n_processes == size(rcl%processes)) then allocate( temp(2 * rcl%n_processes) ) temp(:rcl%n_processes) = rcl%processes call move_alloc(temp, rcl%processes) end if rcl%processes(rcl%n_processes + 1) = process rcl%n_processes = rcl%n_processes + 1 end subroutine rcl_controller_add_process @ %def rcl_controller_add_process @ Define all processes added to the controller, and only them. If processes have been defined before, RECOLA is reset. <>= procedure :: define_processes => rcl_controller_define_processes <>= subroutine rcl_controller_define_processes (rcl) class(rcl_controller_t), intent(inout) :: rcl integer :: id, i type(string_t) :: process_string type(string_t) :: order if (rcl%defined) then if (.not. rcl%done) call rclwrap_generate_processes () if (debug_on) call msg_debug2 (D_ME_METHODS, "reset_recola_rcl") call reset_recola_rcl () end if do i = 1, rcl%n_processes call rcl%processes(i)%get_params(id, process_string, order) call rclwrap_define_process (id, process_string, order) end do rcl%defined = .true. rcl%done = .false. end subroutine rcl_controller_define_processes @ %def rcl_controller_define_processes @ Revert to initial state. Also, reset RECOLA (only if it has already done something). <>= procedure :: reset => rcl_controller_reset <>= subroutine rcl_controller_reset (rcl) class(rcl_controller_t), intent(inout) :: rcl if (rcl%active .or. rcl%done) then if (debug_on) call msg_debug2 (D_ME_METHODS, "reset_recola_rcl") if (allocated (rcl%processes)) deallocate (rcl%processes) call reset_recola_rcl () end if rcl%active = .false. rcl%defined = .false. rcl%done = .false. rcl%recola_id = 0 rcl%n_processes = 0 end subroutine rcl_controller_reset @ %def rcl_controller_reset @ Output. <>= procedure :: write => rcl_controller_write <>= subroutine rcl_controller_write (object, unit) class(rcl_controller_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A,2(1x,A,L1),2(1x,A,I0))") "RECOLA controller:", & "active=", object%active, "done=", object%done, & "id=", object%recola_id, "n_processes=", object%n_processes end subroutine rcl_controller_write @ %def rcl_controller_write @ Return a new numeric process ID, incrementing the counter once. <>= procedure :: get_new_id => rcl_controller_get_new_id <>= subroutine rcl_controller_get_new_id (object, id) class(rcl_controller_t), intent(inout) :: object integer, intent(out) :: id object%recola_id = object%recola_id + 1 id = object%recola_id end subroutine rcl_controller_get_new_id @ %def rcl_controller_get_new_id @ Return the current numeric process ID without incrementing the counter. <>= procedure :: get_current_id => rcl_controller_get_current_id <>= subroutine rcl_controller_get_current_id (object, id) class(rcl_controller_t), intent(inout) :: object integer, intent(out) :: id id = object%recola_id end subroutine rcl_controller_get_current_id @ %def rcl_controller_get_current_id @ Do not allow activation if processes have been calculated previously. Otherwise set the flag. <>= procedure :: activate => rcl_controller_activate <>= subroutine rcl_controller_activate (rcl) class(rcl_controller_t), intent(inout) :: rcl if ( .not. allocated(rcl%processes) ) allocate ( rcl%processes(10) ) rcl_controller%active = .true. end subroutine rcl_controller_activate @ %def rcl_controller_activate @ Start process initialization by calling the RECOLA API. Do not allow this twice (skip silently), and skip anyway if there is no activation. <>= procedure :: generate_processes => rcl_controller_generate_processes <>= subroutine rcl_controller_generate_processes (rcl) class(rcl_controller_t), intent(inout) :: rcl if (rcl_controller%active) then if (.not. rcl_controller%done) then call msg_message ("Recola: preparing processes for integration") call generate_processes_rcl () rcl_controller%done = .true. end if end if end subroutine rcl_controller_generate_processes @ %def rcl_controller_generate_processes @ Return a new numeric RECOLA process ID. The singleton nature of the controller guarantees that the ID is unique. <>= public :: rclwrap_get_new_recola_id <>= subroutine rclwrap_get_new_recola_id (id) integer, intent(out) :: id call rcl_controller%get_new_id (id) end subroutine rclwrap_get_new_recola_id @ %def rclwrap_get_new_recola_id @ Return the current numeric RECOLA process ID. This coincides with the amount of IDs currently in use. <>= public :: rclwrap_get_current_recola_id <>= function rclwrap_get_current_recola_id () result (n) integer :: n call rcl_controller%get_current_id (n) end function rclwrap_get_current_recola_id @ %def rclwrap_get_current_recola_id @ This procedure records the fact that there is a recola process pending, so we will have to call [[generate_processes]] before we can calculate anything with Recola. <>= public :: rclwrap_request_generate_processes <>= subroutine rclwrap_request_generate_processes () if (debug_on) call msg_debug2 (D_ME_METHODS, "request_generate_processes_rcl") call rcl_controller%activate () end subroutine rclwrap_request_generate_processes @ %def rclwrap_request_generate_processes @ Add a process to be defined later <>= public :: rclwrap_add_process <>= subroutine rclwrap_add_process (id, process_string, order) integer, intent(in) :: id type(string_t), intent(in) :: process_string, order type(rcl_process_t) :: prc if (debug_on) call msg_debug2 (D_ME_METHODS, "add_process_rcl: id", id) prc = rcl_process_t (id, process_string, order) call rcl_controller%add_process (prc) end subroutine rclwrap_add_process @ %def rclwrap_add_process @ Define all added processes. Reset if processes were already defined. <>= public :: rclwrap_define_processes <>= subroutine rclwrap_define_processes () if (debug_on) call msg_debug2 (D_ME_METHODS, "define_processes_rcl") call rcl_controller%define_processes () end subroutine rclwrap_define_processes @ %def rclwrap_define_processes @ We call this after all processes have been added and defined, so RECOLA can initialize itself for integration. <>= public :: rclwrap_generate_processes <>= subroutine rclwrap_generate_processes () if (debug_on) call msg_debug2 (D_ME_METHODS, "generate_processes_rcl") call rcl_controller%generate_processes () end subroutine rclwrap_generate_processes @ %def rclwrap_generate_processes @ <>= public :: rclwrap_compute_process <>= subroutine rclwrap_compute_process (id, p, order, sqme) integer, intent(in) :: id real(double), intent(in), dimension(:,:) :: p character(len=*), intent(in) :: order real(double), intent(out), dimension(0:1), optional :: sqme if (debug_on) call msg_debug2 (D_ME_METHODS, "compute_process_rcl") call compute_process_rcl (id, p, order, sqme) end subroutine rclwrap_compute_process @ %def rclwrap_compute_process @ <>= public :: rclwrap_get_amplitude <>= subroutine rclwrap_get_amplitude (id, g_power, order, col, hel, amp) integer, intent(in) :: id, g_power character(len=*), intent(in) :: order integer, dimension(:), intent(in) :: col, hel complex(double), intent(out) :: amp if (debug_on) call msg_debug2 (D_ME_METHODS, "get_amplitude_rcl") call get_amplitude_rcl (id, g_power, order, col, hel, amp) end subroutine rclwrap_get_amplitude @ %def rclwrap_get_amplitude @ <>= public :: rclwrap_get_squared_amplitude <>= subroutine rclwrap_get_squared_amplitude (id, alphas_power, order, sqme) integer, intent(in) :: id, alphas_power character(len=*), intent(in) :: order real(double), intent(out) :: sqme if (debug_on) call msg_debug2 (D_ME_METHODS, "get_squared_amplitude_rcl") call get_squared_amplitude_rcl (id, alphas_power, order, sqme) end subroutine rclwrap_get_squared_amplitude @ %def rclwrap_get_squared_amplitude @ <>= public :: rclwrap_set_pole_mass <>= subroutine rclwrap_set_pole_mass (pdg_id, mass, width) integer, intent(in) :: pdg_id real(double), intent(in) :: mass, width if (debug_on) call msg_debug2 (D_ME_METHODS, "rclwrap_set_pole_mass of ", pdg_id) select case (abs(pdg_id)) case (11) if (width > zero) & call msg_fatal ("Recola pole mass: Attempting to set non-zero electron width!") call set_pole_mass_electron_rcl (mass) case (13) call set_pole_mass_muon_rcl (mass, width) case (15) call set_pole_mass_tau_rcl (mass, width) case (1) if (width > zero) & call msg_fatal ("Recola pole mass: Attempting to set non-zero down-quark width!") call set_pole_mass_down_rcl (mass) case (2) if (width > zero) & call msg_fatal ("Recola pole mass: Attempting to set non-zero up-quark width!") call set_pole_mass_up_rcl (mass) case (3) if (width > zero) & call msg_fatal ("Recola pole mass: Attempting to set non-zero strange-quark width!") call set_pole_mass_strange_rcl (mass) case (4) call set_pole_mass_charm_rcl (mass, width) case (5) call set_pole_mass_bottom_rcl (mass, width) case (6) call set_pole_mass_top_rcl (mass, width) case (23) call set_pole_mass_z_rcl (mass, width) case (24) call set_pole_mass_w_rcl (mass, width) case (25) call set_pole_mass_h_rcl (mass, width) case default call msg_fatal ("Recola pole mass: Unsupported particle") end select end subroutine rclwrap_set_pole_mass @ %def rclwrap_set_pole_mass @ <>= public :: rclwrap_set_onshell_mass <>= subroutine rclwrap_set_onshell_mass (pdg_id, mass, width) integer, intent(in) :: pdg_id real(double), intent(in) :: mass, width if (debug_on) call msg_debug2 (D_ME_METHODS, "rclwrap_set_onshell_mass of ", pdg_id) select case (abs(pdg_id)) case (23) call set_onshell_mass_z_rcl (mass, width) case (24) call set_onshell_mass_w_rcl (mass, width) case default call msg_fatal ("Recola onshell mass: Only for W and Z") end select end subroutine rclwrap_set_onshell_mass @ %def rclwrap_set_onshell_mass @ <>= public :: rclwrap_use_gfermi_scheme <>= subroutine rclwrap_use_gfermi_scheme (gf) real(double), intent(in), optional :: gf if (debug_on) call msg_debug2 (D_ME_METHODS, "use_gfermi_scheme_rcl", & real(gf, kind=default)) call use_gfermi_scheme_rcl (gf) end subroutine rclwrap_use_gfermi_scheme @ %def rclwrap_use_gfermi_scheme @ <>= public :: rclwrap_set_light_fermions <>= subroutine rclwrap_set_light_fermions (m) real(double), intent(in) :: m if (debug_on) call msg_debug2 (D_ME_METHODS, "set_light_fermions_rcl", & real(m, kind=default)) call set_light_fermions_rcl (m) end subroutine rclwrap_set_light_fermions @ %def rclwrap_set_light_fermions @ <>= public :: rclwrap_set_light_fermion <>= subroutine rclwrap_set_light_fermion (pdg_id) integer, intent(in) :: pdg_id if (debug_on) call msg_debug2 (D_ME_METHODS, "rclwrap_set_light_fermion", pdg_id) select case (abs(pdg_id)) case (1) call set_light_down_rcl () case (2) call set_light_up_rcl () case (3) call set_light_strange_rcl () case (4) call set_light_charm_rcl () case (5) call set_light_bottom_rcl () case (6) call set_light_top_rcl () case (11) call set_light_electron_rcl () case (13) call set_light_muon_rcl () case (15) call set_light_tau_rcl () end select end subroutine rclwrap_set_light_fermion @ %def rclwrap_set_light_fermion @ <>= public :: rclwrap_unset_light_fermion <>= subroutine rclwrap_unset_light_fermion (pdg_id) integer, intent(in) :: pdg_id if (debug_on) call msg_debug2 (D_ME_METHODS, "rclwrap_unset_light_fermion", pdg_id) select case (abs(pdg_id)) case (1) call unset_light_down_rcl () case (2) call unset_light_up_rcl () case (3) call unset_light_strange_rcl () case (4) call unset_light_charm_rcl () case (5) call unset_light_bottom_rcl () case (6) call unset_light_top_rcl () case (11) call unset_light_electron_rcl () case (13) call unset_light_muon_rcl () case (15) call unset_light_tau_rcl () end select end subroutine rclwrap_unset_light_fermion @ %def rclwrap_unset_light_fermion @ <>= public :: rclwrap_set_onshell_scheme <>= subroutine rclwrap_set_onshell_scheme if (debug_on) call msg_debug2 (D_ME_METHODS, "set_on_shell_scheme_rcl") call set_on_shell_scheme_rcl () end subroutine rclwrap_set_onshell_scheme @ %def rclwrap_set_onshell_scheme @ <>= public :: rclwrap_set_alpha_s <>= subroutine rclwrap_set_alpha_s (alpha_s, mu, nf) real(double), intent(in) :: alpha_s, mu integer, intent(in) :: nf if (debug_on) call msg_debug2 (D_ME_METHODS, "set_alphas_rcl") call set_alphas_rcl (alpha_s, mu, nf) end subroutine rclwrap_set_alpha_s @ %def rclwrap_set_alpha_s @ <>= public :: rclwrap_get_alpha_s <>= function rclwrap_get_alpha_s () result (alpha_s) real(double) :: alpha_s if (debug_on) call msg_debug2 (D_ME_METHODS, "get_alphas_rcl") call get_alphas_rcl (alpha_s) end function rclwrap_get_alpha_s @ %def rclwrap_get_alpha_s @ <>= public :: rclwrap_get_helicity_configurations <>= subroutine rclwrap_get_helicity_configurations (id, hel) integer, intent(in) :: id integer, intent(inout), dimension(:,:), allocatable :: hel call get_helicity_configurations_rcl (id, hel) end subroutine rclwrap_get_helicity_configurations @ %def rclwrap_get_helicity_configurations @ <>= public :: rclwrap_get_color_configurations <>= subroutine rclwrap_get_color_configurations (id, col) integer, intent(in) :: id integer, intent(out), dimension(:,:), allocatable :: col call get_colour_configurations_rcl (id, col) end subroutine rclwrap_get_color_configurations @ %def rclwrap_get_color_configurations @ Selects dimensional regularization for soft singularities. <>= public :: rclwrap_use_dim_reg_soft <>= subroutine rclwrap_use_dim_reg_soft () if (debug_on) call msg_debug2 (D_ME_METHODS, "use_dim_reg_soft_rcl") call use_dim_reg_soft_rcl () end subroutine rclwrap_use_dim_reg_soft @ %def rclwrap_use_dim_reg_soft @ Selects mass regularization for soft singularities and sets the mass regulator in GeV to [[m]]. <>= public :: rclwrap_use_mass_reg_soft <>= subroutine rclwrap_use_mass_reg_soft (m) real(double), intent(in) :: m if (debug_on) call msg_debug2 (D_ME_METHODS, "use_mass_reg_soft_rcl") call use_mass_reg_soft_rcl (m) end subroutine rclwrap_use_mass_reg_soft @ %def rclwrap_use_mass_reg_soft @ Sets the UV pole parameterization $\Delta_{UV}$. <>= public :: rclwrap_set_delta_uv <>= subroutine rclwrap_set_delta_uv (d) real(double), intent(in) :: d if (debug_on) call msg_debug2 (D_ME_METHODS, "set_delta_uv_rcl") call set_delta_uv_rcl (d) end subroutine rclwrap_set_delta_uv @ %def rclwrap_set_delta_uv @ <>= public :: rclwrap_set_mu_uv <>= subroutine rclwrap_set_mu_uv (mu) real(double), intent(in) :: mu if (debug_on) call msg_debug2 (D_ME_METHODS, "set_mu_uv_rcl") call set_mu_uv_rcl (mu) end subroutine rclwrap_set_mu_uv @ %def rclwrap_set_mu_uv @ Sets the IR pole parameterizations $\Delta_{IR}$ and $\Delta_2$. <>= public :: rclwrap_set_delta_ir <>= subroutine rclwrap_set_delta_ir (d, d2) real(double), intent(in) :: d, d2 if (debug_on) call msg_debug2 (D_ME_METHODS, "set_delta_ir_rcl", & real(d, kind=default)) if (debug_on) call msg_debug2 (D_ME_METHODS, "set_delta_ir_rcl", & real(d2, kind=default)) call set_delta_ir_rcl (d, d2) end subroutine rclwrap_set_delta_ir @ %def rclwrap_set_delta_ir @ <>= public :: rclwrap_set_mu_ir <>= subroutine rclwrap_set_mu_ir (mu) real(double), intent(in) :: mu if (debug_on) call msg_debug2 (D_ME_METHODS, "set_mu_ir_rcl") call set_mu_ir_rcl (mu) end subroutine rclwrap_set_mu_ir @ %def rclwrap_set_mu_ir @ <>= public :: rclwrap_get_renormalization_scale <>= subroutine rclwrap_get_renormalization_scale (mu) real(double), intent(out) :: mu if (debug_on) call msg_debug2 (D_ME_METHODS, "get_renormalization_scale_rcl") call get_renormalization_scale_rcl (mu) end subroutine rclwrap_get_renormalization_scale @ %def rclwrap_get_renormalization_scale @ <>= public :: rclwrap_get_flavor_scheme <>= subroutine rclwrap_get_flavor_scheme (nf) integer, intent(out) :: nf if (debug_on) call msg_debug2 (D_ME_METHODS, "get_flavour_scheme_rcl") call get_flavour_scheme_rcl (nf) end subroutine rclwrap_get_flavor_scheme @ %def rclwrap_get_flavor_scheme @ <>= public :: rclwrap_use_alpha0_scheme <>= subroutine rclwrap_use_alpha0_scheme (al0) real(double), intent(in), optional :: al0 if (debug_on) call msg_debug2 (D_ME_METHODS, "use_alpha0_scheme_rcl") call use_alpha0_scheme_rcl (al0) end subroutine rclwrap_use_alpha0_scheme @ %def rclwrap_use_alpha0_scheme @ <>= public :: rclwrap_use_alphaz_scheme <>= subroutine rclwrap_use_alphaz_scheme (alz) real(double), intent(in), optional :: alz if (debug_on) call msg_debug2 (D_ME_METHODS, "use_alphaz_scheme_rcl") call use_alphaz_scheme_rcl (alz) end subroutine rclwrap_use_alphaz_scheme @ %def rclwrap_use_alphaz_scheme @ <>= public :: rclwrap_set_complex_mass_scheme <>= subroutine rclwrap_set_complex_mass_scheme () if (debug_on) call msg_debug2 (D_ME_METHODS, "set_complex_mass_scheme_rcl") call set_complex_mass_scheme_rcl () end subroutine rclwrap_set_complex_mass_scheme @ %def rclwrap_set_complex_mass_scheme @ <>= public :: rclwrap_set_resonant_particle <>= subroutine rclwrap_set_resonant_particle (pdg_id) integer, intent(in) :: pdg_id if (debug_on) call msg_debug2 (D_ME_METHODS, "set_resonant_particle_rcl") call set_resonant_particle_rcl (char(get_recola_particle_string (pdg_id))) end subroutine rclwrap_set_resonant_particle @ %def rclwrap_set_resonant_particle @ <>= public :: rclwrap_switch_on_resonant_self_energies <>= subroutine rclwrap_switch_on_resonant_self_energies () if (debug_on) call msg_debug2 (D_ME_METHODS, "switchon_resonant_selfenergies_rcl") call switchon_resonant_selfenergies_rcl () end subroutine rclwrap_switch_on_resonant_self_energies @ %def rclwrap_switch_on_resonant_self_energies @ <>= public :: rclwrap_switch_off_resonant_self_energies <>= subroutine rclwrap_switch_off_resonant_self_energies () if (debug_on) call msg_debug2 (D_ME_METHODS, "switchoff_resonant_selfenergies_rcl") call switchoff_resonant_selfenergies_rcl () end subroutine rclwrap_switch_off_resonant_self_energies @ %def rclwrap_switch_off_resonant_self_energies @ <>= public :: rclwrap_set_draw_level_branches <>= subroutine rclwrap_set_draw_level_branches (n) integer, intent(in) :: n if (debug_on) call msg_debug2 (D_ME_METHODS, "set_draw_level_branches_rcl") call set_draw_level_branches_rcl (n) end subroutine rclwrap_set_draw_level_branches @ %def rclwrap_set_draw_level_branches @ <>= public :: rclwrap_set_print_level_amplitude <>= subroutine rclwrap_set_print_level_amplitude (n) integer, intent(in) :: n if (debug_on) call msg_debug2 (D_ME_METHODS, "set_print_level_amplitude_rcl") call set_print_level_amplitude_rcl (n) end subroutine rclwrap_set_print_level_amplitude @ %def rclwrap_set_print_level_amplitude @ <>= public :: rclwrap_set_print_level_squared_amplitude <>= subroutine rclwrap_set_print_level_squared_amplitude (n) integer, intent(in) :: n if (debug_on) call msg_debug2 (D_ME_METHODS, "set_print_level_squared_amplitude_rcl") call set_print_level_squared_amplitude_rcl (n) end subroutine rclwrap_set_print_level_squared_amplitude @ %def rclwrap_set_print_level_squared_amplitude @ <>= public :: rclwrap_set_print_level_correlations <>= subroutine rclwrap_set_print_level_correlations (n) integer, intent(in) :: n if (debug_on) call msg_debug2 (D_ME_METHODS, "set_print_level_correlations_rcl") call set_print_level_correlations_rcl (n) end subroutine rclwrap_set_print_level_correlations @ %def rclwrap_set_print_level_correlations @ <>= public :: rclwrap_set_print_level_RAM <>= subroutine rclwrap_set_print_level_RAM (n) integer, intent(in) :: n if (debug_on) call msg_debug2 (D_ME_METHODS, "set_print_level_RAM_rcl") call set_print_level_RAM_rcl (n) end subroutine rclwrap_set_print_level_RAM @ %def rclwrap_set_print_level_RAM @ <>= public :: rclwrap_scale_coupling3 <>= subroutine rclwrap_scale_coupling3 (pdg_id1, pdg_id2, pdg_id3, factor) integer, intent(in) :: pdg_id1, pdg_id2, pdg_id3 complex(double), intent(in) :: factor if (debug_on) call msg_debug2 (D_ME_METHODS, "scale_coupling3_rcl") call scale_coupling3_rcl (factor, char(get_recola_particle_string (pdg_id1)), & char(get_recola_particle_string (pdg_id2)), char(get_recola_particle_string (pdg_id3))) end subroutine rclwrap_scale_coupling3 @ %def rclwrap_scale_coupling3 @ <>= public :: rclwrap_scale_coupling4 <>= subroutine rclwrap_scale_coupling4 (pdg_id1, pdg_id2, pdg_id3, pdg_id4, factor) integer, intent(in) :: pdg_id1, pdg_id2, pdg_id3, pdg_id4 complex(double), intent(in) :: factor if (debug_on) call msg_debug2 (D_ME_METHODS, "scale_coupling4_rcl") call scale_coupling4_rcl (factor, char(get_recola_particle_string (pdg_id1)), & char(get_recola_particle_string (pdg_id2)), char(get_recola_particle_string (pdg_id3)), & char(get_recola_particle_string (pdg_id4))) end subroutine rclwrap_scale_coupling4 @ %def rclwrap_scale_coupling4 @ <>= public :: rclwrap_switch_off_coupling3 <>= subroutine rclwrap_switch_off_coupling3 (pdg_id1, pdg_id2, pdg_id3) integer, intent(in) :: pdg_id1, pdg_id2, pdg_id3 if (debug_on) call msg_debug2 (D_ME_METHODS, "switchoff_coupling3_rcl") call switchoff_coupling3_rcl (char(get_recola_particle_string (pdg_id1)), & char(get_recola_particle_string (pdg_id2)), char(get_recola_particle_string (pdg_id3))) end subroutine rclwrap_switch_off_coupling3 @ %def rclwrap_switch_off_coupling3 @ <>= public :: rclwrap_switch_off_coupling4 <>= subroutine rclwrap_switch_off_coupling4 (pdg_id1, pdg_id2, pdg_id3, pdg_id4) integer, intent(in) :: pdg_id1, pdg_id2, pdg_id3, pdg_id4 if (debug_on) call msg_debug2 (D_ME_METHODS, "switchoff_coupling4_rcl") call switchoff_coupling4_rcl & (char(get_recola_particle_string (pdg_id1)), & char(get_recola_particle_string (pdg_id2)), & char(get_recola_particle_string (pdg_id3)), & char(get_recola_particle_string (pdg_id4))) end subroutine rclwrap_switch_off_coupling4 @ %def rclwrap_switch_off_coupling4 @ <>= public :: rclwrap_set_ifail <>= subroutine rclwrap_set_ifail (i) integer, intent(in) :: i if (debug_on) call msg_debug2 (D_ME_METHODS, "set_ifail_rcl") call set_ifail_rcl (i) end subroutine rclwrap_set_ifail @ %def rclwrap_set_ifail @ <>= public :: rclwrap_get_ifail <>= subroutine rclwrap_get_ifail (i) integer, intent(out) :: i if (debug_on) call msg_debug2 (D_ME_METHODS, "get_ifail_rcl") call get_ifail_rcl (i) end subroutine rclwrap_get_ifail @ %def rclwrap_get_ifail @ <>= public :: rclwrap_set_output_file <>= subroutine rclwrap_set_output_file (filename) character(len=*), intent(in) :: filename if (debug_on) call msg_debug2 (D_ME_METHODS, "set_output_file_rcl") call set_output_file_rcl (filename) end subroutine rclwrap_set_output_file @ %def rclwrap_set_output_file @ <>= public :: rclwrap_set_gs_power <>= subroutine rclwrap_set_gs_power (id, gs_array) integer, intent(in) :: id integer, dimension(:,:), intent(in) :: gs_array if (debug_on) call msg_debug2 (D_ME_METHODS, "set_gs_power_rcl") call set_gs_power_rcl (id, gs_array) end subroutine rclwrap_set_gs_power @ %def rclwrap_set_gs_power @ <>= public :: rclwrap_select_gs_power_born_amp <>= subroutine rclwrap_select_gs_power_born_amp (id, gs_power) integer, intent(in) :: id, gs_power if (debug_on) call msg_debug2 (D_ME_METHODS, "select_gs_power_BornAmpl_rcl") call select_gs_power_BornAmpl_rcl (id, gs_power) end subroutine rclwrap_select_gs_power_born_amp @ %def rclwrap_select_gs_power_born_amp @ <>= public :: rclwrap_unselect_gs_power_born_amp <>= subroutine rclwrap_unselect_gs_power_born_amp (id, gs_power) integer, intent(in) :: id, gs_power if (debug_on) call msg_debug2 (D_ME_METHODS, "unselect_gs_power_BornAmpl_rcl") call unselect_gs_power_BornAmpl_rcl (id, gs_power) end subroutine rclwrap_unselect_gs_power_born_amp @ %def rclwrap_unselect_gs_power_born_amp @ <>= public :: rclwrap_select_gs_power_loop_amp <>= subroutine rclwrap_select_gs_power_loop_amp (id, gs_power) integer, intent(in) :: id, gs_power if (debug_on) call msg_debug2 (D_ME_METHODS, "select_gs_power_LoopAmpl_rcl") call select_gs_power_LoopAmpl_rcl (id, gs_power) end subroutine rclwrap_select_gs_power_loop_amp @ %def rclwrap_select_gs_power_loop_amp @ <>= public :: rclwrap_unselect_gs_power_loop_amp <>= subroutine rclwrap_unselect_gs_power_loop_amp (id, gs_power) integer, intent(in) :: id, gs_power if (debug_on) call msg_debug2 (D_ME_METHODS, "unselect_gs_power_LoopAmpl_rcl") call unselect_gs_power_LoopAmpl_rcl (id, gs_power) end subroutine rclwrap_unselect_gs_power_loop_amp @ %def rclwrap_unselect_gs_power_loop_amp @ <>= public :: rclwrap_select_all_gs_powers_born_amp <>= subroutine rclwrap_select_all_gs_powers_born_amp (id) integer, intent(in) :: id if (debug_on) call msg_debug2 (D_ME_METHODS, "select_all_gs_powers_BornAmpl_rcl") call select_all_gs_powers_BornAmpl_rcl (id) end subroutine rclwrap_select_all_gs_powers_born_amp @ %def rclwrap_select_all_gs_powers_born_amp @ <>= public :: rclwrap_unselect_all_gs_powers_loop_amp <>= subroutine rclwrap_unselect_all_gs_powers_loop_amp (id) integer, intent(in) :: id if (debug_on) call msg_debug2 (D_ME_METHODS, "unselect_all_gs_powers_BornAmpl_rcl") call unselect_all_gs_powers_BornAmpl_rcl (id) end subroutine rclwrap_unselect_all_gs_powers_loop_amp @ %def rclwrap_unselect_all_gs_powers_loop_amp @ <>= public :: rclwrap_select_all_gs_powers_loop_amp <>= subroutine rclwrap_select_all_gs_powers_loop_amp (id) integer, intent(in) :: id if (debug_on) call msg_debug2 (D_ME_METHODS, "select_all_gs_powers_LoopAmpl_rcl") call select_all_gs_powers_LoopAmpl_rcl (id) end subroutine rclwrap_select_all_gs_powers_loop_amp @ %def rclwrap_select_all_gs_powers_loop_amp @ <>= public :: rclwrap_unselect_all_gs_powers_born_amp <>= subroutine rclwrap_unselect_all_gs_powers_born_amp (id) integer, intent(in) :: id if (debug_on) call msg_debug2 (D_ME_METHODS, "unselect_all_gs_powers_LoopAmpl_rcl") call unselect_all_gs_powers_LoopAmpl_rcl (id) end subroutine rclwrap_unselect_all_gs_powers_born_amp @ %def rclwrap_unselect_all_gs_powers_born_amp @ <>= public :: rclwrap_set_resonant_squared_momentum <>= subroutine rclwrap_set_resonant_squared_momentum (id, i_res, p2) integer, intent(in) :: id, i_res real(double), intent(in) :: p2 if (debug_on) call msg_debug2 (D_ME_METHODS, "set_resonant_squared_momentum_rcl") call set_resonant_squared_momentum_rcl (id, i_res, p2) end subroutine rclwrap_set_resonant_squared_momentum @ %def rclwrap_set_resonant_squared_momentum @ <>= public :: rclwrap_compute_running_alpha_s <>= subroutine rclwrap_compute_running_alpha_s (Q, nf, n_loops) real(double), intent(in) :: Q integer, intent(in) :: nf, n_loops if (debug_on) call msg_debug2 (D_ME_METHODS, "compute_running_alphas_rcl") call compute_running_alphas_rcl (Q, nf, n_loops) end subroutine rclwrap_compute_running_alpha_s @ %def rclwrap_compute_running_alpha_s @ <>= public :: rclwrap_set_dynamic_settings <>= subroutine rclwrap_set_dynamic_settings () if (debug_on) call msg_debug2 (D_ME_METHODS, "set_dynamic_settings_rcl") call set_dynamic_settings_rcl (1) end subroutine rclwrap_set_dynamic_settings @ %def rclwrap_set_dynamic_settings @ <>= public :: rclwrap_rescale_process <>= subroutine rclwrap_rescale_process (id, order, sqme) integer, intent(in) :: id character(len=*), intent(in) :: order real(double), dimension(0:1), intent(out), optional :: sqme if (debug_on) call msg_debug2 (D_ME_METHODS, "rescale_process_rcl") call rescale_process_rcl (id, order, sqme) end subroutine rclwrap_rescale_process @ %def rclwrap_rescale_process @ <>= public :: rclwrap_get_polarized_squared_amplitude <>= subroutine rclwrap_get_polarized_squared_amplitude (id, & alphas_power, order, hel, sqme) integer, intent(in) :: id, alphas_power character(len=*), intent(in) :: order integer, dimension(:), intent(in) :: hel real(double), intent(out) :: sqme if (debug_on) call msg_debug2 (D_ME_METHODS, "get_polarized_squared_amplitude_rcl") call get_polarized_squared_amplitude_rcl (id, alphas_power, & order, hel, sqme) end subroutine rclwrap_get_polarized_squared_amplitude @ %def rclwrap_get_polarized_squared_amplitude @ <>= public :: rclwrap_compute_color_correlation <>= subroutine rclwrap_compute_color_correlation (id, p, & i1, i2, sqme) integer, intent(in) :: id real(double), dimension(:,:), intent(in) :: p integer, intent(in) :: i1, i2 real(double), intent(out), optional :: sqme if (debug_on) call msg_debug2 (D_ME_METHODS, "compute_colour_correlation_rcl") call compute_colour_correlation_rcl (id, p, i1, i2, sqme) end subroutine rclwrap_compute_color_correlation @ %def rclwrap_compute_color_correlation @ <>= public :: rclwrap_compute_all_color_correlations <>= subroutine rclwrap_compute_all_color_correlations (id, p) integer, intent(in) :: id real(double), dimension(:,:), intent(in) :: p if (debug_on) call msg_debug2 (D_ME_METHODS, "compute_all_colour_correlations_rcl") call compute_all_colour_correlations_rcl (id, p) end subroutine rclwrap_compute_all_color_correlations @ %def rclwrap_compute_all_color_correlations @ <>= public :: rclwrap_rescale_color_correlation <>= subroutine rclwrap_rescale_color_correlation (id, i1, i2, sqme) integer, intent(in) :: id, i1, i2 real(double), intent(out), optional :: sqme if (debug_on) call msg_debug2 (D_ME_METHODS, "rescale_colour_correlation_rcl") call rescale_colour_correlation_rcl (id, i1, i2, sqme) end subroutine rclwrap_rescale_color_correlation @ %def rclwrap_rescale_color_correlation @ <>= public :: rclwrap_rescale_all_color_correlations <>= subroutine rclwrap_rescale_all_color_correlations (id) integer, intent(in) :: id if (debug_on) call msg_debug2 (D_ME_METHODS, "rescale_all_colour_correlations_rcl") call rescale_all_colour_correlations_rcl (id) end subroutine rclwrap_rescale_all_color_correlations @ %def rclwrap_rescale_all_color_correlations @ <>= public :: rclwrap_get_color_correlation <>= subroutine rclwrap_get_color_correlation (id, alphas_power, i1, i2, sqme) integer, intent(in) :: id, alphas_power, i1, i2 real(double), intent(out) :: sqme if (debug_on) call msg_debug2 (D_ME_METHODS, "get_colour_correlation_rcl") call get_colour_correlation_rcl (id, alphas_power, i1, i2, sqme) end subroutine rclwrap_get_color_correlation @ %def rclwrap_get_color_correlation @ <>= public :: rclwrap_compute_spin_correlation <>= subroutine rclwrap_compute_spin_correlation (id, p, i_photon, pol, sqme) integer, intent(in) :: id real(double), dimension(:,:), intent(in) :: p integer, intent(in) :: i_photon complex(double), dimension(:), intent(in) :: pol real(double), intent(out), optional :: sqme if (debug_on) call msg_debug2 (D_ME_METHODS, "compute_spin_correlation_rcl") call compute_spin_correlation_rcl (id, p, i_photon, pol, sqme) end subroutine rclwrap_compute_spin_correlation @ %def rclwrap_compute_spin_correlation @ <>= public :: rclwrap_rescale_spin_correlation <>= subroutine rclwrap_rescale_spin_correlation (id, i_photon, pol, sqme) integer, intent(in) :: id, i_photon complex(double), dimension(:), intent(in) :: pol real(double), intent(out), optional :: sqme if (debug_on) call msg_debug2 (D_ME_METHODS, "rescale_spin_correlation_rcl") call rescale_spin_correlation_rcl (id, i_photon, pol, sqme) end subroutine rclwrap_rescale_spin_correlation @ %def rclwrap_rescale_spin_correlation @ <>= public :: rclwrap_get_spin_correlation <>= subroutine rclwrap_get_spin_correlation (id, alphas_power, sqme) integer, intent(in) :: id, alphas_power real(double), intent(out) :: sqme if (debug_on) call msg_debug2 (D_ME_METHODS, "get_spin_correlation_rcl") call get_spin_correlation_rcl (id, alphas_power, sqme) end subroutine rclwrap_get_spin_correlation @ %def rclwrap_get_spin_correlation @ <>= public :: rclwrap_compute_spin_color_correlation <>= subroutine rclwrap_compute_spin_color_correlation (id, p, & i_gluon, i_spectator, pol, sqme) integer, intent(in) :: id real(double), dimension(:,:), intent(in) :: p integer, intent(in) :: i_gluon, i_spectator complex(double), dimension(:), intent(in) :: pol real(double), intent(out), optional :: sqme if (debug_on) call msg_debug2 (D_ME_METHODS, "compute_spin_colour_correlation_rcl") call compute_spin_colour_correlation_rcl (id, p, & i_gluon, i_spectator, pol, sqme) end subroutine rclwrap_compute_spin_color_correlation @ %def rclwrap_compute_spin_color_correlation @ <>= public :: rclwrap_rescale_spin_color_correlation <>= subroutine rclwrap_rescale_spin_color_correlation (id, i_gluon, & i_spectator, pol, sqme) integer, intent(in) :: id, i_gluon, i_spectator complex(double), dimension(:), intent(in) :: pol real(double), intent(out), optional :: sqme if (debug_on) call msg_debug2 (D_ME_METHODS, "rescale_spin_colour_correlation_rcl") call rescale_spin_colour_correlation_rcl (id, i_gluon, & i_spectator, pol, sqme) end subroutine rclwrap_rescale_spin_color_correlation @ %def rclwrap_rescale_spin_color_correlation @ <>= public :: rclwrap_get_spin_color_correlation <>= subroutine rclwrap_get_spin_color_correlation (id, alphas_power, & i_gluon, i_spectator, sqme) integer, intent(in) :: id, alphas_power, i_gluon, i_spectator real(double), intent(out) :: sqme if (debug_on) call msg_debug2 (D_ME_METHODS, "get_spin_colour_correlation_rcl") call get_spin_colour_correlation_rcl (id, alphas_power, & i_gluon, i_spectator, sqme) end subroutine rclwrap_get_spin_color_correlation @ %def rclwrap_get_spin_color_correlation @ <>= public :: rclwrap_get_momenta <>= subroutine rclwrap_get_momenta (id, p) integer, intent(in) :: id real(double), dimension(:,:), intent(out) :: p if (debug_on) call msg_debug2 (D_ME_METHODS, "get_momenta_rcl") call get_momenta_rcl (id, p) end subroutine rclwrap_get_momenta @ %def rclwrap_get_momenta @ The reset routine is essential. But note that it doesn't reset the Recola parameters, just the processes. For LOL, Recola's reset routine crashes the program if there was no process before. So, rather reset indirectly via the controller. <>= public :: rclwrap_reset_recola <>= subroutine rclwrap_reset_recola if (debug_on) call msg_debug (D_ME_METHODS, "rclwrap_reset_recola") call rcl_controller%reset () end subroutine rclwrap_reset_recola @ %def rclwrap_reset_recola @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Recola dummy replacement module} <<[[recola_wrapper_dummy.f90]]>>= <> module recola_wrapper use kinds <> <> -<> +<> -<> +<> contains -<> +<> end module recola_wrapper @ %def recola_wrapper_dummy @ -<>= +<>= public :: rclwrap_is_active -<>= +<>= logical, parameter :: rclwrap_is_active = .false. @ %def rclwrap_is_active @ -<>= +<>= public :: get_recola_particle_string -<>= +<>= elemental function get_recola_particle_string (pdg) result (name) type(string_t) :: name integer, intent(in) :: pdg name = var_str ("?") end function get_recola_particle_string @ %def get_recola_paritcle_string @ -<>= +<>= public :: rclwrap_get_new_recola_id -<>= +<>= subroutine rclwrap_get_new_recola_id (id) integer, intent(out) :: id id = 0 end subroutine rclwrap_get_new_recola_id @ %def rclwrap_get_new_recola_id @ -<>= +<>= public :: rclwrap_get_current_recola_id -<>= +<>= function rclwrap_get_current_recola_id () result (n) integer :: n n = 0 end function rclwrap_get_current_recola_id @ %def rclwrap_get_current_recola_id @ -<>= +<>= public :: rclwrap_request_generate_processes -<>= +<>= subroutine rclwrap_request_generate_processes () end subroutine rclwrap_request_generate_processes @ %def rclwrap_request_generate_processes @ -<>= +<>= public :: rclwrap_add_process -<>= +<>= subroutine rclwrap_add_process (id, process_string, order) integer, intent(in) :: id type(string_t), intent(in) :: process_string, order end subroutine rclwrap_add_process @ %def rclwrap_add_process @ -<>= +<>= public :: rclwrap_define_processes -<>= +<>= subroutine rclwrap_define_processes () end subroutine rclwrap_define_processes @ %def rclwrap_define_processes @ -<>= +<>= public :: rclwrap_generate_processes -<>= +<>= subroutine rclwrap_generate_processes () end subroutine rclwrap_generate_processes @ %def rclwrap_generate_processes @ -<>= +<>= public :: rclwrap_compute_process -<>= +<>= subroutine rclwrap_compute_process (id, p, order, sqme) integer, intent(in) :: id real(double), intent(in), dimension(:,:) :: p character(len=*), intent(in) :: order real(double), intent(out), dimension(0:1), optional :: sqme end subroutine rclwrap_compute_process @ %def rclwrap_compute_process @ -<>= +<>= public :: rclwrap_get_amplitude -<>= +<>= subroutine rclwrap_get_amplitude (id, g_power, order, col, hel, amp) integer, intent(in) :: id, g_power character(len=*), intent(in) :: order integer, dimension(:), intent(in) :: col, hel complex(double), intent(out) :: amp end subroutine rclwrap_get_amplitude @ %def rclwrap_get_amplitude @ -<>= +<>= public :: rclwrap_get_squared_amplitude -<>= +<>= subroutine rclwrap_get_squared_amplitude (id, alphas_power, order, sqme) integer, intent(in) :: id, alphas_power character(len=*), intent(in) :: order real(double), intent(out) :: sqme end subroutine rclwrap_get_squared_amplitude @ %def rclwrap_get_squared_amplitude @ -<>= +<>= public :: rclwrap_set_pole_mass -<>= +<>= subroutine rclwrap_set_pole_mass (pdg_id, mass, width) integer, intent(in) :: pdg_id real(double), intent(in) :: mass, width end subroutine rclwrap_set_pole_mass @ %def rclwrap_set_pole_mass @ -<>= +<>= public :: rclwrap_set_onshell_mass -<>= +<>= subroutine rclwrap_set_onshell_mass (pdg_id, mass, width) integer, intent(in) :: pdg_id real(double), intent(in) :: mass, width end subroutine rclwrap_set_onshell_mass @ %def rclwrap_set_onshell_mass @ -<>= +<>= public :: rclwrap_use_gfermi_scheme -<>= +<>= subroutine rclwrap_use_gfermi_scheme (gf) real(double), intent(in), optional :: gf end subroutine rclwrap_use_gfermi_scheme @ %def rclwrap_use_gfermi_scheme @ -<>= +<>= public :: rclwrap_set_light_fermions -<>= +<>= subroutine rclwrap_set_light_fermions (m) real(double), intent(in) :: m end subroutine rclwrap_set_light_fermions @ %def rclwrap_set_light_fermions @ -<>= +<>= public :: rclwrap_set_light_fermion -<>= +<>= subroutine rclwrap_set_light_fermion (pdg_id) integer, intent(in) :: pdg_id end subroutine rclwrap_set_light_fermion @ %def rclwrap_set_light_fermion @ -<>= +<>= public :: rclwrap_unset_light_fermion -<>= +<>= subroutine rclwrap_unset_light_fermion (pdg_id) integer, intent(in) :: pdg_id end subroutine rclwrap_unset_light_fermion @ %def rclwrap_unset_light_fermion @ -<>= +<>= public :: rclwrap_set_onshell_scheme -<>= +<>= subroutine rclwrap_set_onshell_scheme end subroutine rclwrap_set_onshell_scheme @ %def rclwrap_set_onshell_scheme @ -<>= +<>= public :: rclwrap_set_alpha_s -<>= +<>= subroutine rclwrap_set_alpha_s (alpha_s, mu, nf) real(double), intent(in) :: alpha_s, mu integer, intent(in) :: nf end subroutine rclwrap_set_alpha_s @ %def rclwrap_set_alpha_s @ -<>= +<>= public :: rclwrap_get_alpha_s -<>= +<>= function rclwrap_get_alpha_s () result (alpha_s) real(double) :: alpha_s end function rclwrap_get_alpha_s @ %def rclwrap_get_alpha_s @ -<>= +<>= public :: rclwrap_get_helicity_configurations -<>= +<>= subroutine rclwrap_get_helicity_configurations (id, hel) integer, intent(in) :: id integer, intent(inout), dimension(:,:), allocatable :: hel end subroutine rclwrap_get_helicity_configurations @ %def rclwrap_get_helicity_configurations @ -<>= +<>= public :: rclwrap_get_color_configurations -<>= +<>= subroutine rclwrap_get_color_configurations (id, col) integer, intent(in) :: id integer, intent(out), dimension(:,:), allocatable :: col end subroutine rclwrap_get_color_configurations @ %def rclwrap_get_color_configurations @ -<>= +<>= public :: rclwrap_use_dim_reg_soft -<>= +<>= subroutine rclwrap_use_dim_reg_soft () end subroutine rclwrap_use_dim_reg_soft @ %def rclwrap_use_dim_reg_soft @ -<>= +<>= public :: rclwrap_use_mass_reg_soft -<>= +<>= subroutine rclwrap_use_mass_reg_soft (m) real(double), intent(in) :: m end subroutine rclwrap_use_mass_reg_soft @ %def rclwrap_use_mass_reg_soft @ -<>= +<>= public :: rclwrap_set_delta_uv -<>= +<>= subroutine rclwrap_set_delta_uv (d) real(double), intent(in) :: d end subroutine rclwrap_set_delta_uv @ %def rclwrap_set_delta_uv @ -<>= +<>= public :: rclwrap_set_mu_uv -<>= +<>= subroutine rclwrap_set_mu_uv (mu) real(double), intent(in) :: mu end subroutine rclwrap_set_mu_uv @ %def rclwrap_set_mu_uv @ -<>= +<>= public :: rclwrap_set_delta_ir -<>= +<>= subroutine rclwrap_set_delta_ir (d, d2) real(double), intent(in) :: d, d2 end subroutine rclwrap_set_delta_ir @ %def rclwrap_set_delta_ir @ -<>= +<>= public :: rclwrap_set_mu_ir -<>= +<>= subroutine rclwrap_set_mu_ir (mu) real(double), intent(in) :: mu end subroutine rclwrap_set_mu_ir @ %def rclwrap_set_mu_ir @ -<>= +<>= public :: rclwrap_get_renormalization_scale -<>= +<>= subroutine rclwrap_get_renormalization_scale (mu) real(double), intent(out) :: mu end subroutine rclwrap_get_renormalization_scale @ %def rclwrap_get_renormalization_scale @ -<>= +<>= public :: rclwrap_get_flavor_scheme -<>= +<>= subroutine rclwrap_get_flavor_scheme (nf) integer, intent(out) :: nf end subroutine rclwrap_get_flavor_scheme @ %def rclwrap_get_flavor_scheme @ -<>= +<>= public :: rclwrap_use_alpha0_scheme -<>= +<>= subroutine rclwrap_use_alpha0_scheme (al0) real(double), intent(in), optional :: al0 end subroutine rclwrap_use_alpha0_scheme @ %def rclwrap_use_alpha0_scheme @ -<>= +<>= public :: rclwrap_use_alphaz_scheme -<>= +<>= subroutine rclwrap_use_alphaz_scheme (alz) real(double), intent(in), optional :: alz end subroutine rclwrap_use_alphaz_scheme @ %def rclwrap_use_alphaz_scheme @ -<>= +<>= public :: rclwrap_set_complex_mass_scheme -<>= +<>= subroutine rclwrap_set_complex_mass_scheme () end subroutine rclwrap_set_complex_mass_scheme @ %def rclwrap_set_complex_mass_scheme @ -<>= +<>= public :: rclwrap_set_resonant_particle -<>= +<>= subroutine rclwrap_set_resonant_particle (pdg_id) integer, intent(in) :: pdg_id end subroutine rclwrap_set_resonant_particle @ %def rclwrap_set_resonant_particle @ -<>= +<>= public :: rclwrap_switch_on_resonant_self_energies -<>= +<>= subroutine rclwrap_switch_on_resonant_self_energies () end subroutine rclwrap_switch_on_resonant_self_energies @ %def rclwrap_switch_on_resonant_self_energies @ -<>= +<>= public :: rclwrap_switch_off_resonant_self_energies -<>= +<>= subroutine rclwrap_switch_off_resonant_self_energies () end subroutine rclwrap_switch_off_resonant_self_energies @ %def rclwrap_switch_off_resonant_self_energies @ -<>= +<>= public :: rclwrap_set_draw_level_branches -<>= +<>= subroutine rclwrap_set_draw_level_branches (n) integer, intent(in) :: n end subroutine rclwrap_set_draw_level_branches @ %def rclwrap_set_draw_level_branches @ -<>= +<>= public :: rclwrap_set_print_level_amplitude -<>= +<>= subroutine rclwrap_set_print_level_amplitude (n) integer, intent(in) :: n end subroutine rclwrap_set_print_level_amplitude @ %def rclwrap_set_print_level_amplitude @ -<>= +<>= public :: rclwrap_set_print_level_squared_amplitude -<>= +<>= subroutine rclwrap_set_print_level_squared_amplitude (n) integer, intent(in) :: n end subroutine rclwrap_set_print_level_squared_amplitude @ %def rclwrap_set_print_level_squared_amplitude @ -<>= +<>= public :: rclwrap_set_print_level_correlations -<>= +<>= subroutine rclwrap_set_print_level_correlations (n) integer, intent(in) :: n end subroutine rclwrap_set_print_level_correlations @ %def rclwrap_set_print_level_correlations @ -<>= +<>= public :: rclwrap_set_print_level_RAM -<>= +<>= subroutine rclwrap_set_print_level_RAM (n) integer, intent(in) :: n end subroutine rclwrap_set_print_level_RAM @ %def rclwrap_set_print_level_RAM @ -<>= +<>= public :: rclwrap_scale_coupling3 -<>= +<>= subroutine rclwrap_scale_coupling3 (pdg_id1, pdg_id2, pdg_id3, factor) integer, intent(in) :: pdg_id1, pdg_id2, pdg_id3 complex(double), intent(in) :: factor end subroutine rclwrap_scale_coupling3 @ %def rclwrap_scale_coupling3 @ -<>= +<>= public :: rclwrap_scale_coupling4 -<>= +<>= subroutine rclwrap_scale_coupling4 (pdg_id1, pdg_id2, pdg_id3, pdg_id4, factor) integer, intent(in) :: pdg_id1, pdg_id2, pdg_id3, pdg_id4 complex(double), intent(in) :: factor end subroutine rclwrap_scale_coupling4 @ %def rclwrap_scale_coupling4 @ -<>= +<>= public :: rclwrap_switch_off_coupling3 -<>= +<>= subroutine rclwrap_switch_off_coupling3 (pdg_id1, pdg_id2, pdg_id3) integer, intent(in) :: pdg_id1, pdg_id2, pdg_id3 end subroutine rclwrap_switch_off_coupling3 @ %def rclwrap_switch_off_coupling3 @ -<>= +<>= public :: rclwrap_switch_off_coupling4 -<>= +<>= subroutine rclwrap_switch_off_coupling4 (pdg_id1, pdg_id2, pdg_id3, pdg_id4) integer, intent(in) :: pdg_id1, pdg_id2, pdg_id3, pdg_id4 end subroutine rclwrap_switch_off_coupling4 @ %def rclwrap_switch_off_coupling4 @ -<>= +<>= public :: rclwrap_set_ifail -<>= +<>= subroutine rclwrap_set_ifail (i) integer, intent(in) :: i end subroutine rclwrap_set_ifail @ %def rclwrap_set_ifail @ -<>= +<>= public :: rclwrap_get_ifail -<>= +<>= subroutine rclwrap_get_ifail (i) integer, intent(out) :: i end subroutine rclwrap_get_ifail @ %def rclwrap_get_ifail @ -<>= +<>= public :: rclwrap_set_output_file -<>= +<>= subroutine rclwrap_set_output_file (filename) character(len=*), intent(in) :: filename end subroutine rclwrap_set_output_file @ %def rclwrap_set_output_file @ -<>= +<>= public :: rclwrap_set_gs_power -<>= +<>= subroutine rclwrap_set_gs_power (id, gs_array) integer, intent(in) :: id integer, dimension(:,:), intent(in) :: gs_array end subroutine rclwrap_set_gs_power @ %def rclwrap_set_gs_power @ -<>= +<>= public :: rclwrap_select_gs_power_born_amp -<>= +<>= subroutine rclwrap_select_gs_power_born_amp (id, gs_power) integer, intent(in) :: id, gs_power end subroutine rclwrap_select_gs_power_born_amp @ %def rclwrap_select_gs_power_born_amp @ -<>= +<>= public :: rclwrap_unselect_gs_power_born_amp -<>= +<>= subroutine rclwrap_unselect_gs_power_born_amp (id, gs_power) integer, intent(in) :: id, gs_power end subroutine rclwrap_unselect_gs_power_born_amp @ %def rclwrap_unselect_gs_power_born_amp @ -<>= +<>= public :: rclwrap_select_gs_power_loop_amp -<>= +<>= subroutine rclwrap_select_gs_power_loop_amp (id, gs_power) integer, intent(in) :: id, gs_power end subroutine rclwrap_select_gs_power_loop_amp @ %def rclwrap_select_gs_power_loop_amp @ -<>= +<>= public :: rclwrap_unselect_gs_power_loop_amp -<>= +<>= subroutine rclwrap_unselect_gs_power_loop_amp (id, gs_power) integer, intent(in) :: id, gs_power end subroutine rclwrap_unselect_gs_power_loop_amp @ %def rclwrap_unselect_gs_power_loop_amp @ -<>= +<>= public :: rclwrap_select_all_gs_powers_born_amp -<>= +<>= subroutine rclwrap_select_all_gs_powers_born_amp (id) integer, intent(in) :: id end subroutine rclwrap_select_all_gs_powers_born_amp @ %def rclwrap_select_all_gs_powers_born_amp @ -<>= +<>= public :: rclwrap_unselect_all_gs_powers_loop_amp -<>= +<>= subroutine rclwrap_unselect_all_gs_powers_loop_amp (id) integer, intent(in) :: id end subroutine rclwrap_unselect_all_gs_powers_loop_amp @ %def rclwrap_unselect_all_gs_powers_loop_amp @ -<>= +<>= public :: rclwrap_select_all_gs_powers_loop_amp -<>= +<>= subroutine rclwrap_select_all_gs_powers_loop_amp (id) integer, intent(in) :: id end subroutine rclwrap_select_all_gs_powers_loop_amp @ %def rclwrap_select_all_gs_powers_loop_amp @ -<>= +<>= public :: rclwrap_unselect_all_gs_powers_born_amp -<>= +<>= subroutine rclwrap_unselect_all_gs_powers_born_amp (id) integer, intent(in) :: id end subroutine rclwrap_unselect_all_gs_powers_born_amp @ %def rclwrap_unselect_all_gs_powers_born_amp @ -<>= +<>= public :: rclwrap_set_resonant_squared_momentum -<>= +<>= subroutine rclwrap_set_resonant_squared_momentum (id, i_res, p2) integer, intent(in) :: id, i_res real(double), intent(in) :: p2 end subroutine rclwrap_set_resonant_squared_momentum @ %def rclwrap_set_resonant_squared_momentum @ -<>= +<>= public :: rclwrap_compute_running_alpha_s -<>= +<>= subroutine rclwrap_compute_running_alpha_s (Q, nf, n_loops) real(double), intent(in) :: Q integer, intent(in) :: nf, n_loops end subroutine rclwrap_compute_running_alpha_s @ %def rclwrap_compute_running_alpha_s @ -<>= +<>= public :: rclwrap_set_dynamic_settings -<>= +<>= subroutine rclwrap_set_dynamic_settings () end subroutine rclwrap_set_dynamic_settings @ %def rclwrap_set_dynamic_settings @ -<>= +<>= public :: rclwrap_rescale_process -<>= +<>= subroutine rclwrap_rescale_process (id, order, sqme) integer, intent(in) :: id character(len=*), intent(in) :: order real(double), dimension(0:1), intent(out), optional :: sqme end subroutine rclwrap_rescale_process @ %def rclwrap_rescale_process @ -<>= +<>= public :: rclwrap_get_polarized_squared_amplitude -<>= +<>= subroutine rclwrap_get_polarized_squared_amplitude (id, & alphas_power, order, hel, sqme) integer, intent(in) :: id, alphas_power character(len=*), intent(in) :: order integer, dimension(:), intent(in) :: hel real(double), intent(out) :: sqme end subroutine rclwrap_get_polarized_squared_amplitude @ %def rclwrap_get_polarized_squared_amplitude @ -<>= +<>= public :: rclwrap_compute_color_correlation -<>= +<>= subroutine rclwrap_compute_color_correlation (id, p, & i1, i2, sqme) integer, intent(in) :: id real(double), dimension(:,:), intent(in) :: p integer, intent(in) :: i1, i2 real(double), intent(out), optional :: sqme end subroutine rclwrap_compute_color_correlation @ %def rclwrap_compute_color_correlation @ -<>= +<>= public :: rclwrap_compute_all_color_correlations -<>= +<>= subroutine rclwrap_compute_all_color_correlations (id, p) integer, intent(in) :: id real(double), dimension(:,:), intent(in) :: p end subroutine rclwrap_compute_all_color_correlations @ %def rclwrap_compute_all_color_correlations @ -<>= +<>= public :: rclwrap_rescale_color_correlation -<>= +<>= subroutine rclwrap_rescale_color_correlation (id, i1, i2, sqme) integer, intent(in) :: id, i1, i2 real(double), intent(out), optional :: sqme end subroutine rclwrap_rescale_color_correlation @ %def rclwrap_rescale_color_correlation @ -<>= +<>= public :: rclwrap_rescale_all_color_correlations -<>= +<>= subroutine rclwrap_rescale_all_color_correlations (id) integer, intent(in) :: id end subroutine rclwrap_rescale_all_color_correlations @ %def rclwrap_rescale_all_color_correlations @ -<>= +<>= public :: rclwrap_get_color_correlation -<>= +<>= subroutine rclwrap_get_color_correlation (id, alphas_power, i1, i2, sqme) integer, intent(in) :: id, alphas_power, i1, i2 real(double), intent(out) :: sqme end subroutine rclwrap_get_color_correlation @ %def rclwrap_get_color_correlation @ -<>= +<>= public :: rclwrap_compute_spin_correlation -<>= +<>= subroutine rclwrap_compute_spin_correlation (id, p, i_photon, pol, sqme) integer, intent(in) :: id real(double), dimension(:,:), intent(in) :: p integer, intent(in) :: i_photon complex(double), dimension(:), intent(in) :: pol real(double), intent(out), optional :: sqme end subroutine rclwrap_compute_spin_correlation @ %def rclwrap_compute_spin_correlation @ -<>= +<>= public :: rclwrap_rescale_spin_correlation -<>= +<>= subroutine rclwrap_rescale_spin_correlation (id, i_photon, pol, sqme) integer, intent(in) :: id, i_photon complex(double), dimension(:), intent(in) :: pol real(double), intent(out), optional :: sqme end subroutine rclwrap_rescale_spin_correlation @ %def rclwrap_rescale_spin_correlation @ -<>= +<>= public :: rclwrap_get_spin_correlation -<>= +<>= subroutine rclwrap_get_spin_correlation (id, alphas_power, sqme) integer, intent(in) :: id, alphas_power real(double), intent(out) :: sqme end subroutine rclwrap_get_spin_correlation @ %def rclwrap_get_spin_correlation @ -<>= +<>= public :: rclwrap_compute_spin_color_correlation -<>= +<>= subroutine rclwrap_compute_spin_color_correlation (id, p, & i_gluon, i_spectator, pol, sqme) integer, intent(in) :: id real(double), dimension(:,:), intent(in) :: p integer, intent(in) :: i_gluon, i_spectator complex(double), dimension(:), intent(in) :: pol real(double), intent(out), optional :: sqme end subroutine rclwrap_compute_spin_color_correlation @ %def rclwrap_compute_spin_color_correlation @ -<>= +<>= public :: rclwrap_rescale_spin_color_correlation -<>= +<>= subroutine rclwrap_rescale_spin_color_correlation (id, i_gluon, & i_spectator, pol, sqme) integer, intent(in) :: id, i_gluon, i_spectator complex(double), dimension(:), intent(in) :: pol real(double), intent(out), optional :: sqme end subroutine rclwrap_rescale_spin_color_correlation @ %def rclwrap_rescale_spin_color_correlation @ -<>= +<>= public :: rclwrap_get_spin_color_correlation -<>= +<>= subroutine rclwrap_get_spin_color_correlation (id, alphas_power, & i_gluon, i_spectator, sqme) integer, intent(in) :: id, alphas_power, i_gluon, i_spectator real(double), intent(out) :: sqme end subroutine rclwrap_get_spin_color_correlation @ %def rclwrap_get_spin_color_correlation @ -<>= +<>= public :: rclwrap_get_momenta -<>= +<>= subroutine rclwrap_get_momenta (id, p) integer, intent(in) :: id real(double), dimension(:,:), intent(out) :: p end subroutine rclwrap_get_momenta @ %def rclwrap_get_momenta @ -<>= +<>= public :: rclwrap_reset_recola -<>= +<>= subroutine rclwrap_reset_recola end subroutine rclwrap_reset_recola @ %def rclwrap_reset_recola @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Recola Core} The recola core object and auxiliary types and objects. <<[[prc_recola.f90]]>>= <> module prc_recola use kinds <> <> use diagnostics use lorentz use physics_defs use variables, only: var_list_t use os_interface, only: os_data_t use sm_qcd, only: qcd_t use model_data, only: model_data_t use prc_core, only: prc_core_state_t use prc_core_def, only: prc_core_driver_t, prc_core_def_t use prc_external use process_libraries, only: process_library_t <> <> <> <> <> interface <> end interface contains <> end module prc_recola @ %def prc_recola @ <<[[prc_recola_sub.f90]]>>= <> submodule (prc_recola) prc_recola_s use constants, only: pi, zero use string_utils, only: str use system_defs, only: TAB use io_units use recola_wrapper !NODEP! implicit none contains <> end submodule prc_recola_s @ %def prc_recola_s @ \subsection{Sanity check} Checks the [[rclwrap_is_active]] flag and aborts the program if the dummy is used. <>= public :: abort_if_recola_not_active <>= module subroutine abort_if_recola_not_active () end subroutine abort_if_recola_not_active <>= module subroutine abort_if_recola_not_active () if (.not. rclwrap_is_active) call msg_fatal ("You want to use Recola, ", & [var_str("but either the compiler with which Whizard has been build "), & var_str("is not supported by it, or you have not linked Recola "), & var_str("correctly to Whizard. Either reconfigure Whizard with a path to "), & var_str("a valid Recola installation (for details consult the manual), "), & var_str("or choose a different matrix-element method.")]) end subroutine abort_if_recola_not_active @ %def abort_if_recola_not_active @ \subsection{Process definition} When defining a RECOLA process, we store the process-specific flags and parameters. Correction types are either QCD, EW, or full SM. <>= integer, parameter :: RECOLA_UNDEFINED = 0, RECOLA_QCD = 1, & RECOLA_EW = 2, RECOLA_FULL = 3 @ %def RECOLA_QCD RECOLA_EW RECOLA_FULL @ <>= public :: recola_def_t <>= type, extends (prc_external_def_t) :: recola_def_t type(string_t) :: suffix type(string_t) :: order integer :: alpha_power = 0 integer :: alphas_power = 0 integer :: corr = RECOLA_UNDEFINED contains <> end type recola_def_t @ %def recola_def_t @ <>= procedure, nopass :: type_string => recola_def_type_string <>= module function recola_def_type_string () result (string) type(string_t) :: string end function recola_def_type_string <>= module function recola_def_type_string () result (string) type(string_t) :: string string = "recola" end function recola_def_type_string @ %def recola_def_type_string @ Not implemented yet. <>= procedure :: write => recola_def_write <>= module subroutine recola_def_write (object, unit) class(recola_def_t), intent(in) :: object integer, intent(in) :: unit end subroutine recola_def_write <>= module subroutine recola_def_write (object, unit) class(recola_def_t), intent(in) :: object integer, intent(in) :: unit end subroutine recola_def_write @ %def recola_def_write @ <>= procedure :: read => recola_def_read <>= module subroutine recola_def_read (object, unit) class(recola_def_t), intent(out) :: object integer, intent(in) :: unit end subroutine recola_def_read <>= module subroutine recola_def_read (object, unit) class(recola_def_t), intent(out) :: object integer, intent(in) :: unit end subroutine recola_def_read @ %def recola_def_read @ The initializer has the responsibility to store all process- and method-specific parameters, such that they can be used later by the writer and by the driver for this process. Also, it allocates the writer. For RECOLA, the writer (i) creates full-fledged \oMega\ matrix element code which we need for the interface. (ii) registers the process definition with the RECOLA library which has been linked. The latter task does not involve external code. Note that all management stuff is taken care of by the base type(s) methods. Here, we introduce only RECOLA-specific procedures, in addition. The NLO flag is true only for virtual matrix elements. Gfortran 7/8/9 bug: has to remain in the main module. <>= procedure :: init => recola_def_init <>= subroutine recola_def_init (object, basename, model_name, & prt_in, prt_out, nlo_type, alpha_power, alphas_power, & correction_type, restrictions) class(recola_def_t), intent(inout) :: object type(string_t), intent(in) :: basename, model_name type(string_t), dimension(:), intent(in) :: prt_in, prt_out integer, intent(in) :: nlo_type integer, intent(in) :: alpha_power integer, intent(in) :: alphas_power type(string_t), intent(in) :: correction_type type(string_t), intent(in), optional :: restrictions if (debug_on) call msg_debug (D_ME_METHODS, "recola_def_init: " & // char (basename) // ", nlo_type", nlo_type) object%basename = basename object%alpha_power = alpha_power object%alphas_power = alphas_power select case (char (correction_type)) case ("QCD") object%corr = RECOLA_QCD case ("EW") object%corr = RECOLA_EW case ("Full") object%corr = RECOLA_FULL end select allocate (recola_writer_t :: object%writer) select case (nlo_type) case (BORN) object%suffix = '_BORN' object%order = "LO" case (NLO_REAL) object%suffix = '_REAL' object%order = "LO" if (object%corr == RECOLA_QCD) object%alphas_power = alphas_power + 1 if (object%corr == RECOLA_EW) object%alpha_power = alpha_power + 1 case (NLO_VIRTUAL) object%suffix = '_LOOP' object%order = "NLO" case (NLO_SUBTRACTION) object%suffix = '_SUB' object%order = "LO" case (NLO_MISMATCH) object%suffix = '_MISMATCH' object%order = "LO" case (NLO_DGLAP) object%suffix = '_DGLAP' object%order = "LO" end select select type (writer => object%writer) class is (recola_writer_t) call writer%init (model_name, prt_in, prt_out, restrictions) call writer%set_id (basename // object%suffix) call writer%set_order (object%order) call writer%set_coupling_powers (object%alpha_power, object%alphas_power) end select end subroutine recola_def_init @ %def recola_def_init @ \subsection{Writer object} The RECOLA writer takes the additional resposibility of transferring process information to RECOLA. <>= type, extends (prc_external_writer_t) :: recola_writer_t private type(string_t) :: id type(string_t) :: order integer :: alpha_power = 0 integer :: alphas_power = 0 contains <> end type recola_writer_t @ %def recola_writer_t @ <>= procedure, nopass :: type_name => recola_writer_type_name <>= module function recola_writer_type_name () result (string) type(string_t) :: string end function recola_writer_type_name <>= module function recola_writer_type_name () result (string) type(string_t) :: string string = "recola" end function recola_writer_type_name @ %def recola_writer_type_name @ Set the process ID string as used by WHIZARD. <>= procedure :: set_id => recola_writer_set_id <>= module subroutine recola_writer_set_id (writer, id) class(recola_writer_t), intent(inout) :: writer type(string_t), intent(in) :: id end subroutine recola_writer_set_id <>= module subroutine recola_writer_set_id (writer, id) class(recola_writer_t), intent(inout) :: writer type(string_t), intent(in) :: id if (debug_on) call msg_debug2 & (D_ME_METHODS, "Recola writer: id = " // char (id)) writer%id = id end subroutine recola_writer_set_id @ %def recola_writer_set_id @ Set the NLO flag. <>= procedure :: set_order => recola_writer_set_order <>= module subroutine recola_writer_set_order (writer, order) class(recola_writer_t), intent(inout) :: writer type(string_t), intent(in) :: order end subroutine recola_writer_set_order <>= module subroutine recola_writer_set_order (writer, order) class(recola_writer_t), intent(inout) :: writer type(string_t), intent(in) :: order if (debug_on) call msg_debug2 & (D_ME_METHODS, "Recola writer: order = " // char (order)) writer%order = order end subroutine recola_writer_set_order @ %def recola_writer_set_order @ Set coupling powers. <>= procedure :: set_coupling_powers => recola_writer_set_coupling_powers <>= module subroutine recola_writer_set_coupling_powers & (writer, alpha_power, alphas_power) class(recola_writer_t), intent(inout) :: writer integer, intent(in) :: alpha_power integer, intent(in) :: alphas_power end subroutine recola_writer_set_coupling_powers <>= module subroutine recola_writer_set_coupling_powers & (writer, alpha_power, alphas_power) class(recola_writer_t), intent(inout) :: writer integer, intent(in) :: alpha_power integer, intent(in) :: alphas_power if (debug_on) call msg_debug2 & (D_ME_METHODS, "Recola writer: alphas_power", alphas_power) if (debug_on) call msg_debug2 & (D_ME_METHODS, "Recola writer: alpha_power", alpha_power) writer%alpha_power = alpha_power writer%alphas_power = alphas_power end subroutine recola_writer_set_coupling_powers @ %def recola_writer_set_coupling_powers @ The Makefile code contains all of the code that the [[prc_external]] base method generates, plus an extra clause that extracts a shorthand listing of all flavor combinations for the current process. This list is required by [[make source]], so it can be read and used for declaring the RECOLA processes. There is one glitch here: we use the component-specific source file but write a flavor list for the process, without component extension. That is, we must not have more than one component at this stage. NB: We might actually extend \oMega\ to produce this shorthand listing. <>= procedure :: write_makefile_code => recola_writer_write_makefile_code <>= module subroutine recola_writer_write_makefile_code & (writer, unit, id, os_data, verbose, testflag) class(recola_writer_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id type(os_data_t), intent(in) :: os_data logical, intent(in) :: verbose logical, intent(in), optional :: testflag end subroutine recola_writer_write_makefile_code <>= function flv_file_name (id) type(string_t), intent(in) :: id type(string_t) :: flv_file_name flv_file_name = id // ".flv.dat" end function flv_file_name module subroutine recola_writer_write_makefile_code & (writer, unit, id, os_data, verbose, testflag) class(recola_writer_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id type(os_data_t), intent(in) :: os_data logical, intent(in) :: verbose logical, intent(in), optional :: testflag type(string_t) :: src_file type(string_t) :: flv_file call writer%base_write_makefile_code (unit, id, os_data, verbose, testflag) src_file = trim (char(id)) // ".f90" flv_file = flv_file_name (writer%id) write (unit, *) write (unit, "(5A)") "# Flavor state listing for RECOLA process generation" write (unit, "(5A)") char (flv_file), ": ", char (src_file) if (verbose) then write (unit, "(5A)", advance="no") TAB else write (unit, "(5A)") TAB, '@echo " MAKE ', char (flv_file), '"' write (unit, "(5A)", advance="no") TAB, "@" end if write (unit, "(5A)") & "grep 'data table_flavor_states' $< ", & "| sed -e 's/.*\/\(.*\)\/.*/\1/' -e 's/,//g' > $@" write (unit, "(5A)") "SOURCES += ", char (flv_file) write (unit, "(5A)") "CLEAN_SOURCES += ", char (flv_file) end subroutine recola_writer_write_makefile_code @ %def recola_writer_write_makefile_code @ To communicate the process definition to RECOLA, we must know the following: the process definition, expanded in terms of flavor states, and the process order (LO/NLO). We will ask for a new numeric ID, create a process string using RECOLA conventions, and define the process. The [[request_generate_processes]] enables the RECOLA internal process compiler, which can be called only after all processes have been defined. <>= procedure :: register_processes => prc_recola_register_processes <>= module subroutine prc_recola_register_processes (writer, recola_ids) class(recola_writer_t), intent(in) :: writer integer, dimension (:), intent(inout) :: recola_ids end subroutine prc_recola_register_processes <>= module subroutine prc_recola_register_processes (writer, recola_ids) class(recola_writer_t), intent(in) :: writer integer, dimension (:), intent(inout) :: recola_ids integer :: recola_id integer :: i_flv integer :: n_tot integer :: unit, iostat integer, dimension(:), allocatable :: pdg type(string_t), dimension(:), allocatable :: particle_names type(string_t) :: process_string integer :: i_part !!! TODO (cw-2016-08-08): Include helicities call msg_message ("Recola: registering processes for '" // char (writer%id) // "'") i_flv = 0 n_tot = writer%n_in + writer%n_out allocate (pdg (n_tot)) allocate (particle_names (n_tot)) call open_flv_list (writer%id, unit) call rclwrap_request_generate_processes () SCAN_FLV_LIST: do read (unit, *, iostat = iostat) pdg if (iostat < 0) then exit SCAN_FLV_LIST else if (iostat > 0) then call err_flv_list (writer%id) end if i_flv = i_flv + 1 call rclwrap_get_new_recola_id (recola_id) recola_ids(i_flv) = recola_id particle_names(:) = get_recola_particle_string (pdg) process_string = var_str ("") do i_part = 1, n_tot process_string = process_string // & particle_names (i_part) // var_str (" ") if (i_part == writer%n_in) then process_string = process_string // var_str ("-> ") end if end do call msg_message ("Recola: " & // "process #" // char (str (recola_id)) & // ": " // char (process_string) & // "(" // char (writer%order) // ")") call rclwrap_add_process (recola_id, process_string, writer%order) call rclwrap_define_processes () end do SCAN_FLV_LIST call close_flv_list (unit) if (debug_on) call msg_debug (D_ME_METHODS, "RECOLA: processes for '" & // char (writer%id) // "' registered") end subroutine prc_recola_register_processes @ %def prc_recola_register_processes @ Manage the list of flavor combinations for the current process. We rely on this being created along with the \oMega\ call. <>= subroutine open_flv_list (id, unit) type(string_t), intent(in) :: id integer, intent(out) :: unit type(string_t) :: flv_file integer :: iostat flv_file = flv_file_name (id) open (file = char (flv_file), newunit = unit, & status = "old", action = "read", & iostat = iostat) if (iostat /= 0) then call msg_fatal ("Recola: attempt to open flavor-list file '" & // char (flv_file) // "' failed") end if end subroutine open_flv_list subroutine err_flv_list (id) type(string_t), intent(in) :: id type(string_t) :: flv_file flv_file = flv_file_name (id) call msg_fatal ("Recola: error while reading from flavor-list file '" & // char (flv_file) // "'") end subroutine err_flv_list subroutine close_flv_list (unit) integer, intent(in) :: unit close (unit) end subroutine close_flv_list @ %def open_flv_list @ %def err_flv_list @ %def close_flv_list @ \subsection{Driver object} A core driver is required by design. However, we are not going to load any external dynamical libraries, so this is a dummy. <>= type, extends (prc_external_driver_t) :: recola_driver_t contains <> end type recola_driver_t @ %def recola_driver_t @ Gfortran 7/8/9 bug: has to remain in the main module. <>= procedure :: allocate_driver => recola_def_allocate_driver <>= subroutine recola_def_allocate_driver (object, driver, basename) class(recola_def_t), intent(in) :: object class(prc_core_driver_t), intent(out), allocatable :: driver type(string_t), intent(in) :: basename if (debug_on) call msg_debug2 (D_ME_METHODS, "recola_def_allocate_driver") allocate (recola_driver_t :: driver) end subroutine recola_def_allocate_driver @ %def recola_def_allocate_driver @ <>= procedure, nopass :: type_name => recola_driver_type_name <>= module function recola_driver_type_name () result (type) type(string_t) :: type end function recola_driver_type_name <>= module function recola_driver_type_name () result (type) type(string_t) :: type type = "Recola" end function recola_driver_type_name @ %def recola_driver_type_name @ \subsection{Process object} We create [[prc_recola_t]] as an extension of the [[prc_external_t]], which in turn inherits from [[prc_core_t]]. This way, we can use a lot of the existing interfaces in the actual code. However, we have to stick to the rules and implement the deferred type-bound procedures of [[prc_core_t]]. <>= public :: prc_recola_t <>= type, extends (prc_external_t) :: prc_recola_t integer, dimension(:), allocatable :: recola_ids integer, dimension(:,:), allocatable :: color_state integer :: n_f = 0 logical :: helicity_and_color_arrays_are_replaced = .false. contains <> end type prc_recola_t @ %def prc_recola_t @ <>= procedure :: write_name => prc_recola_write_name <>= module subroutine prc_recola_write_name (object, unit) class(prc_recola_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine prc_recola_write_name <>= module subroutine prc_recola_write_name (object, unit) class(prc_recola_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u,"(1x,A)") "Core: Recola" end subroutine prc_recola_write_name @ %def prc_recola_write_name @ <>= procedure :: has_matrix_element => prc_recola_has_matrix_element <>= module function prc_recola_has_matrix_element (object) result (flag) logical :: flag class(prc_recola_t), intent(in) :: object end function prc_recola_has_matrix_element <>= module function prc_recola_has_matrix_element (object) result (flag) logical :: flag class(prc_recola_t), intent(in) :: object flag = .true. end function prc_recola_has_matrix_element @ %def prc_recola_has_matrix_element @ Not implemented yet. <>= procedure :: write => prc_recola_write <>= module subroutine prc_recola_write (object, unit) class(prc_recola_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine prc_recola_write <>= module subroutine prc_recola_write (object, unit) class(prc_recola_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine prc_recola_write @ %def prc_recola_write @ \subsection{Accompanying state object} This must be implemented, but is unused. <>= type, extends (prc_external_state_t) :: recola_state_t contains <> end type recola_state_t @ %def recola_state_t @ <>= procedure :: write => recola_state_write <>= module subroutine recola_state_write (object, unit) class(recola_state_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine recola_state_write <>= module subroutine recola_state_write (object, unit) class(recola_state_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine recola_state_write @ %def recola_state_write @ Gfortran 7/8/9 bug: has to remain in the main module. <>= procedure :: allocate_workspace => prc_recola_allocate_workspace <>= subroutine prc_recola_allocate_workspace (object, core_state) class(prc_recola_t), intent(in) :: object class(prc_core_state_t), intent(inout), allocatable :: core_state allocate (recola_state_t :: core_state) end subroutine prc_recola_allocate_workspace @ %def prc_recola_allocate_workspace @ \subsection{Recola process data} This information is stored in the associated [[def]] object. To obtain it, we need a type cast. <>= procedure :: get_alpha_power => prc_recola_get_alpha_power procedure :: get_alphas_power => prc_recola_get_alphas_power <>= module function prc_recola_get_alpha_power (object) result (p) class(prc_recola_t), intent(in) :: object integer :: p end function prc_recola_get_alpha_power module function prc_recola_get_alphas_power (object) result (p) class(prc_recola_t), intent(in) :: object integer :: p end function prc_recola_get_alphas_power <>= module function prc_recola_get_alpha_power (object) result (p) class(prc_recola_t), intent(in) :: object integer :: p p = 0 if (associated (object%def)) then select type (def => object%def) type is (recola_def_t) p = def%alpha_power end select end if end function prc_recola_get_alpha_power module function prc_recola_get_alphas_power (object) result (p) class(prc_recola_t), intent(in) :: object integer :: p p = 0 if (associated (object%def)) then select type (def => object%def) type is (recola_def_t) p = def%alphas_power end select end if end function prc_recola_get_alphas_power @ %def prc_recola_get_alpha_power @ %def prc_recola_get_alphas_power @ <>= procedure :: compute_alpha_s => prc_recola_compute_alpha_s <>= module subroutine prc_recola_compute_alpha_s (object, core_state, ren_scale) class(prc_recola_t), intent(in) :: object class(prc_external_state_t), intent(inout) :: core_state real(default), intent(in) :: ren_scale end subroutine prc_recola_compute_alpha_s <>= module subroutine prc_recola_compute_alpha_s (object, core_state, ren_scale) class(prc_recola_t), intent(in) :: object class(prc_external_state_t), intent(inout) :: core_state real(default), intent(in) :: ren_scale core_state%alpha_qcd = object%qcd%alpha%get (ren_scale) end subroutine prc_recola_compute_alpha_s @ %def prc_recola_compute_alpha_s @ <>= procedure :: includes_polarization => prc_recola_includes_polarization <>= module function prc_recola_includes_polarization (object) result (polarized) logical :: polarized class(prc_recola_t), intent(in) :: object end function prc_recola_includes_polarization <>= module function prc_recola_includes_polarization (object) result (polarized) logical :: polarized class(prc_recola_t), intent(in) :: object polarized = .false. end function prc_recola_includes_polarization @ %def prc_recola_includes_polarization @ \subsection{Prepare for process evaluation} This has become obsolete and is empty. <>= procedure :: prepare_external_code => & prc_recola_prepare_external_code <>= module subroutine prc_recola_prepare_external_code & (core, flv_states, var_list, os_data, libname, model, i_core, is_nlo) class(prc_recola_t), intent(inout) :: core integer, intent(in), dimension(:,:), allocatable :: flv_states type(var_list_t), intent(in) :: var_list type(os_data_t), intent(in) :: os_data type(string_t), intent(in) :: libname type(model_data_t), intent(in), target :: model integer, intent(in) :: i_core logical, intent(in) :: is_nlo end subroutine prc_recola_prepare_external_code <>= module subroutine prc_recola_prepare_external_code & (core, flv_states, var_list, os_data, libname, model, i_core, is_nlo) class(prc_recola_t), intent(inout) :: core integer, intent(in), dimension(:,:), allocatable :: flv_states type(var_list_t), intent(in) :: var_list type(os_data_t), intent(in) :: os_data type(string_t), intent(in) :: libname type(model_data_t), intent(in), target :: model integer, intent(in) :: i_core logical, intent(in) :: is_nlo if (debug_on) call msg_debug & (D_ME_METHODS, "prc_recola_prepare_external_code (no-op)") end subroutine prc_recola_prepare_external_code @ %def prc_recola_prepare_external_code @ Set all Recola parameters to their correct values. We use the model object for masses and such. Note that the QCD object provides the [[n_f]] parameter which affects $\alpha_s$ evaluation. Note that this is executed before the [[init]] method below, which defines and prepares the Recola process objects. This is in line with the Recola workflow, however. <>= procedure :: set_parameters => prc_recola_set_parameters <>= module subroutine prc_recola_set_parameters (object, qcd, model) class(prc_recola_t), intent(inout) :: object type(qcd_t), intent(in) :: qcd class(model_data_t), intent(in), target, optional :: model end subroutine prc_recola_set_parameters <>= module subroutine prc_recola_set_parameters (object, qcd, model) class(prc_recola_t), intent(inout) :: object type(qcd_t), intent(in) :: qcd class(model_data_t), intent(in), target, optional :: model if (debug_on) call msg_debug (D_ME_METHODS, "RECOLA: set_parameters") object%qcd = qcd call rclwrap_set_dynamic_settings () call rclwrap_set_pole_mass & (11, dble(model%get_real (var_str ('me'))), 0._double) call rclwrap_set_pole_mass & (13, dble(model%get_real (var_str ('mmu'))), 0._double) call rclwrap_set_pole_mass & (15, dble(model%get_real (var_str ('mtau'))), 0._double) call rclwrap_set_pole_mass (1, 0._double, 0._double) call rclwrap_set_pole_mass (2, 0._double, 0._double) call rclwrap_set_pole_mass (3, dble(model%get_real (var_str ('ms'))), 0._double) call rclwrap_set_pole_mass (4, dble(model%get_real (var_str ('mc'))), 0._double) call rclwrap_set_pole_mass (5, dble(model%get_real (var_str ('mb'))), 0._double) call rclwrap_set_pole_mass (6, dble(model%get_real (var_str ('mtop'))), & dble(model%get_real (var_str ('wtop')))) call rclwrap_set_pole_mass (23, dble(model%get_real (var_str ('mZ'))), & dble(model%get_real (var_str ('wZ')))) call rclwrap_set_pole_mass (24, dble(model%get_real (var_str ('mW'))), & dble(model%get_real (var_str ('wW')))) call rclwrap_set_pole_mass (25, dble(model%get_real (var_str ('mH'))), & dble(model%get_real (var_str ('wH')))) call rclwrap_use_gfermi_scheme (dble(model%get_real (var_str ('GF')))) call rclwrap_set_light_fermions (0._double) call rclwrap_set_delta_ir (0._double, dble(pi**2 / 6)) end subroutine prc_recola_set_parameters @ %def prc_recola_set_parameters @ <>= procedure :: set_mu_ir => prc_recola_set_mu_ir <>= subroutine prc_recola_set_mu_ir (object, mu) class(prc_recola_t), intent(inout) :: object real(default), intent(in) :: mu call rclwrap_set_mu_ir (dble(mu)) end subroutine prc_recola_set_mu_ir @ %def prc_recola_set_mu_ir @ Extend the base-type initialization method by Recola-specific initialization. We take the process definitions from the [[def]] object, which has been filled before. The [[writer]] component of the process-definition object can now complete its task and prepare the Recola processes. Sadly, we have to completely reset Recola first, since Recola does not allow to modify \emph{anything} after process definition. Also, we cannot really make use of Recola's multi-process capability without violating the Whizard convention that the parameter settings at process integration time apply, not at process definition time. Each new process (i.e., process-integration) object will thus trigger a complete new Recola instance. <>= procedure :: init => prc_recola_init <>= module subroutine prc_recola_init (object, def, lib, id, i_component) class(prc_recola_t), intent(inout) :: object class(prc_core_def_t), intent(in), target :: def type(process_library_t), intent(in), target :: lib type(string_t), intent(in) :: id integer, intent(in) :: i_component end subroutine prc_recola_init <>= module subroutine prc_recola_init (object, def, lib, id, i_component) class(prc_recola_t), intent(inout) :: object class(prc_core_def_t), intent(in), target :: def type(process_library_t), intent(in), target :: lib type(string_t), intent(in) :: id integer, intent(in) :: i_component integer :: n_flv if (debug_on) call msg_debug (D_ME_METHODS, "RECOLA: init process object") call object%base_init (def, lib, id, i_component) n_flv = size (object%data%flv_state, 2) allocate (object%recola_ids(n_flv)) select type (writer => object%def%writer) type is (recola_writer_t) call writer%register_processes (object%recola_ids) end select call rclwrap_generate_processes () call object%replace_helicity_and_color_arrays () end subroutine prc_recola_init @ %def prc_recola_init @ Recola can compute dressed amplitudes, but it needs helicity and color to be in its own format to do so. <>= procedure :: replace_helicity_and_color_arrays => & prc_recola_replace_helicity_and_color_arrays <>= module subroutine prc_recola_replace_helicity_and_color_arrays (object) class(prc_recola_t), intent(inout) :: object end subroutine prc_recola_replace_helicity_and_color_arrays <>= module subroutine prc_recola_replace_helicity_and_color_arrays (object) class(prc_recola_t), intent(inout) :: object integer, dimension(:,:), allocatable :: col_recola integer :: i if (debug_on) call msg_debug & (D_ME_METHODS, "RECOLA: replace_helicity_and_color_arrays") deallocate (object%data%hel_state) call rclwrap_get_helicity_configurations & (object%recola_ids(1), object%data%hel_state) call rclwrap_get_color_configurations (object%recola_ids(1), col_recola) allocate (object%color_state (object%data%n_in + object%data%n_out, & size (col_recola, dim = 2))) do i = 1, size (col_recola, dim = 2) object%color_state (:, i) = col_recola (:, i) end do end subroutine prc_recola_replace_helicity_and_color_arrays @ %def prc_recola_replace_helicity_and_color_arrays @ \subsection{Compute matrix element} Computes the amplitude as a function of the phase space point, the flavor, helicity and color index. It is currently only used in the form by [[prc_omega_t]], all the other ones use different interfaces. H With RECOLA, we might be able to use this, too. The current implementation can fail due to missing helicity initialization. <>= procedure :: compute_amplitude => prc_recola_compute_amplitude <>= module function prc_recola_compute_amplitude & (object, j, p, f, h, c, fac_scale, ren_scale, alpha_qcd_forced, & core_state) result (amp) complex(default) :: amp class(prc_recola_t), intent(in) :: object integer, intent(in) :: j type(vector4_t), intent(in), dimension(:) :: p integer, intent(in) :: f, h, c real(default), intent(in) :: fac_scale, ren_scale real(default), intent(in), allocatable :: alpha_qcd_forced class(prc_core_state_t), intent(inout), allocatable, optional :: & core_state end function prc_recola_compute_amplitude <>= module function prc_recola_compute_amplitude & (object, j, p, f, h, c, fac_scale, ren_scale, alpha_qcd_forced, & core_state) result (amp) complex(default) :: amp class(prc_recola_t), intent(in) :: object integer, intent(in) :: j type(vector4_t), intent(in), dimension(:) :: p integer, intent(in) :: f, h, c real(default), intent(in) :: fac_scale, ren_scale real(default), intent(in), allocatable :: alpha_qcd_forced class(prc_core_state_t), intent(inout), allocatable, optional :: & core_state real(double), dimension(0:3, object%data%n_in + object%data%n_out) :: & p_recola integer :: i logical :: new_event complex(double) :: amp_dble if (debug_on) call msg_debug2 (D_ME_METHODS, "prc_recola_compute_amplitude") if (present (core_state)) then if (allocated (core_state)) then select type (core_state) type is (recola_state_t) new_event = core_state%new_kinematics core_state%new_kinematics = .false. end select end if end if if (new_event) then do i = 1, object%data%n_in + object%data%n_out p_recola(:, i) = dble(p(i)%p) end do call rclwrap_compute_process (object%recola_ids(f), p_recola, 'LO') end if call rclwrap_get_amplitude (object%recola_ids(f), 0, 'LO', & object%color_state (:, c), object%data%hel_state (h, :), amp_dble) amp = amp_dble end function prc_recola_compute_amplitude @ %def prc_recola_compute_amplitude @ <>= procedure :: compute_sqme => prc_recola_compute_sqme <>= module subroutine prc_recola_compute_sqme (object, i_flv, i_hel, p, & ren_scale, sqme, bad_point) class(prc_recola_t), intent(in) :: object integer, intent(in) :: i_flv, i_hel type(vector4_t), dimension(:), intent(in) :: p real(default), intent(in) :: ren_scale real(default), intent(out) :: sqme logical, intent(out) :: bad_point end subroutine prc_recola_compute_sqme <>= module subroutine prc_recola_compute_sqme (object, i_flv, i_hel, p, & ren_scale, sqme, bad_point) class(prc_recola_t), intent(in) :: object integer, intent(in) :: i_flv, i_hel type(vector4_t), dimension(:), intent(in) :: p real(default), intent(in) :: ren_scale real(default), intent(out) :: sqme logical, intent(out) :: bad_point real(double) :: sqme_dble real(double), dimension(0:3, object%data%n_in + object%data%n_out) :: & p_recola real(default) :: alpha_s integer :: i integer :: alphas_power ! TODO sbrass: Helicity for RECOLA if (debug_on) call msg_debug2 (D_ME_METHODS, "prc_recola_compute_sqme") do i = 1, object%data%n_in + object%data%n_out p_recola(:, i) = dble(p(i)%p) end do alpha_s = object%qcd%alpha%get (ren_scale) if (debug_on) call msg_debug2 (D_ME_METHODS, "alpha_s", alpha_s) if (debug_on) call msg_debug2 (D_ME_METHODS, "ren_scale", ren_scale) call rclwrap_set_alpha_s (dble (alpha_s), dble (ren_scale), object%qcd%n_f) call rclwrap_set_mu_ir (dble (ren_scale)) call rclwrap_compute_process (object%recola_ids(i_flv), p_recola, 'LO') call rclwrap_get_squared_amplitude & (object%recola_ids(i_flv), object%get_alphas_power (), 'LO', sqme_dble) sqme = real(sqme_dble, kind=default) bad_point = .false. end subroutine prc_recola_compute_sqme @ %def prc_recola_compute_sqme @ <>= procedure :: compute_sqme_virt => prc_recola_compute_sqme_virt <>= module subroutine prc_recola_compute_sqme_virt (object, i_flv, i_hel, & p, ren_scale, es_scale, loop_method, sqme, bad_point) class(prc_recola_t), intent(in) :: object integer, intent(in) :: i_flv, i_hel type(vector4_t), dimension(:), intent(in) :: p real(default), intent(in) :: ren_scale, es_scale integer, intent(in) :: loop_method real(default), dimension(4), intent(out) :: sqme real(default) :: amp logical, intent(out) :: bad_point end subroutine prc_recola_compute_sqme_virt <>= module subroutine prc_recola_compute_sqme_virt (object, i_flv, i_hel, & p, ren_scale, es_scale, loop_method, sqme, bad_point) class(prc_recola_t), intent(in) :: object integer, intent(in) :: i_flv, i_hel type(vector4_t), dimension(:), intent(in) :: p real(default), intent(in) :: ren_scale, es_scale integer, intent(in) :: loop_method real(default), dimension(4), intent(out) :: sqme real(default) :: amp logical, intent(out) :: bad_point real(double), dimension(0:3, object%data%n_in + object%data%n_out) :: & p_recola real(double) :: sqme_dble real(default) :: alpha_s integer :: i ! TODO sbrass Helicity for RECOLA if (debug_on) call msg_debug2 (D_ME_METHODS, "prc_recola_compute_sqme_virt") sqme = zero do i = 1, object%data%n_in + object%data%n_out p_recola(:, i) = dble(p(i)%p) end do call rclwrap_set_mu_ir (dble (ren_scale)) alpha_s = object%qcd%alpha%get (ren_scale) call rclwrap_set_alpha_s (dble (alpha_s), dble (ren_scale), object%qcd%n_f) call rclwrap_compute_process (object%recola_ids(i_flv), p_recola, 'NLO') !!! JRR, TODO: generalize for EW corrections call rclwrap_get_squared_amplitude (object%recola_ids(i_flv), & object%get_alphas_power () + 1, 'NLO', sqme_dble) sqme(3) = sqme_dble call rclwrap_get_squared_amplitude & (object%recola_ids(i_flv), object%get_alphas_power (), 'LO', sqme_dble) sqme(4) = sqme_dble bad_point = .false. end subroutine prc_recola_compute_sqme_virt @ %def prc_recola_compute_sqme_virt @ For RECOLA, explicit color factors need to multiplied to the off-diagonal elements of the color correlation matrix. The factor 1/2 from the normalization accoring to the RECOLA manual is covered by the fact that we are taking only one half of the symmetric matrix. <>= procedure :: compute_sqme_color_c_raw => prc_recola_compute_sqme_color_c_raw <>= module subroutine prc_recola_compute_sqme_color_c_raw (object, & i_flv, i_hel, p, ren_scale, sqme_color_c, bad_point) class(prc_recola_t), intent(in) :: object integer, intent(in) :: i_hel, i_flv type(vector4_t), dimension(:), intent(in) :: p real(default), intent(in) :: ren_scale real(default), dimension(:), intent(out) :: sqme_color_c logical, intent(out) :: bad_point end subroutine prc_recola_compute_sqme_color_c_raw <>= module subroutine prc_recola_compute_sqme_color_c_raw (object, & i_flv, i_hel, p, ren_scale, sqme_color_c, bad_point) class(prc_recola_t), intent(in) :: object integer, intent(in) :: i_hel, i_flv type(vector4_t), dimension(:), intent(in) :: p real(double), dimension(0:3, object%data%n_in + object%data%n_out) :: & p_recola real(default), intent(in) :: ren_scale real(default), dimension(:), intent(out) :: sqme_color_c logical, intent(out) :: bad_point integer :: i1, i2, i, n_tot real(double) :: sqme_dble do i = 1, object%data%n_in + object%data%n_out p_recola(:, i) = dble(p(i)%p) end do n_tot = object%data%n_in + object%data%n_out i = 0 do i1 = 1, n_tot do i2 = 1, i1-1 i = i + 1 call rclwrap_compute_color_correlation & (object%recola_ids(i_flv), p_recola, i1, i2, sqme_dble) sqme_color_c(i) = real (sqme_dble, kind=default) select case (abs (object%data%flv_state (i1, i_flv))) case (1:6) sqme_color_c(i) = CF * sqme_color_c(i) case (9,21) sqme_color_c(i) = CA * sqme_color_c(i) end select end do end do end subroutine prc_recola_compute_sqme_color_c_raw @ %def prc_recola_compute_sqme_color_c_raw @ \subsection{Unit tests} <<[[prc_recola_ut.f90]]>>= <> module prc_recola_ut use unit_tests use prc_recola_uti <> <> contains <> end module prc_recola_ut @ %def prc_recola_ut @ <<[[prc_recola_uti.f90]]>>= <> module prc_recola_uti use recola_wrapper !NODEP! use, intrinsic :: iso_c_binding !NODEP! use kinds <> use constants use format_utils, only: write_separator use numeric_utils, only: assert_equal use os_interface use particle_specifiers, only: new_prt_spec use prc_core_def use process_constants use process_libraries use prc_core use prc_omega <> <> contains <> <> end module prc_recola_uti @ %def prc_recola_uti @ <>= public :: prc_recola_test <>= subroutine prc_recola_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine prc_recola_test @ %def prc_recola_test @ \subsubsection{Testing a fixed flavor matrix element computation} <>= function get_omega_parameter_array () result (par) real(default), dimension(25) :: par par = zero par(1) = 1.16637d-5 ! gf par(2) = 91.153480619182744_default ! mZ par(3) = 80.357973609877547_default ! mW par(4) = 125._default ! mH par(5) = rclwrap_get_alpha_s () ! alpha_s par(12) = 173.2_default ! mt par(14) = 2.4942663787728243_default ! wZ par(15) = 2.0842989982782196_default ! wW par(22) = one / sqrt (sqrt (two) * par(1)) ! par%v - Higgs expectation value par(23) = par(3) / par(2) ! par%cw par(24) = sqrt (one - par(23)**2) ! par%sw par(25) = two * par(24) * par(3) / par(22) end function get_omega_parameter_array @ %def get_omega_parameter_array @ <>= call test (prc_recola_1, "prc_recola_1", & "Registering a RECOLA process and computing the amplitude", & u, results) <>= public :: prc_recola_1 <>= subroutine prc_recola_1 (u) integer, intent(in) :: u real(double) :: p(0:3,1:4) real(double) :: sqrts = 500._double real(double) :: m_e = 0._double real(double) :: m_mu = 0._double real(double) :: p_x_out, p_y_out, p_z_out, p_z_in integer :: h_e_p, h_e_m, h_mu_p, h_mu_m, counter real(double) :: sqme integer :: i integer, dimension(:), allocatable :: col_recola, hel_recola complex(double) :: amp_recola complex(default) :: amp_recola_default real(default), parameter :: ee = 0.3 !!! Electromagnetic coupling type(process_library_t) :: lib class(prc_core_def_t), allocatable :: def type(process_def_entry_t), pointer :: entry type(string_t), dimension(:), allocatable :: prt_in, prt_out type(os_data_t) :: os_data type(process_constants_t) :: data class(prc_core_driver_t), allocatable :: driver complex(default) :: amp integer, dimension(:,:), allocatable :: helicities write (u, "(A)") "* Test output: prc_recola_1" write (u, "(A)") "* Purpose: Test interface to RECOLA and compare matrix elements with O'Mega" write (u, "(A)") p_z_in = sqrt ((sqrts / 2)**2 - m_e**2) p_z_out = 0._double p_y_out = sqrts / 10._default p_x_out = sqrt ((sqrts / 2)**2 - p_y_out**2 - p_z_out**2 - m_mu**2) p(:,1) = [sqrts / 2, 0._double, 0._double, p_z_in] p(:,2) = [sqrts / 2, 0._double, 0._double, -p_z_in] p(:,3) = [sqrts / 2, p_x_out, p_y_out, p_z_out] p(:,4) = [sqrts / 2, -p_x_out, -p_y_out, -p_z_out] write (u, "(A)") "Use phase-space point: " do i = 1, 4 write (u, "(4(F12.3,1x))") p(:,1) end do write (u, "(A)") call write_separator (u) write (u, "(A)") write (u, "(A)") "* RECOLA: Evaluate process" counter = 1 call rclwrap_request_generate_processes () write (u, "(A)") "* RECOLA: Define process e+ e- -> mu+ mu- at leading order" call rclwrap_add_process (counter, var_str ('e+ e- -> mu+ mu-'), var_str ('LO')) call rclwrap_define_processes () write (u, "(A)") "* RECOLA: generate process" call rclwrap_generate_processes () call rclwrap_compute_process (1, p, 'LO') call rclwrap_get_helicity_configurations (1, helicities) allocate (hel_recola (4), col_recola (4)) col_recola = [0,0,0,0] write (u, "(A)") "* Setting up Omega to compute the same amplitude" call lib%init (var_str ("omega1")) allocate (prt_in (2), prt_out (2)) prt_in = [var_str ("e+"), var_str ("e-")] prt_out = [var_str ("mu+"), var_str ("mu-")] allocate (omega_def_t :: def) select type (def) type is (omega_def_t) call def%init (var_str ("SM"), prt_in, prt_out, & ufo = .false., ovm = .false., cms_scheme = .true.) end select allocate (entry) call entry%init (var_str ("omega1_a"), model_name = var_str ("SM"), & n_in = 2, n_components = 1) call entry%import_component (1, n_out = 2, & prt_in = new_prt_spec (prt_in), & prt_out = new_prt_spec (prt_out), & method = var_str ("omega"), & variant = def) call lib%append (entry) call os_data%init () call lib%configure (os_data) call lib%write_makefile (os_data, force = .true., verbose = .false.) call lib%clean (os_data, distclean = .false.) call lib%write_driver (force = .true.) call lib%load (os_data) call lib%connect_process (var_str ("omega1_a"), 1, data, driver) select type (driver) type is (omega_driver_t) call driver%init (get_omega_parameter_array (), 3) call driver%new_event (real(p, kind = default)) do i = 1, 6 call rclwrap_get_amplitude (1, 0, 'LO', col_recola, helicities (:,i), amp_recola) end do do i = 1, 16 call rclwrap_get_amplitude (1, 0, 'LO', col_recola, data%hel_state (:,i), amp_recola) amp_recola = amp_recola * cmplx (0, -1, double) amp_recola_default = amp_recola call driver%get_amplitude (1, i, 1, amp) write(u,"(A,4(I2),A)") "Helicity: [",data%hel_state (:,i),"]" call assert_equal (u, amp, amp_recola_default, rel_smallness = 1.E-7_default) end do end select call rclwrap_reset_recola () write (u, "(A)") write (u, "(A)") "* End of test output: prc_recola_1" end subroutine prc_recola_1 @ %def prc_recola_1 @ \subsubsection{Testing a fixed flavor matrix element computation for 2->3} <>= call test (prc_recola_2, "prc_recola_2", & "Registering a RECOLA process and computing the amplitude for 2->3 process", & u, results) <>= public :: prc_recola_2 <>= subroutine prc_recola_2 (u) integer, intent(in) :: u real(double) :: p(0:3,1:5) real(double) :: sqrts = 700._double real(double) :: m_e = 0._double real(double) :: m_mu = 0._double real(double) :: p_x_out, p_y_out, p_z_out, p_z_in real(double) :: sqme integer :: i integer, dimension(:), allocatable :: col_recola, hel_recola integer, dimension(:,:), allocatable :: helicities complex(double) :: amp_recola complex(default) :: amp_recola_default real(default), parameter :: ee = 0.3 !!! Electromagnetic coupling type(process_library_t) :: lib class(prc_core_def_t), allocatable :: def type(process_def_entry_t), pointer :: entry type(string_t), dimension(:), allocatable :: prt_in, prt_out type(os_data_t) :: os_data type(process_constants_t) :: data class(prc_core_driver_t), allocatable :: driver complex(default) :: amp integer :: n_allowed write (u, "(A)") "* Test output: prc_recola_2" write (u, "(A)") "* Purpose: Test interface to RECOLA and compare matrix elements with O'Mega for 2->3 process" write (u, "(A)") p_z_in = sqrt ((sqrts / 2)**2 - m_e**2) p(:,1) = [sqrts / 2, 0._double, 0._double, p_z_in] p(:,2) = [sqrts / 2, 0._double, 0._double, -p_z_in] p(:,3) = [243.49323116_double, -141.69619338_double, -108.30640321_double, 165.77353656_double] p(:,4) = [337.53250628_double, 143.95931207_double, 110.19717026_double, -284.71124482_double] p(:,5) = [118.97426257_double, -2.2631186860_double, -1.8907670459_double, 118.93770827_double] write (u, "(A)") "Use phase-space point: " do i = 1, 5 write (u, "(4(F12.3,1x))") p(:,1) end do write (u, "(A)") call write_separator (u) write (u, "(A)") write (u, "(A)") "* RECOLA: Evaluate process" call rclwrap_request_generate_processes () write (u, "(A)") "* RECOLA: Define process e+ e- -> mu+ mu- A at leading order" call rclwrap_add_process (2, var_str ('e+ e- -> mu+ mu- A'), var_str ('LO')) call rclwrap_define_processes () write (u, "(A)") "* RECOLA: generate process" call rclwrap_generate_processes () call rclwrap_compute_process (2, p, 'LO') call rclwrap_get_helicity_configurations (2, helicities) allocate (hel_recola (5), col_recola (5)) col_recola = [0,0,0,0,0] write (u, "(A)") "* Setting up Omega to compute the same amplitude" call lib%init (var_str ("omega2")) allocate (prt_in (2), prt_out (3)) prt_in = [var_str ("e+"), var_str ("e-")] prt_out = [var_str ("mu+"), var_str ("mu-"), var_str("A")] allocate (omega_def_t :: def) select type (def) type is (omega_def_t) call def%init (var_str ("SM"), prt_in, prt_out, & ufo = .false., ovm = .false.) end select allocate (entry) call entry%init (var_str ("omega2_a"), model_name = var_str ("SM"), & n_in = 2, n_components = 1) call entry%import_component (1, n_out = 3, & prt_in = new_prt_spec (prt_in), & prt_out = new_prt_spec (prt_out), & method = var_str ("omega"), & variant = def) call lib%append (entry) call os_data%init () call lib%configure (os_data) call lib%write_makefile (os_data, force = .true., verbose = .false.) call lib%clean (os_data, distclean = .false.) call lib%write_driver (force = .true.) call lib%load (os_data) call lib%connect_process (var_str ("omega2_a"), 1, data, driver) select type (driver) type is (omega_driver_t) call driver%init (get_omega_parameter_array (), 3) call driver%new_event (real(p, kind = default)) do i = 1, 32 call rclwrap_get_amplitude & (2, 0, 'LO', col_recola, data%hel_state (:,i), amp_recola) if (data%hel_state(3,i) * data%hel_state(4,i) * & data%hel_state(5,i) == -1) then amp_recola = amp_recola * cmplx (0, -1, double) else amp_recola = amp_recola * cmplx (0, 1, double) end if amp_recola_default = amp_recola call driver%get_amplitude (1, i, 1, amp) write(u,"(A,5(I2),A)") "Helicity: [", data%hel_state (:,i),"]" write(u,"(A,2(F12.7,1x),A,2(F12.7,1x))") "RECOLA:", & amp_recola,", O'MEGA:", amp call assert_equal & (u, amp, amp_recola_default, rel_smallness = 1.E-6_default) end do end select call rclwrap_reset_recola () write (u, "(A)") write (u, "(A)") "* End of test output: prc_recola_2" end subroutine prc_recola_2 @ %def prc_recola_2 @ Index: trunk/share/debug/Makefile_full =================================================================== --- trunk/share/debug/Makefile_full (revision 8793) +++ trunk/share/debug/Makefile_full (revision 8794) @@ -1,648 +1,661 @@ FC=pgfortran_2019 FCFLAGS=-Mbackslash CC=gcc CCFLAGS= MODELS = \ SM.mdl \ SM_hadrons.mdl \ Test.mdl CC_SRC = \ sprintf_interface.c \ signal_interface.c F77_SRC = \ pythia.F \ pythia_pdf.f \ pythia6_up.f \ toppik.f \ toppik_axial.f FC0_SRC = FC_SRC = \ format_defs.f90 \ io_units.f90 \ kinds.f90 \ constants.f90 \ iso_varying_string.f90 \ unit_tests.f90 \ unit_tests_sub.f90 \ numeric_utils.f90 \ numeric_utils_sub.f90 \ system_dependencies.f90 \ string_utils.f90 \ string_utils_sub.f90 \ system_defs.f90 \ system_defs_sub.f90 \ debug_master.f90 \ diagnostics.f90 \ diagnostics_sub.f90 \ sorting.f90 \ physics_defs.f90 \ physics_defs_sub.f90 \ pdg_arrays.f90 \ bytes.f90 \ hashes.f90 \ md5.f90 \ model_data.f90 \ model_data_sub.f90 \ auto_components.f90 \ auto_components_sub.f90 \ var_base.f90 \ model_testbed.f90 \ auto_components_uti.f90 \ auto_components_ut.f90 \ os_interface.f90 \ os_interface_sub.f90 \ c_particles.f90 \ c_particles_sub.f90 \ format_utils.f90 \ lorentz.f90 \ lorentz_sub.f90 \ phs_points.f90 \ phs_points_sub.f90 \ colors.f90 \ colors_sub.f90 \ flavors.f90 \ flavors_sub.f90 \ helicities.f90 \ helicities_sub.f90 \ quantum_numbers.f90 \ quantum_numbers_sub.f90 \ state_matrices.f90 \ state_matrices_sub.f90 \ interactions.f90 \ interactions_sub.f90 \ CppStringsWrap_dummy.f90 \ FastjetWrap_dummy.f90 \ cpp_strings.f90 \ cpp_strings_sub.f90 \ fastjet.f90 \ fastjet_sub.f90 \ jets.f90 \ subevents.f90 \ su_algebra.f90 \ su_algebra_sub.f90 \ bloch_vectors.f90 \ bloch_vectors_sub.f90 \ polarizations.f90 \ polarizations_sub.f90 \ particles.f90 \ particles_sub.f90 \ event_base.f90 \ event_base_sub.f90 \ eio_data.f90 \ eio_data_sub.f90 \ event_handles.f90 \ eio_base.f90 \ eio_base_sub.f90 \ eio_base_uti.f90 \ eio_base_ut.f90 \ variables.f90 \ variables_sub.f90 \ rng_base.f90 \ rng_base_sub.f90 \ tao_random_numbers.f90 \ rng_tao.f90 \ rng_tao_sub.f90 \ rng_stream.f90 \ rng_stream_sub.f90 \ rng_base_uti.f90 \ rng_base_ut.f90 \ dispatch_rng.f90 \ dispatch_rng_sub.f90 \ dispatch_rng_uti.f90 \ dispatch_rng_ut.f90 \ beam_structures.f90 \ beam_structures_sub.f90 \ evaluators.f90 \ evaluators_sub.f90 \ beams.f90 \ beams_sub.f90 \ sm_physics.f90 \ sm_physics_sub.f90 \ file_registries.f90 \ file_registries_sub.f90 \ sf_aux.f90 \ sf_aux_sub.f90 \ sf_mappings.f90 \ sf_mappings_sub.f90 \ sf_base.f90 \ sf_base_sub.f90 \ electron_pdfs.f90 \ electron_pdfs_sub.f90 \ sf_isr.f90 \ sf_isr_sub.f90 \ sf_epa.f90 \ sf_epa_sub.f90 \ sf_ewa.f90 \ sf_ewa_sub.f90 \ sf_escan.f90 \ sf_escan_sub.f90 \ sf_gaussian.f90 \ sf_gaussian_sub.f90 \ sf_beam_events.f90 \ sf_beam_events_sub.f90 \ circe1.f90 \ sf_circe1.f90 \ sf_circe1_sub.f90 \ circe2.f90 \ selectors.f90 \ selectors_sub.f90 \ sf_circe2.f90 \ sf_circe2_sub.f90 \ sm_qcd.f90 \ sm_qcd_sub.f90 \ sm_qed.f90 \ sm_qed_sub.f90 \ mrst2004qed.f90 \ cteq6pdf.f90 \ mstwpdf.f90 \ ct10pdf.f90 \ CJpdf.f90 \ ct14pdf.f90 \ pdf_builtin.f90 \ pdf_builtin_sub.f90 \ LHAPDFWrap_dummy.f90 \ lhapdf5_full_dummy.f90 \ lhapdf5_has_photon_dummy.f90 \ lhapdf.f90 \ hoppet_dummy.f90 \ hoppet_interface.f90 \ sf_pdf_builtin.f90 \ sf_pdf_builtin_sub.f90 \ sf_lhapdf.f90 \ sf_lhapdf_sub.f90 \ dispatch_beams.f90 \ dispatch_beams_sub.f90 \ process_constants.f90 \ process_constants_sub.f90 \ prclib_interfaces.f90 \ prc_core_def.f90 \ prc_core_def_sub.f90 \ particle_specifiers.f90 \ particle_specifiers_sub.f90 \ process_libraries.f90 \ process_libraries_sub.f90 \ prc_test.f90 \ prc_test_sub.f90 \ prc_core.f90 \ prc_core_sub.f90 \ prc_test_core.f90 \ prc_test_core_sub.f90 \ sm_qed.f90 \ sm_qed_sub.f90 \ prc_omega.f90 \ prc_omega_sub.f90 \ phs_base.f90 \ + phs_base_sub.f90 \ ifiles.f90 \ lexers.f90 \ syntax_rules.f90 \ parser.f90 \ expr_base.f90 \ formats.f90 \ formats_sub.f90 \ analysis.f90 \ user_code_interface.f90 \ observables.f90 \ observables_sub.f90 \ eval_trees.f90 \ eval_trees_sub.f90 \ interpolation.f90 \ interpolation_sub.f90 \ nr_tools.f90 \ ttv_formfactors.f90 \ ttv_formfactors_use.f90 \ ttv_formfactors_uti.f90 \ ttv_formfactors_ut.f90 \ models.f90 \ prclib_stacks.f90 \ prclib_stacks_sub.f90 \ user_files.f90 \ cputime.f90 \ cputime_sub.f90 \ mci_base.f90 \ integration_results.f90 \ integration_results_uti.f90 \ integration_results_ut.f90 \ mappings.f90 \ + mappings_sub.f90 \ permutations.f90 \ + permutations_sub.f90 \ resonances.f90 \ + resonances_sub.f90 \ phs_trees.f90 \ + phs_trees_sub.f90 \ phs_forests.f90 \ + phs_forests_sub.f90 \ prc_external.f90 \ blha_config.f90 \ blha_config_sub.f90 \ blha_olp_interfaces.f90 \ blha_olp_interfaces_sub.f90 \ prc_openloops.f90 \ prc_openloops_sub.f90 \ prc_threshold.f90 \ prc_threshold_sub.f90 \ process_config.f90 \ process_counter.f90 \ process_mci.f90 \ pcm_base.f90 \ nlo_data.f90 \ cascades.f90 \ + cascades_sub.f90 \ cascades2_lexer.f90 \ cascades2_lexer_uti.f90 \ cascades2_lexer_ut.f90 \ cascades2.f90 \ cascades2_uti.f90 \ cascades2_ut.f90 \ phs_none.f90 \ + phs_none_sub.f90 \ phs_rambo.f90 \ + phs_rambo_sub.f90 \ phs_wood.f90 \ + phs_wood_sub.f90 \ phs_fks.f90 \ + phs_fks_sub.f90 \ phs_single.f90 \ + phs_single_sub.f90 \ fks_regions.f90 \ virtual.f90 \ pdf.f90 \ pdf_sub.f90 \ real_subtraction.f90 \ dglap_remnant.f90 \ dispatch_fks.f90 \ dispatch_phase_space.f90 \ + dispatch_phase_space_sub.f90 \ pcm.f90 \ recola_wrapper_dummy.f90 \ prc_recola.f90 \ subevt_expr.f90 \ parton_states.f90 \ prc_template_me.f90 \ prc_template_me_sub.f90 \ process.f90 \ process_stacks.f90 \ iterations.f90 \ rt_data.f90 \ file_utils.f90 \ file_utils_sub.f90 \ prc_gosam.f90 \ prc_gosam_sub.f90 \ dispatch_me_methods.f90 \ sf_base_uti.f90 \ sf_base_ut.f90 \ dispatch_uti.f90 \ dispatch_ut.f90 \ formats_uti.f90 \ formats_ut.f90 \ md5_uti.f90 \ md5_ut.f90 \ os_interface_uti.f90 \ os_interface_ut.f90 \ sorting_uti.f90 \ sorting_ut.f90 \ grids.f90 \ grids_uti.f90 \ grids_ut.f90 \ solver.f90 \ solver_uti.f90 \ solver_ut.f90 \ cputime_uti.f90 \ cputime_ut.f90 \ sm_qcd_uti.f90 \ sm_qcd_ut.f90 \ sm_physics_uti.f90 \ sm_physics_ut.f90 \ lexers_uti.f90 \ lexers_ut.f90 \ parser_uti.f90 \ parser_ut.f90 \ xml.f90 \ xml_uti.f90 \ xml_ut.f90 \ colors_uti.f90 \ colors_ut.f90 \ state_matrices_uti.f90 \ state_matrices_ut.f90 \ analysis_uti.f90 \ analysis_ut.f90 \ particles_uti.f90 \ particles_ut.f90 \ radiation_generator.f90 \ radiation_generator_sub.f90 \ radiation_generator_uti.f90 \ radiation_generator_ut.f90 \ blha_uti.f90 \ blha_ut.f90 \ evaluators_uti.f90 \ evaluators_ut.f90 \ models_uti.f90 \ models_ut.f90 \ eval_trees_uti.f90 \ eval_trees_ut.f90 \ resonances_uti.f90 \ resonances_ut.f90 \ phs_trees_uti.f90 \ phs_trees_ut.f90 \ phs_forests_uti.f90 \ phs_forests_ut.f90 \ beams_uti.f90 \ beams_ut.f90 \ su_algebra_uti.f90 \ su_algebra_ut.f90 \ bloch_vectors_uti.f90 \ bloch_vectors_ut.f90 \ polarizations_uti.f90 \ polarizations_ut.f90 \ sf_aux_uti.f90 \ sf_aux_ut.f90 \ sf_mappings_uti.f90 \ sf_mappings_ut.f90 \ sf_pdf_builtin_uti.f90 \ sf_pdf_builtin_ut.f90 \ sf_lhapdf_uti.f90 \ sf_lhapdf_ut.f90 \ sf_isr_uti.f90 \ sf_isr_ut.f90 \ sf_epa_uti.f90 \ sf_epa_ut.f90 \ sf_ewa_uti.f90 \ sf_ewa_ut.f90 \ sf_circe1_uti.f90 \ sf_circe1_ut.f90 \ sf_circe2_uti.f90 \ sf_circe2_ut.f90 \ sf_gaussian_uti.f90 \ sf_gaussian_ut.f90 \ sf_beam_events_uti.f90 \ sf_beam_events_ut.f90 \ sf_escan_uti.f90 \ sf_escan_ut.f90 \ phs_base_uti.f90 \ phs_base_ut.f90 \ phs_none_uti.f90 \ phs_none_ut.f90 \ phs_single_uti.f90 \ phs_single_ut.f90 \ phs_rambo_uti.f90 \ phs_rambo_ut.f90 \ phs_wood_uti.f90 \ phs_wood_ut.f90 \ phs_fks_uti.f90 \ phs_fks_ut.f90 \ fks_regions_uti.f90 \ fks_regions_ut.f90 \ mci_midpoint.f90 \ mci_base_uti.f90 \ mci_base_ut.f90 \ mci_midpoint_uti.f90 \ mci_midpoint_ut.f90 \ kinematics.f90 \ instances.f90 \ mci_none.f90 \ mci_none_uti.f90 \ mci_none_ut.f90 \ processes_uti.f90 \ processes_ut.f90 \ process_stacks_uti.f90 \ process_stacks_ut.f90 \ prc_recola_uti.f90 \ prc_recola_ut.f90 \ rng_tao_uti.f90 \ rng_tao_ut.f90 \ rng_stream_uti.f90 \ rng_stream_ut.f90 \ selectors_uti.f90 \ selectors_ut.f90 \ vegas.f90 \ vegas_uti.f90 \ vegas_ut.f90 \ vamp2.f90 \ vamp2_uti.f90 \ vamp2_ut.f90 \ exceptions.f90 \ vamp_stat.f90 \ utils.f90 \ divisions.f90 \ linalg.f90 \ vamp.f90 \ mci_vamp.f90 \ mci_vamp_uti.f90 \ mci_vamp_ut.f90 \ mci_vamp2.f90 \ mci_vamp2_uti.f90 \ mci_vamp2_ut.f90 \ prclib_interfaces_uti.f90 \ prclib_interfaces_ut.f90 \ particle_specifiers_uti.f90 \ particle_specifiers_ut.f90 \ process_libraries_uti.f90 \ process_libraries_ut.f90 \ prclib_stacks_uti.f90 \ prclib_stacks_ut.f90 \ slha_interface.f90 \ slha_interface_sub.f90 \ slha_interface_uti.f90 \ slha_interface_ut.f90 \ cascades_uti.f90 \ cascades_ut.f90 \ prc_test_uti.f90 \ prc_test_ut.f90 \ prc_template_me_uti.f90 \ prc_template_me_ut.f90 \ prc_omega_uti.f90 \ prc_omega_ut.f90 \ event_transforms.f90 \ event_transforms_uti.f90 \ event_transforms_ut.f90 \ hep_common.f90 \ hep_common_sub.f90 \ hepev4_aux.f90 \ tauola_dummy.f90 \ tauola_interface.f90 \ tauola_interface_sub.f90 \ shower_base.f90 \ shower_base_sub.f90 \ shower_partons.f90 \ shower_partons_sub.f90 \ muli.f90 \ matching_base.f90 \ powheg_matching.f90 \ shower_core.f90 \ shower_core_sub.f90 \ shower_base_uti.f90 \ shower_base_ut.f90 \ shower.f90 \ shower_uti.f90 \ shower_ut.f90 \ shower_pythia6.f90 \ shower_pythia6_sub.f90 \ whizard_lha.f90 \ whizard_lha_uti.f90 \ whizard_lha_ut.f90 \ LHAWhizard_dummy.f90 \ Pythia8Wrap_dummy.f90 \ pythia8.f90 \ pythia8_uti.f90 \ pythia8_ut.f90 \ shower_pythia8.f90 \ shower_pythia8_sub.f90 \ hadrons.f90 \ ktclus.f90 \ mlm_matching.f90 \ ckkw_matching.f90 \ jets_uti.f90 \ jets_ut.f90 \ pdg_arrays_uti.f90 \ pdg_arrays_ut.f90 \ interactions_uti.f90 \ interactions_ut.f90 \ decays.f90 \ decays_uti.f90 \ decays_ut.f90 \ evt_nlo.f90 \ events.f90 \ events_uti.f90 \ events_ut.f90 \ HepMCWrap_dummy.f90 \ hepmc_interface.f90 \ hepmc_interface_sub.f90 \ hepmc_interface_uti.f90 \ hepmc_interface_ut.f90 \ LCIOWrap_dummy.f90 \ lcio_interface.f90 \ lcio_interface_sub.f90 \ lcio_interface_uti.f90 \ lcio_interface_ut.f90 \ hep_events.f90 \ hep_events_sub.f90 \ hep_events_uti.f90 \ hep_events_ut.f90 \ expr_tests_uti.f90 \ expr_tests_ut.f90 \ parton_states_uti.f90 \ parton_states_ut.f90 \ eio_data_uti.f90 \ eio_data_ut.f90 \ eio_raw.f90 \ eio_raw_uti.f90 \ eio_raw_ut.f90 \ eio_checkpoints.f90 \ eio_checkpoints_sub.f90 \ eio_checkpoints_uti.f90 \ eio_checkpoints_ut.f90 \ eio_lhef.f90 \ eio_lhef_sub.f90 \ eio_lhef_uti.f90 \ eio_lhef_ut.f90 \ eio_hepmc.f90 \ eio_hepmc_sub.f90 \ eio_hepmc_uti.f90 \ eio_hepmc_ut.f90 \ eio_lcio.f90 \ eio_lcio_sub.f90 \ eio_lcio_uti.f90 \ eio_lcio_ut.f90 \ stdhep_dummy.f90 \ xdr_wo_stdhep.f90 \ eio_stdhep.f90 \ eio_stdhep_sub.f90 \ eio_stdhep_uti.f90 \ eio_stdhep_ut.f90 \ eio_ascii.f90 \ eio_ascii_sub.f90 \ eio_ascii_uti.f90 \ eio_ascii_ut.f90 \ eio_weights.f90 \ eio_weights_sub.f90 \ eio_weights_uti.f90 \ eio_weights_ut.f90 \ eio_dump.f90 \ eio_dump_sub.f90 \ eio_dump_uti.f90 \ eio_dump_ut.f90 \ eio_callback.f90 \ eio_callback_sub.f90 \ real_subtraction_uti.f90 \ real_subtraction_ut.f90 \ iterations_uti.f90 \ iterations_ut.f90 \ rt_data_uti.f90 \ rt_data_ut.f90 \ dispatch_mci.f90 \ dispatch_mci_uti.f90 \ dispatch_mci_ut.f90 \ dispatch_phs_uti.f90 \ dispatch_phs_ut.f90 \ resonance_insertion.f90 \ resonance_insertion_uti.f90 \ resonance_insertion_ut.f90 \ recoil_kinematics.f90 \ recoil_kinematics_uti.f90 \ recoil_kinematics_ut.f90 \ isr_epa_handler.f90 \ isr_epa_handler_uti.f90 \ isr_epa_handler_ut.f90 \ dispatch_transforms.f90 \ dispatch_transforms_uti.f90 \ dispatch_transforms_ut.f90 \ beam_structures_uti.f90 \ beam_structures_ut.f90 \ process_configurations.f90 \ process_configurations_uti.f90 \ process_configurations_ut.f90 \ compilations.f90 \ compilations_uti.f90 \ compilations_ut.f90 \ integrations.f90 \ integrations_uti.f90 \ integrations_ut.f90 \ event_streams.f90 \ event_streams_uti.f90 \ event_streams_ut.f90 \ restricted_subprocesses.f90 \ eio_direct.f90 \ eio_direct_sub.f90 \ eio_direct_uti.f90 \ eio_direct_ut.f90 \ simulations.f90 \ restricted_subprocesses_uti.f90 \ restricted_subprocesses_ut.f90 \ simulations_uti.f90 \ simulations_ut.f90 \ commands.f90 \ commands_uti.f90 \ commands_ut.f90 \ cmdline_options.f90 \ libmanager.f90 \ features.f90 \ whizard.f90 \ api.f90 \ api_hepmc_uti.f90 \ api_hepmc_ut.f90 \ api_lcio_uti.f90 \ api_lcio_ut.f90 \ api_uti.f90 \ api_ut.f90 FC_OBJ = $(FC0_SRC:.f90=.o) $(F77_SRC:.f=.o) $(FC_SRC:.f90=.o) CC_OBJ = $(CC_SRC:.c=.o) all: whizard_test check: whizard_test ./whizard_test --check resonances whizard_test: $(FC_OBJ) $(CC_OBJ) main_ut.f90 $(FC) $(FC_OBJ) $(CC_OBJ) -ldl -o $@ main_ut.f90 whizard: $(FC_OBJ) $(CC_OBJ) main.f90 $(FC) $(FC_OBJ) $(CC_OBJ) -ldl -o $@ main.f90 %.o: %.f90 $(FC) $(FCFLAGS) -c $< %.o: %.f $(FC) $(FCFLAGS) -c $< %.o: %.c $(CC) $(CCFLAGS) -c $< tar: $(FC_SRC) $(F77_SRC) $(FC0_SRC) $(CC_SRC) $(MODELS) tar cvvzf whizard-`date +%y%m%d`-`date +%H%M`.tar.gz $(FC_SRC) $(FC0_SRC) \ $(F77_SRC) $(CC_SRC) main_ut.f90 Makefile $(MODELS) clean: rm -f *.mod *.o whizard_test