Index: trunk/src/variables/Makefile.am =================================================================== --- trunk/src/variables/Makefile.am (revision 8782) +++ trunk/src/variables/Makefile.am (revision 8783) @@ -1,195 +1,208 @@ ## 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 objects and methods ## as they appear in the Sindarin language ## We create a library which is still to be combined with auxiliary libs. noinst_LTLIBRARIES = libvariables.la libvariables_la_SOURCES = \ + $(VARIABLES_MODULES) \ + $(VARIABLES_SUBMODULES) + +VARIABLES_MODULES = \ variables.f90 \ observables.f90 +VARIABLES_SUBMODULES = \ + variables_sub.f90 \ + observables_sub.f90 + ## Omitting this would exclude it from the distribution dist_noinst_DATA = variables.nw # Modules and installation # Dump module names into file Modules execmoddir = $(fmoddir)/whizard nodist_execmod_HEADERS = \ - ${libvariables_la_SOURCES:.f90=.$(FCMOD)} + ${VARIABLES_MODULES:.f90=.$(FCMOD)} # Dump module names into file Modules -libvariables_Modules = ${libvariables_la_SOURCES:.f90=} +# Submodules must not be included here +libvariables_Modules = ${VARIABLES_MODULES:.f90=} Modules: Makefile @for module in $(libvariables_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 \ ../expr_base/Modules \ ../physics/Modules \ ../types/Modules $(module_lists): $(MAKE) -C `dirname $@` Modules Module_dependencies.sed: $(libvariables_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: $(libvariables_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../physics -I../expr_base -I../fastjet -I../types +######################################################################## +# For the moment, the submodule dependencies will be hard-coded +variables_sub.lo: variables.lo +observables_sub.lo: observables.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 ## Dependencies across directories and packages, if not automatically generated $(libvariables_la_OBJECTS): \ ../fastjet/fastjet.$(FCMOD) ## (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 variables.stamp: $(PRELUDE) $(srcdir)/variables.nw $(POSTLUDE) @rm -f variables.tmp @touch variables.tmp for src in $(libvariables_la_SOURCES); do \ $(NOTANGLE) -R[[$$src]] $^ | $(CPIF) $$src; \ done @mv -f variables.tmp variables.stamp $(libvariables_la_SOURCES): variables.stamp ## Recover from the removal of $@ @if test -f $@; then :; else \ rm -f variables.stamp; \ $(MAKE) $(AM_MAKEFLAGS) variables.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 variables.stamp variables.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/variables/variables.nw =================================================================== --- trunk/src/variables/variables.nw (revision 8782) +++ trunk/src/variables/variables.nw (revision 8783) @@ -1,7054 +1,7741 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: variables for processes %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Variables for Processes} \includemodulegraph{variables} This part introduces variables as user-controlled objects that influence the behavior of objects and calculations. Variables contain objects of intrinsic type or of a type as introced above. \begin{description} \item[variables] Store values of various kind, used by expressions and accessed by the command interface. This provides an implementation of the [[vars_t]] abstract type. \item[observables] Concrete implementation of observables (functions in the variable tree), applicable for \whizard. abstract type. \end{description} \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Variables: Implementation} The user interface deals with variables that are handled similarly to full-flegded programming languages. The system will add a lot of predefined variables (model parameters, flags, etc.) that are accessible to the user by the same methods. Variables can be of various type: logical (boolean/flag), integer, real (default precision), subevents (used in cut expressions), arrays of PDG codes (aliases for particles), strings. Furthermore, in cut expressions we have unary and binary observables, which are used like real parameters but behave like functions. <<[[variables.f90]]>>= <> module variables <> <> - use io_units use numeric_utils, only: pacify - use format_utils, only: pac_fmt - use format_defs, only: FMT_12, FMT_19 - use constants, only: eps0 use os_interface, only: paths_t - use physics_defs, only: LAMBDA_QCD_REF - use system_dependencies - use fastjet !NODEP! - use diagnostics use pdg_arrays use subevents - use var_base <> <> <> <> <> + interface +<> + end interface + +end module variables +@ %def variables +@ +<<[[variables_sub.f90]]>>= +<> + +submodule (variables) variables_s + + use io_units + use format_utils, only: pac_fmt + use format_defs, only: FMT_12, FMT_19 + use constants, only: eps0 + use physics_defs, only: LAMBDA_QCD_REF + use system_dependencies + use diagnostics + use fastjet !NODEP! + + implicit none + contains <> -end module variables -@ %def variables +end submodule variables_s + +@ %def variables_s @ \subsection{Variable list entries} Variable (and constant) values can be of one of the following types: <>= integer, parameter, public :: V_NONE = 0, V_LOG = 1, V_INT = 2, V_REAL = 3 integer, parameter, public :: V_CMPLX = 4, V_SEV = 5, V_PDG = 6, V_STR = 7 integer, parameter, public :: V_OBS1_INT = 11, V_OBS2_INT = 12 integer, parameter, public :: V_OBS1_REAL = 21, V_OBS2_REAL = 22 integer, parameter, public :: V_OBSEV_INT = 13, V_OBSEV_REAL = 23 integer, parameter, public :: V_UOBS1_INT = 31, V_UOBS2_INT = 32 integer, parameter, public :: V_UOBS1_REAL = 41, V_UOBS2_REAL = 42 @ %def V_NONE V_LOG V_INT V_REAL V_CMPLX V_PRT V_SEV V_PDG V_OBS1_INT @ %def V_OBS2_INT V_OBSEV_INT V_OBS1_REAL V_OBS2_REAL V_OBSEV_REAL @ %def V_UOBS1_INT V_UOBS2_INT V_UOBS1_REAL V_UOBS2_REAL @ \subsubsection{The type} This is an entry in the variable list. It can be of any type; in each case only one value is allocated. It may be physically allocated upon creation, in which case [[is_allocated]] is true, or it may contain just a pointer to a value somewhere else, in which case [[is_allocated]] is false. The flag [[is_defined]] is set when the variable is given a value, even the undefined value. (Therefore it is distinct from [[is_known]].) This matters for variable declaration in the SINDARIN language. The variable is set up in the compilation step and initially marked as defined, but after compilation all variables are set undefined. Each variable becomes defined when it is explicitly set. The difference matters in loops. [[is_locked]] means that it cannot be given a value using the interface routines [[var_list_set_XXX]] below. It can only be initialized, or change automatically due to a side effect. [[is_copy]] means that this is a local copy of a global variable. The copy has a pointer to the original, which can be used to restore a previous value. [[is_intrinsic]] means that this variable is defined by the program, not by the user. Intrinsic variables cannot be (re)declared, but their values can be reset unless they are locked. [[is_user_var]] means that the variable has been declared by the user. It could be a new variable, or a local copy of an intrinsic variable. The flag [[is_known]] is a pointer which parallels the use of the value pointer. For pointer variables, it is set if the value should point to a known value. For ordinary variables, it should be true. The value is implemented as a set of alternative type-specific pointers. This emulates polymorphism, and it allows for actual pointer variables. Observable-type variables have function pointers as values, so they behave like macros. The functions make use of the particle objects accessible via the pointers [[prt1]] and [[prt2]]. Finally, the [[next]] pointer indicates that we are making lists of variables. A more efficient implementation might switch to hashes or similar; the current implementation has $O(N)$ lookup. -<>= - public :: var_entry_t <>= type :: var_entry_t private integer :: type = V_NONE type(string_t) :: name logical :: is_allocated = .false. logical :: is_defined = .false. logical :: is_locked = .false. logical :: is_intrinsic = .false. logical :: is_user_var = .false. logical, pointer :: is_known => null () logical, pointer :: lval => null () integer, pointer :: ival => null () real(default), pointer :: rval => null () complex(default), pointer :: cval => null () type(subevt_t), pointer :: pval => null () type(pdg_array_t), pointer :: aval => null () type(string_t), pointer :: sval => null () procedure(obs_unary_int), nopass, pointer :: obs1_int => null () procedure(obs_unary_real), nopass, pointer :: obs1_real => null () procedure(obs_binary_int), nopass, pointer :: obs2_int => null () procedure(obs_binary_real), nopass, pointer :: obs2_real => null () procedure(obs_sev_int), nopass, pointer :: obsev_int => null () procedure(obs_sev_real), nopass, pointer :: obsev_real => null () type(prt_t), pointer :: prt1 => null () type(prt_t), pointer :: prt2 => null () type(var_entry_t), pointer :: next => null () type(var_entry_t), pointer :: previous => null () type(string_t) :: description end type var_entry_t @ %def var_entry_t @ \subsubsection{Interfaces for the observable functions} <>= public :: obs_unary_int public :: obs_unary_real public :: obs_binary_int public :: obs_binary_real public :: obs_sev_int public :: obs_sev_real <>= abstract interface function obs_unary_int (prt1) result (ival) import integer :: ival type(prt_t), intent(in) :: prt1 end function obs_unary_int end interface abstract interface function obs_unary_real (prt1) result (rval) import real(default) :: rval type(prt_t), intent(in) :: prt1 end function obs_unary_real end interface abstract interface function obs_binary_int (prt1, prt2) result (ival) import integer :: ival type(prt_t), intent(in) :: prt1, prt2 end function obs_binary_int end interface abstract interface function obs_binary_real (prt1, prt2) result (rval) import real(default) :: rval type(prt_t), intent(in) :: prt1, prt2 end function obs_binary_real end interface abstract interface function obs_sev_int (sev) result (ival) import integer :: ival type(subevt_t), intent(in) :: sev end function obs_sev_int end interface abstract interface function obs_sev_real (sev) result (rval) import real(default) :: rval type(subevt_t), intent(in) :: sev end function obs_sev_real end interface @ %def obs_unary_int obs_unary_real @ %def obs_binary_int obs_binary_real @ %def obs_sev_int obs_sev_real @ \subsubsection{Initialization} Initialize an entry, optionally with a physical value. We also allocate the [[is_known]] flag and set it if the value is set. -<>= - public :: var_entry_init_int <>= subroutine var_entry_init_log (var, name, lval, intrinsic, user) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name logical, intent(in), optional :: lval logical, intent(in), optional :: intrinsic, user var%name = name var%type = V_LOG allocate (var%lval, var%is_known) if (present (lval)) then var%lval = lval var%is_defined = .true. var%is_known = .true. else var%is_known = .false. end if if (present (intrinsic)) var%is_intrinsic = intrinsic if (present (user)) var%is_user_var = user var%is_allocated = .true. end subroutine var_entry_init_log subroutine var_entry_init_int (var, name, ival, intrinsic, user) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name integer, intent(in), optional :: ival logical, intent(in), optional :: intrinsic, user var%name = name var%type = V_INT allocate (var%ival, var%is_known) if (present (ival)) then var%ival = ival var%is_defined = .true. var%is_known = .true. else var%is_known = .false. end if if (present (intrinsic)) var%is_intrinsic = intrinsic if (present (user)) var%is_user_var = user var%is_allocated = .true. end subroutine var_entry_init_int subroutine var_entry_init_real (var, name, rval, intrinsic, user) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name real(default), intent(in), optional :: rval logical, intent(in), optional :: intrinsic, user var%name = name var%type = V_REAL allocate (var%rval, var%is_known) if (present (rval)) then var%rval = rval var%is_defined = .true. var%is_known = .true. else var%is_known = .false. end if if (present (intrinsic)) var%is_intrinsic = intrinsic if (present (user)) var%is_user_var = user var%is_allocated = .true. end subroutine var_entry_init_real subroutine var_entry_init_cmplx (var, name, cval, intrinsic, user) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name complex(default), intent(in), optional :: cval logical, intent(in), optional :: intrinsic, user var%name = name var%type = V_CMPLX allocate (var%cval, var%is_known) if (present (cval)) then var%cval = cval var%is_defined = .true. var%is_known = .true. else var%is_known = .false. end if if (present (intrinsic)) var%is_intrinsic = intrinsic if (present (user)) var%is_user_var = user var%is_allocated = .true. end subroutine var_entry_init_cmplx subroutine var_entry_init_subevt (var, name, pval, intrinsic, user) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name type(subevt_t), intent(in), optional :: pval logical, intent(in), optional :: intrinsic, user var%name = name var%type = V_SEV allocate (var%pval, var%is_known) if (present (pval)) then var%pval = pval var%is_defined = .true. var%is_known = .true. else var%is_known = .false. end if if (present (intrinsic)) var%is_intrinsic = intrinsic if (present (user)) var%is_user_var = user var%is_allocated = .true. end subroutine var_entry_init_subevt subroutine var_entry_init_pdg_array (var, name, aval, intrinsic, user) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name type(pdg_array_t), intent(in), optional :: aval logical, intent(in), optional :: intrinsic, user var%name = name var%type = V_PDG allocate (var%aval, var%is_known) if (present (aval)) then var%aval = aval var%is_defined = .true. var%is_known = .true. else var%is_known = .false. end if if (present (intrinsic)) var%is_intrinsic = intrinsic if (present (user)) var%is_user_var = user var%is_allocated = .true. end subroutine var_entry_init_pdg_array subroutine var_entry_init_string (var, name, sval, intrinsic, user) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name type(string_t), intent(in), optional :: sval logical, intent(in), optional :: intrinsic, user var%name = name var%type = V_STR allocate (var%sval, var%is_known) if (present (sval)) then var%sval = sval var%is_defined = .true. var%is_known = .true. else var%is_known = .false. end if if (present (intrinsic)) var%is_intrinsic = intrinsic if (present (user)) var%is_user_var = user var%is_allocated = .true. end subroutine var_entry_init_string @ %def var_entry_init_log @ %def var_entry_init_int @ %def var_entry_init_real @ %def var_entry_init_cmplx @ %def var_entry_init_subevt @ %def var_entry_init_pdg_array @ %def var_entry_init_string @ Initialize an entry with a pointer to the value and, for numeric/logical values, a pointer to the [[is_known]] flag. <>= subroutine var_entry_init_log_ptr (var, name, lval, is_known, intrinsic) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name logical, intent(in), target :: lval logical, intent(in), target :: is_known logical, intent(in), optional :: intrinsic var%name = name var%type = V_LOG var%lval => lval var%is_known => is_known if (present (intrinsic)) var%is_intrinsic = intrinsic var%is_defined = .true. end subroutine var_entry_init_log_ptr subroutine var_entry_init_int_ptr (var, name, ival, is_known, intrinsic) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name integer, intent(in), target :: ival logical, intent(in), target :: is_known logical, intent(in), optional :: intrinsic var%name = name var%type = V_INT var%ival => ival var%is_known => is_known if (present (intrinsic)) var%is_intrinsic = intrinsic var%is_defined = .true. end subroutine var_entry_init_int_ptr subroutine var_entry_init_real_ptr (var, name, rval, is_known, intrinsic) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name real(default), intent(in), target :: rval logical, intent(in), target :: is_known logical, intent(in), optional :: intrinsic var%name = name var%type = V_REAL var%rval => rval var%is_known => is_known if (present (intrinsic)) var%is_intrinsic = intrinsic var%is_defined = .true. end subroutine var_entry_init_real_ptr subroutine var_entry_init_cmplx_ptr (var, name, cval, is_known, intrinsic) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name complex(default), intent(in), target :: cval logical, intent(in), target :: is_known logical, intent(in), optional :: intrinsic var%name = name var%type = V_CMPLX var%cval => cval var%is_known => is_known if (present (intrinsic)) var%is_intrinsic = intrinsic var%is_defined = .true. end subroutine var_entry_init_cmplx_ptr subroutine var_entry_init_pdg_array_ptr (var, name, aval, is_known, intrinsic) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name type(pdg_array_t), intent(in), target :: aval logical, intent(in), target :: is_known logical, intent(in), optional :: intrinsic var%name = name var%type = V_PDG var%aval => aval var%is_known => is_known if (present (intrinsic)) var%is_intrinsic = intrinsic var%is_defined = .true. end subroutine var_entry_init_pdg_array_ptr subroutine var_entry_init_subevt_ptr (var, name, pval, is_known, intrinsic) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name type(subevt_t), intent(in), target :: pval logical, intent(in), target :: is_known logical, intent(in), optional :: intrinsic var%name = name var%type = V_SEV var%pval => pval var%is_known => is_known if (present (intrinsic)) var%is_intrinsic = intrinsic var%is_defined = .true. end subroutine var_entry_init_subevt_ptr subroutine var_entry_init_string_ptr (var, name, sval, is_known, intrinsic) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name type(string_t), intent(in), target :: sval logical, intent(in), target :: is_known logical, intent(in), optional :: intrinsic var%name = name var%type = V_STR var%sval => sval var%is_known => is_known if (present (intrinsic)) var%is_intrinsic = intrinsic var%is_defined = .true. end subroutine var_entry_init_string_ptr @ %def var_entry_init_log_ptr @ %def var_entry_init_int_ptr @ %def var_entry_init_real_ptr @ %def var_entry_init_cmplx_ptr @ %def var_entry_init_pdg_array_ptr @ %def var_entry_init_subevt_ptr @ %def var_entry_init_string_ptr @ Initialize an entry with an observable. The procedure pointer is not yet set. <>= subroutine var_entry_init_obs (var, name, type, prt1, prt2) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name integer, intent(in) :: type type(prt_t), intent(in), target :: prt1 type(prt_t), intent(in), optional, target :: prt2 var%type = type var%name = name var%prt1 => prt1 if (present (prt2)) var%prt2 => prt2 var%is_intrinsic = .true. var%is_defined = .true. end subroutine var_entry_init_obs subroutine var_entry_init_obs_sev (var, name, type, pval) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name integer, intent(in) :: type type(subevt_t), intent(in), target :: pval var%type = type var%name = name var%pval => pval var%is_intrinsic = .true. var%is_defined = .true. end subroutine var_entry_init_obs_sev @ %def var_entry_init_obs var_entry_init_obs_sev @ Mark an entry as undefined it it is a user-defined variable object, so force re-initialization. <>= subroutine var_entry_undefine (var) type(var_entry_t), intent(inout) :: var var%is_defined = .not. var%is_user_var var%is_known = var%is_defined .and. var%is_known end subroutine var_entry_undefine @ %def var_entry_undefine @ Clear an entry: mark it as unknown. <>= subroutine var_entry_clear (var) type(var_entry_t), intent(inout) :: var var%is_known = .false. end subroutine var_entry_clear @ %def var_entry_clear @ Lock an entry: forbid resetting the entry after initialization. <>= subroutine var_entry_lock (var, locked) type(var_entry_t), intent(inout) :: var logical, intent(in), optional :: locked if (present (locked)) then var%is_locked = locked else var%is_locked = .true. end if end subroutine var_entry_lock @ %def var_entry_lock @ \subsubsection{Finalizer} <>= subroutine var_entry_final (var) type(var_entry_t), intent(inout) :: var if (var%is_allocated) then select case (var%type) case (V_LOG); deallocate (var%lval) case (V_INT); deallocate (var%ival) case (V_REAL);deallocate (var%rval) case (V_CMPLX);deallocate (var%cval) case (V_SEV); deallocate (var%pval) case (V_PDG); deallocate (var%aval) case (V_STR); deallocate (var%sval) end select deallocate (var%is_known) var%is_allocated = .false. var%is_defined = .false. end if end subroutine var_entry_final @ %def var_entry_final @ \subsubsection{Output} <>= recursive subroutine var_entry_write (var, unit, model_name, & intrinsic, pacified, descriptions, ascii_output) type(var_entry_t), intent(in) :: var integer, intent(in), optional :: unit type(string_t), intent(in), optional :: model_name logical, intent(in), optional :: intrinsic logical, intent(in), optional :: pacified logical, intent(in), optional :: descriptions logical, intent(in), optional :: ascii_output type(string_t) :: col_string logical :: show_desc, ao integer :: u u = given_output_unit (unit); if (u < 0) return show_desc = .false.; if (present (descriptions)) show_desc = descriptions ao = .false.; if (present (ascii_output)) ao = ascii_output if (show_desc) then if (ao) then col_string = create_col_string (COL_BLUE) if (var%is_locked) then write (u, "(A)", advance="no") char (achar(27) // col_string) // & char (var%name) // achar(27) // "[0m" //" fixed-value=" else write (u, "(A)", advance="no") char (achar(27) // col_string) // & char (var%name) // achar(27) // "[0m" //" default=" end if col_string = create_col_string (COL_RED) write (u, "(A)", advance="no") char (achar(27) // col_string) call var_write_val (var, u, "no", pacified=.true.) write (u, "(A)") achar(27) // "[0m" write (u, "(A)") char (var%description) return else write (u, "(A)") "\item" write (u, "(A)", advance="no") "\ttt{" // char ( & replace (replace (var%name, "_", "\_", every=.true.), "$", "\$" )) // & "} " if (var%is_known) then if (var%is_locked) then write (u, "(A)", advance="no") "\qquad (fixed value: \ttt{" else write (u, "(A)", advance="no") "\qquad (default: \ttt{" end if call var_write_val (var, u, "no", pacified=.true., escape_tex=.true.) write (u, "(A)", advance="no") "})" end if write (u, "(A)") " \newline" write (u, "(A)") char (var%description) write (u, "(A)") "%%%%%" return end if end if if (present (intrinsic)) then if (var%is_intrinsic .neqv. intrinsic) return end if if (.not. var%is_defined) then write (u, "(A,1x)", advance="no") "[undefined]" end if if (.not. var%is_intrinsic) then write (u, "(A,1x)", advance="no") "[user variable]" end if if (present (model_name)) then write (u, "(A,A)", advance="no") char(model_name), "." end if write (u, "(A)", advance="no") char (var%name) if (var%is_locked) write (u, "(A)", advance="no") "*" if (var%is_allocated) then write (u, "(A)", advance="no") " = " else if (var%type /= V_NONE) then write (u, "(A)", advance="no") " => " end if call var_write_val (var, u, "yes", pacified) end subroutine var_entry_write @ %def var_entry_write @ <>= subroutine var_write_val (var, u, advance, pacified, escape_tex) type(var_entry_t), intent(in) :: var integer, intent(in) :: u character(*), intent(in) :: advance logical, intent(in), optional :: pacified, escape_tex logical :: num_pac, et real(default) :: rval complex(default) :: cval character(len=7) :: fmt call pac_fmt (fmt, FMT_19, FMT_12, pacified) num_pac = .false.; if (present (pacified)) num_pac = pacified et = .false.; if (present (escape_tex)) et = escape_tex select case (var%type) case (V_NONE); write (u, '()', advance=advance) case (V_LOG) if (var%is_known) then if (var%lval) then write (u, "(A)", advance=advance) "true" else write (u, "(A)", advance=advance) "false" end if else write (u, "(A)", advance=advance) "[unknown logical]" end if case (V_INT) if (var%is_known) then write (u, "(I0)", advance=advance) var%ival else write (u, "(A)", advance=advance) "[unknown integer]" end if case (V_REAL) if (var%is_known) then rval = var%rval if (num_pac) then call pacify (rval, 10 * eps0) end if write (u, "(" // fmt // ")", advance=advance) rval else write (u, "(A)", advance=advance) "[unknown real]" end if case (V_CMPLX) if (var%is_known) then cval = var%cval if (num_pac) then call pacify (cval, 10 * eps0) end if write (u, "('('," // fmt // ",','," // fmt // ",')')", advance=advance) cval else write (u, "(A)", advance=advance) "[unknown complex]" end if case (V_SEV) if (var%is_known) then call var%pval%write (u, prefix=" ", pacified = pacified) else write (u, "(A)", advance=advance) "[unknown subevent]" end if case (V_PDG) if (var%is_known) then call var%aval%write (u); write (u, *) else write (u, "(A)", advance=advance) "[unknown PDG array]" end if case (V_STR) if (var%is_known) then if (et) then write (u, "(A)", advance=advance) '"' // char (replace ( & replace (var%sval, "_", "\_", every=.true.), "$", "\$" )) // '"' else write (u, "(A)", advance=advance) '"' // char (var%sval) // '"' end if else write (u, "(A)", advance=advance) "[unknown string]" end if case (V_OBS1_INT); write (u, "(A)", advance=advance) "[int] = unary observable" case (V_OBS2_INT); write (u, "(A)", advance=advance) "[int] = binary observable" case (V_OBSEV_INT); write (u, "(A)", advance=advance) "[int] = subeventary observable" case (V_OBS1_REAL); write (u, "(A)", advance=advance) "[real] = unary observable" case (V_OBS2_REAL); write (u, "(A)", advance=advance) "[real] = binary observable" case (V_OBSEV_REAL); write (u, "(A)", advance=advance) "[real] = subeventary observable" case (V_UOBS1_INT); write (u, "(A)", advance=advance) "[int] = unary user observable" case (V_UOBS2_INT); write (u, "(A)", advance=advance) "[int] = binary user observable" case (V_UOBS1_REAL); write (u, "(A)", advance=advance) "[real] = unary user observable" case (V_UOBS2_REAL); write (u, "(A)", advance=advance) "[real] = binary user observable" end select end subroutine var_write_val @ %def procedure @ \subsubsection{Accessing contents} <>= function var_entry_get_name (var) result (name) type(string_t) :: name type(var_entry_t), intent(in) :: var name = var%name end function var_entry_get_name function var_entry_get_type (var) result (type) integer :: type type(var_entry_t), intent(in) :: var type = var%type end function var_entry_get_type @ %def var_entry_get_name var_entry_get_type @ Return true if the variable is defined. This the case if it is allocated and known, or if it is a pointer. <>= function var_entry_is_defined (var) result (defined) logical :: defined type(var_entry_t), intent(in) :: var defined = var%is_defined end function var_entry_is_defined @ %def var_entry_is_defined @ Return true if the variable is locked. If [[force]] is active, always return false. <>= function var_entry_is_locked (var, force) result (locked) logical :: locked type(var_entry_t), intent(in) :: var logical, intent(in), optional :: force if (present (force)) then if (force) then locked = .false.; return end if end if locked = var%is_locked end function var_entry_is_locked @ %def var_entry_is_locked @ Return true if the variable is intrinsic <>= function var_entry_is_intrinsic (var) result (flag) logical :: flag type(var_entry_t), intent(in) :: var flag = var%is_intrinsic end function var_entry_is_intrinsic @ %def var_entry_is_intrinsic @ Return components <>= function var_entry_is_known (var) result (flag) logical :: flag type(var_entry_t), intent(in) :: var flag = var%is_known end function var_entry_is_known function var_entry_get_lval (var) result (lval) logical :: lval type(var_entry_t), intent(in) :: var lval = var%lval end function var_entry_get_lval function var_entry_get_ival (var) result (ival) integer :: ival type(var_entry_t), intent(in) :: var ival = var%ival end function var_entry_get_ival function var_entry_get_rval (var) result (rval) real(default) :: rval type(var_entry_t), intent(in) :: var rval = var%rval end function var_entry_get_rval function var_entry_get_cval (var) result (cval) complex(default) :: cval type(var_entry_t), intent(in) :: var cval = var%cval end function var_entry_get_cval function var_entry_get_aval (var) result (aval) type(pdg_array_t) :: aval type(var_entry_t), intent(in) :: var aval = var%aval end function var_entry_get_aval function var_entry_get_pval (var) result (pval) type(subevt_t) :: pval type(var_entry_t), intent(in) :: var pval = var%pval end function var_entry_get_pval function var_entry_get_sval (var) result (sval) type(string_t) :: sval type(var_entry_t), intent(in) :: var sval = var%sval end function var_entry_get_sval @ %def var_entry_get_lval @ %def var_entry_get_ival @ %def var_entry_get_rval @ %def var_entry_get_cval @ %def var_entry_get_aval @ %def var_entry_get_pval @ %def var_entry_get_sval @ Return pointers to components. <>= function var_entry_get_known_ptr (var) result (ptr) logical, pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%is_known end function var_entry_get_known_ptr function var_entry_get_lval_ptr (var) result (ptr) logical, pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%lval end function var_entry_get_lval_ptr function var_entry_get_ival_ptr (var) result (ptr) integer, pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%ival end function var_entry_get_ival_ptr function var_entry_get_rval_ptr (var) result (ptr) real(default), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%rval end function var_entry_get_rval_ptr function var_entry_get_cval_ptr (var) result (ptr) complex(default), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%cval end function var_entry_get_cval_ptr function var_entry_get_pval_ptr (var) result (ptr) type(subevt_t), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%pval end function var_entry_get_pval_ptr function var_entry_get_aval_ptr (var) result (ptr) type(pdg_array_t), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%aval end function var_entry_get_aval_ptr function var_entry_get_sval_ptr (var) result (ptr) type(string_t), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%sval end function var_entry_get_sval_ptr @ %def var_entry_get_known_ptr @ %def var_entry_get_lval_ptr var_entry_get_ival_ptr var_entry_get_rval_ptr @ %def var_entry_get_cval_ptr var_entry_get_aval_ptr var_entry_get_pval_ptr @ %def var_entry_get_sval_ptr @ Furthermore, <>= function var_entry_get_prt1_ptr (var) result (ptr) type(prt_t), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%prt1 end function var_entry_get_prt1_ptr function var_entry_get_prt2_ptr (var) result (ptr) type(prt_t), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%prt2 end function var_entry_get_prt2_ptr @ %def var_entry_get_prt1_ptr @ %def var_entry_get_prt2_ptr @ Subroutines might be safer than functions for procedure pointer transfer. <>= subroutine var_entry_assign_obs1_int_ptr (ptr, var) procedure(obs_unary_int), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%obs1_int end subroutine var_entry_assign_obs1_int_ptr subroutine var_entry_assign_obs1_real_ptr (ptr, var) procedure(obs_unary_real), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%obs1_real end subroutine var_entry_assign_obs1_real_ptr subroutine var_entry_assign_obs2_int_ptr (ptr, var) procedure(obs_binary_int), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%obs2_int end subroutine var_entry_assign_obs2_int_ptr subroutine var_entry_assign_obs2_real_ptr (ptr, var) procedure(obs_binary_real), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%obs2_real end subroutine var_entry_assign_obs2_real_ptr subroutine var_entry_assign_obsev_int_ptr (ptr, var) procedure(obs_sev_int), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%obsev_int end subroutine var_entry_assign_obsev_int_ptr subroutine var_entry_assign_obsev_real_ptr (ptr, var) procedure(obs_sev_real), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%obsev_real end subroutine var_entry_assign_obsev_real_ptr @ %def var_entry_assign_obs1_int_ptr var_entry_assign_obs1_real_ptr @ %def var_entry_assign_obs2_int_ptr var_entry_assign_obs2_real_ptr @ %def var_entry_assigbn_obsev_int_ptr var_entry_assign_obsev_real_ptr @ \subsection{Setting values} Undefine the value. <>= subroutine var_entry_clear_value (var) type(var_entry_t), intent(inout) :: var var%is_known = .false. end subroutine var_entry_clear_value @ %def var_entry_clear_value <>= recursive subroutine var_entry_set_log & (var, lval, is_known, verbose, model_name) type(var_entry_t), intent(inout) :: var logical, intent(in) :: lval logical, intent(in) :: is_known logical, intent(in), optional :: verbose type(string_t), intent(in), optional :: model_name integer :: u u = logfile_unit () var%lval = lval var%is_known = is_known var%is_defined = .true. if (present (verbose)) then if (verbose) then call var_entry_write (var, model_name=model_name) call var_entry_write (var, model_name=model_name, unit=u) if (u >= 0) flush (u) end if end if end subroutine var_entry_set_log recursive subroutine var_entry_set_int & (var, ival, is_known, verbose, model_name) type(var_entry_t), intent(inout) :: var integer, intent(in) :: ival logical, intent(in) :: is_known logical, intent(in), optional :: verbose type(string_t), intent(in), optional :: model_name integer :: u u = logfile_unit () var%ival = ival var%is_known = is_known var%is_defined = .true. if (present (verbose)) then if (verbose) then call var_entry_write (var, model_name=model_name) call var_entry_write (var, model_name=model_name, unit=u) if (u >= 0) flush (u) end if end if end subroutine var_entry_set_int recursive subroutine var_entry_set_real & (var, rval, is_known, verbose, model_name, pacified) type(var_entry_t), intent(inout) :: var real(default), intent(in) :: rval logical, intent(in) :: is_known logical, intent(in), optional :: verbose, pacified type(string_t), intent(in), optional :: model_name integer :: u u = logfile_unit () var%rval = rval var%is_known = is_known var%is_defined = .true. if (present (verbose)) then if (verbose) then call var_entry_write & (var, model_name=model_name, pacified = pacified) call var_entry_write & (var, model_name=model_name, unit=u, pacified = pacified) if (u >= 0) flush (u) end if end if end subroutine var_entry_set_real recursive subroutine var_entry_set_cmplx & (var, cval, is_known, verbose, model_name, pacified) type(var_entry_t), intent(inout) :: var complex(default), intent(in) :: cval logical, intent(in) :: is_known logical, intent(in), optional :: verbose, pacified type(string_t), intent(in), optional :: model_name integer :: u u = logfile_unit () var%cval = cval var%is_known = is_known var%is_defined = .true. if (present (verbose)) then if (verbose) then call var_entry_write & (var, model_name=model_name, pacified = pacified) call var_entry_write & (var, model_name=model_name, unit=u, pacified = pacified) if (u >= 0) flush (u) end if end if end subroutine var_entry_set_cmplx recursive subroutine var_entry_set_pdg_array & (var, aval, is_known, verbose, model_name) type(var_entry_t), intent(inout) :: var type(pdg_array_t), intent(in) :: aval logical, intent(in) :: is_known logical, intent(in), optional :: verbose type(string_t), intent(in), optional :: model_name integer :: u u = logfile_unit () var%aval = aval var%is_known = is_known var%is_defined = .true. if (present (verbose)) then if (verbose) then call var_entry_write (var, model_name=model_name) call var_entry_write (var, model_name=model_name, unit=u) if (u >= 0) flush (u) end if end if end subroutine var_entry_set_pdg_array recursive subroutine var_entry_set_subevt & (var, pval, is_known, verbose, model_name) type(var_entry_t), intent(inout) :: var type(subevt_t), intent(in) :: pval logical, intent(in) :: is_known logical, intent(in), optional :: verbose type(string_t), intent(in), optional :: model_name integer :: u u = logfile_unit () var%pval = pval var%is_known = is_known var%is_defined = .true. if (present (verbose)) then if (verbose) then call var_entry_write (var, model_name=model_name) call var_entry_write (var, model_name=model_name, unit=u) if (u >= 0) flush (u) end if end if end subroutine var_entry_set_subevt recursive subroutine var_entry_set_string & (var, sval, is_known, verbose, model_name) type(var_entry_t), intent(inout) :: var type(string_t), intent(in) :: sval logical, intent(in) :: is_known logical, intent(in), optional :: verbose type(string_t), intent(in), optional :: model_name integer :: u u = logfile_unit () var%sval = sval var%is_known = is_known var%is_defined = .true. if (present (verbose)) then if (verbose) then call var_entry_write (var, model_name=model_name) call var_entry_write (var, model_name=model_name, unit=u) if (u >= 0) flush (u) end if end if end subroutine var_entry_set_string @ %def var_entry_set_log @ %def var_entry_set_int @ %def var_entry_set_real @ %def var_entry_set_cmplx @ %def var_entry_set_pdg_array @ %def var_entry_set_subevt @ %def var_entry_set_string @ -<>= - public :: var_entry_set_description <>= pure subroutine var_entry_set_description (var_entry, description) type(var_entry_t), intent(inout) :: var_entry type(string_t), intent(in) :: description var_entry%description = description end subroutine var_entry_set_description @ %def var_entry_set_description @ \subsection{Copies and pointer variables} Initialize an entry with a copy of an existing variable entry. The copy is physically allocated with the same type as the original. <>= subroutine var_entry_init_copy (var, original, user) type(var_entry_t), intent(out) :: var type(var_entry_t), intent(in), target :: original logical, intent(in), optional :: user type(string_t) :: name logical :: intrinsic name = var_entry_get_name (original) intrinsic = original%is_intrinsic select case (original%type) case (V_LOG) call var_entry_init_log (var, name, intrinsic=intrinsic, user=user) case (V_INT) call var_entry_init_int (var, name, intrinsic=intrinsic, user=user) case (V_REAL) call var_entry_init_real (var, name, intrinsic=intrinsic, user=user) case (V_CMPLX) call var_entry_init_cmplx (var, name, intrinsic=intrinsic, user=user) case (V_SEV) call var_entry_init_subevt (var, name, intrinsic=intrinsic, user=user) case (V_PDG) call var_entry_init_pdg_array (var, name, intrinsic=intrinsic, user=user) case (V_STR) call var_entry_init_string (var, name, intrinsic=intrinsic, user=user) end select end subroutine var_entry_init_copy @ %def var_entry_init_copy @ Copy the value of an entry. The target variable entry must be initialized correctly. <>= subroutine var_entry_copy_value (var, original) type(var_entry_t), intent(inout) :: var type(var_entry_t), intent(in), target :: original if (var_entry_is_known (original)) then select case (original%type) case (V_LOG) call var_entry_set_log (var, var_entry_get_lval (original), .true.) case (V_INT) call var_entry_set_int (var, var_entry_get_ival (original), .true.) case (V_REAL) call var_entry_set_real (var, var_entry_get_rval (original), .true.) case (V_CMPLX) call var_entry_set_cmplx (var, var_entry_get_cval (original), .true.) case (V_SEV) call var_entry_set_subevt (var, var_entry_get_pval (original), .true.) case (V_PDG) call var_entry_set_pdg_array (var, var_entry_get_aval (original), .true.) case (V_STR) call var_entry_set_string (var, var_entry_get_sval (original), .true.) end select else call var_entry_clear (var) end if end subroutine var_entry_copy_value @ %def var_entry_copy_value @ \subsection{Variable lists} \subsubsection{The type} Variable lists can be linked together. No initializer needed. They are deleted separately. <>= public :: var_list_t <>= type, extends (vars_t) :: var_list_t private type(var_entry_t), pointer :: first => null () type(var_entry_t), pointer :: last => null () type(var_list_t), pointer :: next => null () contains <> end type var_list_t @ %def var_list_t @ \subsubsection{Constructors} Implementation of the [[link]] deferred method. The implementation restricts itself to var lists of the same type. We might need to relax this constraint. <>= procedure :: link => var_list_link +<>= + module subroutine var_list_link (vars, target_vars) + class(var_list_t), intent(inout) :: vars + class(vars_t), intent(in), target :: target_vars + end subroutine var_list_link <>= - subroutine var_list_link (vars, target_vars) + module subroutine var_list_link (vars, target_vars) class(var_list_t), intent(inout) :: vars class(vars_t), intent(in), target :: target_vars select type (target_vars) type is (var_list_t) vars%next => target_vars class default call msg_bug ("var_list_link: unsupported target type") end select end subroutine var_list_link @ %def var_list_link @ Append a new entry to an existing list. <>= subroutine var_list_append (var_list, var, verbose) type(var_list_t), intent(inout), target :: var_list type(var_entry_t), intent(inout), target :: var logical, intent(in), optional :: verbose if (associated (var_list%last)) then var%previous => var_list%last var_list%last%next => var else var%previous => null () var_list%first => var end if var_list%last => var if (present (verbose)) then if (verbose) call var_entry_write (var) end if end subroutine var_list_append @ %def var_list_append @ Sort a list. <>= procedure :: sort => var_list_sort +<>= + module subroutine var_list_sort (var_list) + class(var_list_t), intent(inout) :: var_list + end subroutine var_list_sort <>= - subroutine var_list_sort (var_list) + module subroutine var_list_sort (var_list) class(var_list_t), intent(inout) :: var_list type(var_entry_t), pointer :: var, previous if (associated (var_list%first)) then var => var_list%first do while (associated (var)) previous => var%previous do while (associated (previous)) if (larger_var (previous, var)) then call var_list%swap_with_next (previous) end if previous => previous%previous end do var => var%next end do end if end subroutine var_list_sort @ %def var_list_sort @ <>= pure function larger_var (var1, var2) result (larger) logical :: larger type(var_entry_t), intent(in) :: var1, var2 type(string_t) :: str1, str2 str1 = replace (var1%name, "?", "") str1 = replace (str1, "$", "") str2 = replace (var2%name, "?", "") str2 = replace (str2, "$", "") larger = str1 > str2 end function larger_var @ %def larger_var @ <>= procedure :: get_previous => var_list_get_previous +<>= + module function var_list_get_previous & + (var_list, var_entry) result (previous) + type(var_entry_t), pointer :: previous + class(var_list_t), intent(in) :: var_list + type(var_entry_t), intent(in) :: var_entry + end function var_list_get_previous <>= - function var_list_get_previous (var_list, var_entry) result (previous) + module function var_list_get_previous & + (var_list, var_entry) result (previous) type(var_entry_t), pointer :: previous class(var_list_t), intent(in) :: var_list type(var_entry_t), intent(in) :: var_entry previous => var_list%first if (previous%name == var_entry%name) then previous => null () else do while (associated (previous)) if (previous%next%name == var_entry%name) exit previous => previous%next end do end if end function var_list_get_previous @ %def var_list_get_previous @ <>= procedure :: swap_with_next => var_list_swap_with_next +<>= + module subroutine var_list_swap_with_next (var_list, var_entry) + class(var_list_t), intent(inout) :: var_list + type(var_entry_t), intent(in) :: var_entry + end subroutine var_list_swap_with_next <>= - subroutine var_list_swap_with_next (var_list, var_entry) + module subroutine var_list_swap_with_next (var_list, var_entry) class(var_list_t), intent(inout) :: var_list type(var_entry_t), intent(in) :: var_entry type(var_entry_t), pointer :: previous, this, next, next_next previous => var_list%get_previous (var_entry) if (.not. associated (previous)) then this => var_list%first else this => previous%next end if next => this%next next_next => next%next if (associated (previous)) then previous%next => next next%previous => previous else var_list%first => next next%previous => null () end if this%next => next_next if (associated (next_next)) then next_next%previous => this end if next%next => this this%previous => next if (.not. associated (next%next)) then var_list%last => next end if end subroutine var_list_swap_with_next @ %def var_list_swap_with_next @ Public methods for expanding the variable list (as subroutines) <>= generic :: append_log => var_list_append_log_s, var_list_append_log_c procedure, private :: var_list_append_log_s procedure, private :: var_list_append_log_c generic :: append_int => var_list_append_int_s, var_list_append_int_c procedure, private :: var_list_append_int_s procedure, private :: var_list_append_int_c generic :: append_real => var_list_append_real_s, var_list_append_real_c procedure, private :: var_list_append_real_s procedure, private :: var_list_append_real_c generic :: append_cmplx => var_list_append_cmplx_s, var_list_append_cmplx_c procedure, private :: var_list_append_cmplx_s procedure, private :: var_list_append_cmplx_c generic :: append_subevt => var_list_append_subevt_s, var_list_append_subevt_c procedure, private :: var_list_append_subevt_s procedure, private :: var_list_append_subevt_c generic :: append_pdg_array => var_list_append_pdg_array_s, var_list_append_pdg_array_c procedure, private :: var_list_append_pdg_array_s procedure, private :: var_list_append_pdg_array_c generic :: append_string => var_list_append_string_s, var_list_append_string_c procedure, private :: var_list_append_string_s procedure, private :: var_list_append_string_c -<>= - public :: var_list_append_log - public :: var_list_append_int - public :: var_list_append_real - public :: var_list_append_cmplx - public :: var_list_append_subevt - public :: var_list_append_pdg_array - public :: var_list_append_string <>= interface var_list_append_log module procedure var_list_append_log_s module procedure var_list_append_log_c end interface interface var_list_append_int module procedure var_list_append_int_s module procedure var_list_append_int_c end interface interface var_list_append_real module procedure var_list_append_real_s module procedure var_list_append_real_c end interface interface var_list_append_cmplx module procedure var_list_append_cmplx_s module procedure var_list_append_cmplx_c end interface interface var_list_append_subevt module procedure var_list_append_subevt_s module procedure var_list_append_subevt_c end interface interface var_list_append_pdg_array module procedure var_list_append_pdg_array_s module procedure var_list_append_pdg_array_c end interface interface var_list_append_string module procedure var_list_append_string_s module procedure var_list_append_string_c end interface +<>= + module subroutine var_list_append_log_s & + (var_list, name, lval, locked, verbose, intrinsic, user, description) + class(var_list_t), intent(inout) :: var_list + type(string_t), intent(in) :: name + logical, intent(in), optional :: lval + logical, intent(in), optional :: locked, verbose, intrinsic, user + type(string_t), intent(in), optional :: description + end subroutine var_list_append_log_s + module subroutine var_list_append_int_s & + (var_list, name, ival, locked, verbose, intrinsic, user, description) + class(var_list_t), intent(inout) :: var_list + type(string_t), intent(in) :: name + integer, intent(in), optional :: ival + logical, intent(in), optional :: locked, verbose, intrinsic, user + type(string_t), intent(in), optional :: description + end subroutine var_list_append_int_s + module subroutine var_list_append_real_s & + (var_list, name, rval, locked, verbose, intrinsic, user, description) + class(var_list_t), intent(inout) :: var_list + type(string_t), intent(in) :: name + real(default), intent(in), optional :: rval + logical, intent(in), optional :: locked, verbose, intrinsic, user + type(string_t), intent(in), optional :: description + end subroutine var_list_append_real_s + module subroutine var_list_append_cmplx_s & + (var_list, name, cval, locked, verbose, intrinsic, user, description) + class(var_list_t), intent(inout) :: var_list + type(string_t), intent(in) :: name + complex(default), intent(in), optional :: cval + logical, intent(in), optional :: locked, verbose, intrinsic, user + type(string_t), intent(in), optional :: description + end subroutine var_list_append_cmplx_s + module subroutine var_list_append_subevt_s & + (var_list, name, pval, locked, verbose, intrinsic, user, description) + class(var_list_t), intent(inout) :: var_list + type(string_t), intent(in) :: name + type(subevt_t), intent(in), optional :: pval + logical, intent(in), optional :: locked, verbose, intrinsic, user + type(string_t), intent(in), optional :: description + end subroutine var_list_append_subevt_s + module subroutine var_list_append_pdg_array_s & + (var_list, name, aval, locked, verbose, intrinsic, user, description) + class(var_list_t), intent(inout) :: var_list + type(string_t), intent(in) :: name + type(pdg_array_t), intent(in), optional :: aval + logical, intent(in), optional :: locked, verbose, intrinsic, user + type(string_t), intent(in), optional :: description + end subroutine var_list_append_pdg_array_s + module subroutine var_list_append_string_s & + (var_list, name, sval, locked, verbose, intrinsic, user, description) + class(var_list_t), intent(inout) :: var_list + type(string_t), intent(in) :: name + type(string_t), intent(in), optional :: sval + logical, intent(in), optional :: locked, verbose, intrinsic, user + type(string_t), intent(in), optional :: description + end subroutine var_list_append_string_s + module subroutine var_list_append_log_c & + (var_list, name, lval, locked, verbose, intrinsic, user, description) + class(var_list_t), intent(inout) :: var_list + character(*), intent(in) :: name + logical, intent(in), optional :: lval + logical, intent(in), optional :: locked, verbose, intrinsic, user + type(string_t), intent(in), optional :: description + end subroutine var_list_append_log_c + module subroutine var_list_append_int_c & + (var_list, name, ival, locked, verbose, intrinsic, user, description) + class(var_list_t), intent(inout) :: var_list + character(*), intent(in) :: name + integer, intent(in), optional :: ival + logical, intent(in), optional :: locked, verbose, intrinsic, user + type(string_t), intent(in), optional :: description + end subroutine var_list_append_int_c + module subroutine var_list_append_real_c & + (var_list, name, rval, locked, verbose, intrinsic, user, description) + class(var_list_t), intent(inout) :: var_list + character(*), intent(in) :: name + real(default), intent(in), optional :: rval + logical, intent(in), optional :: locked, verbose, intrinsic, user + type(string_t), intent(in), optional :: description + end subroutine var_list_append_real_c + module subroutine var_list_append_cmplx_c & + (var_list, name, cval, locked, verbose, intrinsic, user, description) + class(var_list_t), intent(inout) :: var_list + character(*), intent(in) :: name + complex(default), intent(in), optional :: cval + logical, intent(in), optional :: locked, verbose, intrinsic, user + type(string_t), intent(in), optional :: description + end subroutine var_list_append_cmplx_c + module subroutine var_list_append_subevt_c & + (var_list, name, pval, locked, verbose, intrinsic, user, description) + class(var_list_t), intent(inout) :: var_list + character(*), intent(in) :: name + type(subevt_t), intent(in), optional :: pval + logical, intent(in), optional :: locked, verbose, intrinsic, user + type(string_t), intent(in), optional :: description + end subroutine var_list_append_subevt_c + module subroutine var_list_append_pdg_array_c & + (var_list, name, aval, locked, verbose, intrinsic, user, description) + class(var_list_t), intent(inout) :: var_list + character(*), intent(in) :: name + type(pdg_array_t), intent(in), optional :: aval + logical, intent(in), optional :: locked, verbose, intrinsic, user + type(string_t), intent(in), optional :: description + end subroutine var_list_append_pdg_array_c + module subroutine var_list_append_string_c & + (var_list, name, sval, locked, verbose, intrinsic, user, description) + class(var_list_t), intent(inout) :: var_list + character(*), intent(in) :: name + character(*), intent(in), optional :: sval + logical, intent(in), optional :: locked, verbose, intrinsic, user + type(string_t), intent(in), optional :: description + end subroutine var_list_append_string_c <>= - subroutine var_list_append_log_s & + module subroutine var_list_append_log_s & (var_list, name, lval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name logical, intent(in), optional :: lval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_log (var, name, lval, intrinsic, user) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_log_s - subroutine var_list_append_int_s & + module subroutine var_list_append_int_s & (var_list, name, ival, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name integer, intent(in), optional :: ival logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_int (var, name, ival, intrinsic, user) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_int_s - subroutine var_list_append_real_s & + module subroutine var_list_append_real_s & (var_list, name, rval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name real(default), intent(in), optional :: rval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_real (var, name, rval, intrinsic, user) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_real_s - subroutine var_list_append_cmplx_s & + module subroutine var_list_append_cmplx_s & (var_list, name, cval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name complex(default), intent(in), optional :: cval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_cmplx (var, name, cval, intrinsic, user) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_cmplx_s - subroutine var_list_append_subevt_s & + module subroutine var_list_append_subevt_s & (var_list, name, pval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name type(subevt_t), intent(in), optional :: pval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_subevt (var, name, pval, intrinsic, user) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_subevt_s - subroutine var_list_append_pdg_array_s & + module subroutine var_list_append_pdg_array_s & (var_list, name, aval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name type(pdg_array_t), intent(in), optional :: aval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_pdg_array (var, name, aval, intrinsic, user) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_pdg_array_s - subroutine var_list_append_string_s & + module subroutine var_list_append_string_s & (var_list, name, sval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name type(string_t), intent(in), optional :: sval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_string (var, name, sval, intrinsic, user) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_string_s - subroutine var_list_append_log_c & + module subroutine var_list_append_log_c & (var_list, name, lval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list character(*), intent(in) :: name logical, intent(in), optional :: lval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description call var_list_append_log_s & (var_list, var_str (name), lval, locked, verbose, & intrinsic, user, description) end subroutine var_list_append_log_c - subroutine var_list_append_int_c & + module subroutine var_list_append_int_c & (var_list, name, ival, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list character(*), intent(in) :: name integer, intent(in), optional :: ival logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description call var_list_append_int_s & (var_list, var_str (name), ival, locked, verbose, & intrinsic, user, description) end subroutine var_list_append_int_c - subroutine var_list_append_real_c & + module subroutine var_list_append_real_c & (var_list, name, rval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list character(*), intent(in) :: name real(default), intent(in), optional :: rval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description call var_list_append_real_s & (var_list, var_str (name), rval, locked, verbose, & intrinsic, user, description) end subroutine var_list_append_real_c - subroutine var_list_append_cmplx_c & + module subroutine var_list_append_cmplx_c & (var_list, name, cval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list character(*), intent(in) :: name complex(default), intent(in), optional :: cval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description call var_list_append_cmplx_s & (var_list, var_str (name), cval, locked, verbose, & intrinsic, user, description) end subroutine var_list_append_cmplx_c - subroutine var_list_append_subevt_c & + module subroutine var_list_append_subevt_c & (var_list, name, pval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list character(*), intent(in) :: name type(subevt_t), intent(in), optional :: pval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description call var_list_append_subevt_s & (var_list, var_str (name), pval, locked, verbose, & intrinsic, user, description) end subroutine var_list_append_subevt_c - subroutine var_list_append_pdg_array_c & + module subroutine var_list_append_pdg_array_c & (var_list, name, aval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list character(*), intent(in) :: name type(pdg_array_t), intent(in), optional :: aval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description call var_list_append_pdg_array_s & (var_list, var_str (name), aval, locked, verbose, & intrinsic, user, description) end subroutine var_list_append_pdg_array_c - subroutine var_list_append_string_c & + module subroutine var_list_append_string_c & (var_list, name, sval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list character(*), intent(in) :: name character(*), intent(in), optional :: sval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description if (present (sval)) then call var_list_append_string_s & (var_list, var_str (name), var_str (sval), & locked, verbose, intrinsic, user, description) else call var_list_append_string_s & (var_list, var_str (name), & locked=locked, verbose=verbose, intrinsic=intrinsic, & user=user, description=description) end if end subroutine var_list_append_string_c @ %def var_list_append_log @ %def var_list_append_int @ %def var_list_append_real @ %def var_list_append_cmplx @ %def var_list_append_subevt @ %def var_list_append_pdg_array @ %def var_list_append_string -<>= - public :: var_list_append_log_ptr - public :: var_list_append_int_ptr - public :: var_list_append_real_ptr - public :: var_list_append_cmplx_ptr - public :: var_list_append_pdg_array_ptr - public :: var_list_append_subevt_ptr - public :: var_list_append_string_ptr <>= procedure :: append_log_ptr => var_list_append_log_ptr procedure :: append_int_ptr => var_list_append_int_ptr procedure :: append_real_ptr => var_list_append_real_ptr procedure :: append_cmplx_ptr => var_list_append_cmplx_ptr procedure :: append_pdg_array_ptr => var_list_append_pdg_array_ptr procedure :: append_subevt_ptr => var_list_append_subevt_ptr procedure :: append_string_ptr => var_list_append_string_ptr -<>= - subroutine var_list_append_log_ptr & - (var_list, name, lval, is_known, locked, verbose, intrinsic, description) +<>= + module subroutine var_list_append_log_ptr & + (var_list, name, lval, is_known, locked, verbose, & + intrinsic, description) + class(var_list_t), intent(inout) :: var_list + type(string_t), intent(in) :: name + logical, intent(in), target :: lval + logical, intent(in), target :: is_known + logical, intent(in), optional :: locked, verbose, intrinsic + type(string_t), intent(in), optional :: description + end subroutine var_list_append_log_ptr + module subroutine var_list_append_int_ptr & + (var_list, name, ival, is_known, locked, verbose, & + intrinsic, description) + class(var_list_t), intent(inout) :: var_list + type(string_t), intent(in) :: name + integer, intent(in), target :: ival + logical, intent(in), target :: is_known + logical, intent(in), optional :: locked, verbose, intrinsic + type(string_t), intent(in), optional :: description + end subroutine var_list_append_int_ptr + module subroutine var_list_append_real_ptr & + (var_list, name, rval, is_known, locked, verbose, & + intrinsic, description) + class(var_list_t), intent(inout) :: var_list + type(string_t), intent(in) :: name + real(default), intent(in), target :: rval + logical, intent(in), target :: is_known + logical, intent(in), optional :: locked, verbose, intrinsic + type(string_t), intent(in), optional :: description + end subroutine var_list_append_real_ptr + module subroutine var_list_append_cmplx_ptr & + (var_list, name, cval, is_known, locked, verbose, & + intrinsic, description) + class(var_list_t), intent(inout) :: var_list + type(string_t), intent(in) :: name + complex(default), intent(in), target :: cval + logical, intent(in), target :: is_known + logical, intent(in), optional :: locked, verbose, intrinsic + type(string_t), intent(in), optional :: description + end subroutine var_list_append_cmplx_ptr + module subroutine var_list_append_pdg_array_ptr & + (var_list, name, aval, is_known, locked, verbose, & + intrinsic, description) + class(var_list_t), intent(inout) :: var_list + type(string_t), intent(in) :: name + type(pdg_array_t), intent(in), target :: aval + logical, intent(in), target :: is_known + logical, intent(in), optional :: locked, verbose, intrinsic + type(string_t), intent(in), optional :: description + end subroutine var_list_append_pdg_array_ptr + module subroutine var_list_append_subevt_ptr & + (var_list, name, pval, is_known, locked, verbose, & + intrinsic, description) + class(var_list_t), intent(inout) :: var_list + type(string_t), intent(in) :: name + type(subevt_t), intent(in), target :: pval + logical, intent(in), target :: is_known + logical, intent(in), optional :: locked, verbose, intrinsic + type(string_t), intent(in), optional :: description + end subroutine var_list_append_subevt_ptr + module subroutine var_list_append_string_ptr & + (var_list, name, sval, is_known, locked, verbose, & + intrinsic, description) + class(var_list_t), intent(inout) :: var_list + type(string_t), intent(in) :: name + type(string_t), intent(in), target :: sval + logical, intent(in), target :: is_known + logical, intent(in), optional :: locked, verbose, intrinsic + type(string_t), intent(in), optional :: description + end subroutine var_list_append_string_ptr +<>= + module subroutine var_list_append_log_ptr & + (var_list, name, lval, is_known, locked, verbose, & + intrinsic, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name logical, intent(in), target :: lval logical, intent(in), target :: is_known logical, intent(in), optional :: locked, verbose, intrinsic type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_log_ptr (var, name, lval, is_known, intrinsic) - if (present (description)) call var_entry_set_description (var, description) + if (present (description)) & + call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_log_ptr - subroutine var_list_append_int_ptr & + module subroutine var_list_append_int_ptr & (var_list, name, ival, is_known, locked, verbose, intrinsic, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name integer, intent(in), target :: ival logical, intent(in), target :: is_known logical, intent(in), optional :: locked, verbose, intrinsic type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_int_ptr (var, name, ival, is_known, intrinsic) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_int_ptr - subroutine var_list_append_real_ptr & + module subroutine var_list_append_real_ptr & (var_list, name, rval, is_known, locked, verbose, intrinsic, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name real(default), intent(in), target :: rval logical, intent(in), target :: is_known logical, intent(in), optional :: locked, verbose, intrinsic type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_real_ptr (var, name, rval, is_known, intrinsic) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_real_ptr - subroutine var_list_append_cmplx_ptr & + module subroutine var_list_append_cmplx_ptr & (var_list, name, cval, is_known, locked, verbose, intrinsic, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name complex(default), intent(in), target :: cval logical, intent(in), target :: is_known logical, intent(in), optional :: locked, verbose, intrinsic type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_cmplx_ptr (var, name, cval, is_known, intrinsic) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_cmplx_ptr - subroutine var_list_append_pdg_array_ptr & + module subroutine var_list_append_pdg_array_ptr & (var_list, name, aval, is_known, locked, verbose, intrinsic, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name type(pdg_array_t), intent(in), target :: aval logical, intent(in), target :: is_known logical, intent(in), optional :: locked, verbose, intrinsic type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_pdg_array_ptr (var, name, aval, is_known, intrinsic) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_pdg_array_ptr - subroutine var_list_append_subevt_ptr & + module subroutine var_list_append_subevt_ptr & (var_list, name, pval, is_known, locked, verbose, intrinsic, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name type(subevt_t), intent(in), target :: pval logical, intent(in), target :: is_known logical, intent(in), optional :: locked, verbose, intrinsic type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_subevt_ptr (var, name, pval, is_known, intrinsic) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_subevt_ptr - subroutine var_list_append_string_ptr & + module subroutine var_list_append_string_ptr & (var_list, name, sval, is_known, locked, verbose, intrinsic, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name type(string_t), intent(in), target :: sval logical, intent(in), target :: is_known logical, intent(in), optional :: locked, verbose, intrinsic type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_string_ptr (var, name, sval, is_known, intrinsic) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_string_ptr @ %def var_list_append_log_ptr @ %def var_list_append_int_ptr @ %def var_list_append_real_ptr @ %def var_list_append_cmplx_ptr @ %def var_list_append_pdg_array_ptr @ %def var_list_append_subevt_ptr @ \subsubsection{Finalizer} Finalize, delete the list entry by entry. The link itself is kept intact. Follow link and delete recursively only if requested explicitly. <>= procedure :: final => var_list_final +<>= + recursive module subroutine var_list_final (vars, follow_link) + class(var_list_t), intent(inout) :: vars + logical, intent(in), optional :: follow_link + end subroutine var_list_final <>= - recursive subroutine var_list_final (vars, follow_link) + recursive module subroutine var_list_final (vars, follow_link) class(var_list_t), intent(inout) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var vars%last => null () do while (associated (vars%first)) var => vars%first vars%first => var%next call var_entry_final (var) deallocate (var) end do if (present (follow_link)) then if (follow_link) then if (associated (vars%next)) then call vars%next%final (follow_link) deallocate (vars%next) end if end if end if end subroutine var_list_final @ %def var_list_final @ \subsubsection{Output} Show variable list with precise control over options. E.g., show only variables of a certain type. Many options, thus not an ordinary [[write]] method. -<>= - public :: var_list_write <>= procedure :: write => var_list_write +<>= + recursive module subroutine var_list_write & + (var_list, unit, follow_link, only_type, prefix, model_name, & + intrinsic, pacified, descriptions, ascii_output) + class(var_list_t), intent(in), target :: var_list + integer, intent(in), optional :: unit + logical, intent(in), optional :: follow_link + integer, intent(in), optional :: only_type + character(*), intent(in), optional :: prefix + type(string_t), intent(in), optional :: model_name + logical, intent(in), optional :: intrinsic + logical, intent(in), optional :: pacified + logical, intent(in), optional :: descriptions + logical, intent(in), optional :: ascii_output + end subroutine var_list_write <>= - recursive subroutine var_list_write & + recursive module subroutine var_list_write & (var_list, unit, follow_link, only_type, prefix, model_name, & intrinsic, pacified, descriptions, ascii_output) class(var_list_t), intent(in), target :: var_list integer, intent(in), optional :: unit logical, intent(in), optional :: follow_link integer, intent(in), optional :: only_type character(*), intent(in), optional :: prefix type(string_t), intent(in), optional :: model_name logical, intent(in), optional :: intrinsic logical, intent(in), optional :: pacified logical, intent(in), optional :: descriptions logical, intent(in), optional :: ascii_output type(var_entry_t), pointer :: var integer :: u, length logical :: write_this, write_next u = given_output_unit (unit); if (u < 0) return if (present (prefix)) length = len (prefix) var => var_list%first if (associated (var)) then do while (associated (var)) if (present (only_type)) then write_this = only_type == var%type else write_this = .true. end if if (write_this .and. present (prefix)) then if (prefix /= extract (var%name, 1, length)) & write_this = .false. end if if (write_this) then call var_entry_write & (var, unit, model_name=model_name, & intrinsic=intrinsic, pacified=pacified, & descriptions=descriptions, ascii_output=ascii_output) end if var => var%next end do end if if (present (follow_link)) then write_next = follow_link .and. associated (var_list%next) else write_next = associated (var_list%next) end if if (write_next) then call var_list_write (var_list%next, & unit, follow_link, only_type, prefix, model_name, & intrinsic, pacified) end if end subroutine var_list_write @ %def var_list_write @ Write only a certain variable. -<>= - public :: var_list_write_var <>= procedure :: write_var => var_list_write_var +<>= + recursive module subroutine var_list_write_var & + (var_list, name, unit, type, follow_link, & + model_name, pacified, defined, descriptions, ascii_output) + class(var_list_t), intent(in), target :: var_list + type(string_t), intent(in) :: name + integer, intent(in), optional :: unit + integer, intent(in), optional :: type + logical, intent(in), optional :: follow_link + type(string_t), intent(in), optional :: model_name + logical, intent(in), optional :: pacified + logical, intent(in), optional :: defined + logical, intent(in), optional :: descriptions + logical, intent(in), optional :: ascii_output + end subroutine var_list_write_var <>= - recursive subroutine var_list_write_var & + recursive module subroutine var_list_write_var & (var_list, name, unit, type, follow_link, & model_name, pacified, defined, descriptions, ascii_output) class(var_list_t), intent(in), target :: var_list type(string_t), intent(in) :: name integer, intent(in), optional :: unit integer, intent(in), optional :: type logical, intent(in), optional :: follow_link type(string_t), intent(in), optional :: model_name logical, intent(in), optional :: pacified logical, intent(in), optional :: defined logical, intent(in), optional :: descriptions logical, intent(in), optional :: ascii_output type(var_entry_t), pointer :: var integer :: u u = given_output_unit (unit); if (u < 0) return var => var_list_get_var_ptr & (var_list, name, type, follow_link=follow_link, defined=defined) if (associated (var)) then call var_entry_write & (var, unit, model_name = model_name, & pacified = pacified, & descriptions=descriptions, ascii_output=ascii_output) else write (u, "(A)") char (name) // " = [undefined]" end if end subroutine var_list_write_var @ %def var_list_write_var @ \subsection{Tools} Return a pointer to the variable list linked to by the current one. <>= function var_list_get_next_ptr (var_list) result (next_ptr) type(var_list_t), pointer :: next_ptr type(var_list_t), intent(in) :: var_list next_ptr => var_list%next end function var_list_get_next_ptr @ %def var_list_get_next_ptr @ Used by [[eval_trees]]: Return a pointer to the variable with the requested name. If no such name exists, return a null pointer. In that case, try the next list if present, unless [[follow_link]] is unset. If [[defined]] is set, ignore entries that exist but are undefined. -<>= - public :: var_list_get_var_ptr <>= recursive function var_list_get_var_ptr & (var_list, name, type, follow_link, defined) result (var) type(var_entry_t), pointer :: var type(var_list_t), intent(in), target :: var_list type(string_t), intent(in) :: name integer, intent(in), optional :: type logical, intent(in), optional :: follow_link, defined logical :: ignore_undef, search_next ignore_undef = .true.; if (present (defined)) ignore_undef = .not. defined var => var_list%first if (present (type)) then do while (associated (var)) if (var%type == type) then if (var%name == name) then if (ignore_undef .or. var%is_defined) return end if end if var => var%next end do else do while (associated (var)) if (var%name == name) then if (ignore_undef .or. var%is_defined) return end if var => var%next end do end if search_next = associated (var_list%next) if (present (follow_link)) & search_next = search_next .and. follow_link if (search_next) & var => var_list_get_var_ptr & (var_list%next, name, type, defined=defined) end function var_list_get_var_ptr @ %def var_list_get_var_ptr @ Return the variable type <>= procedure :: get_type => var_list_get_type +<>= + module function var_list_get_type & + (var_list, name, follow_link) result (type) + class(var_list_t), intent(in), target :: var_list + type(string_t), intent(in) :: name + logical, intent(in), optional :: follow_link + integer :: type + end function var_list_get_type <>= - function var_list_get_type (var_list, name, follow_link) result (type) + module function var_list_get_type & + (var_list, name, follow_link) result (type) class(var_list_t), intent(in), target :: var_list type(string_t), intent(in) :: name logical, intent(in), optional :: follow_link integer :: type type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, follow_link=follow_link) if (associated (var)) then type = var%type else type = V_NONE end if end function var_list_get_type @ %def var_list_get_type @ Return true if the variable exists in the current list. <>= procedure :: contains => var_list_exists +<>= + module function var_list_exists (vars, name, follow_link) result (lval) + logical :: lval + type(string_t), intent(in) :: name + class(var_list_t), intent(in) :: vars + logical, intent(in), optional :: follow_link + end function var_list_exists <>= - function var_list_exists (vars, name, follow_link) result (lval) + module function var_list_exists (vars, name, follow_link) result (lval) logical :: lval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr (vars, name, follow_link=follow_link) lval = associated (var) end function var_list_exists @ %def var_list_exists @ Return true if the variable is declared as intrinsic. (This is not a property of the abstract [[vars_t]] type, and therefore the method is not inherited.) <>= procedure :: is_intrinsic => var_list_is_intrinsic +<>= + module function var_list_is_intrinsic & + (vars, name, follow_link) result (lval) + logical :: lval + type(string_t), intent(in) :: name + class(var_list_t), intent(in) :: vars + logical, intent(in), optional :: follow_link + end function var_list_is_intrinsic <>= - function var_list_is_intrinsic (vars, name, follow_link) result (lval) + module function var_list_is_intrinsic & + (vars, name, follow_link) result (lval) logical :: lval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr (vars, name, follow_link=follow_link) if (associated (var)) then lval = var%is_intrinsic else lval = .false. end if end function var_list_is_intrinsic @ %def var_list_is_intrinsic @ Return true if the value is known. <>= procedure :: is_known => var_list_is_known +<>= + module function var_list_is_known (vars, name, follow_link) result (lval) + logical :: lval + type(string_t), intent(in) :: name + class(var_list_t), intent(in) :: vars + logical, intent(in), optional :: follow_link + end function var_list_is_known <>= - function var_list_is_known (vars, name, follow_link) result (lval) + module function var_list_is_known (vars, name, follow_link) result (lval) logical :: lval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr (vars, name, follow_link=follow_link) if (associated (var)) then lval = var%is_known else lval = .false. end if end function var_list_is_known @ %def var_list_is_known @ Return true if the value is locked. (This is not a property of the abstract [[vars_t]] type, and therefore the method is not inherited.) <>= procedure :: is_locked => var_list_is_locked +<>= + module function var_list_is_locked (vars, name, follow_link) result (lval) + logical :: lval + type(string_t), intent(in) :: name + class(var_list_t), intent(in) :: vars + logical, intent(in), optional :: follow_link + end function var_list_is_locked <>= - function var_list_is_locked (vars, name, follow_link) result (lval) + module function var_list_is_locked (vars, name, follow_link) result (lval) logical :: lval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr (vars, name, follow_link=follow_link) if (associated (var)) then lval = var_entry_is_locked (var) else lval = .false. end if end function var_list_is_locked @ %def var_list_is_locked @ Return several properties at once. <>= procedure :: get_var_properties => var_list_get_var_properties -<>= - subroutine var_list_get_var_properties (vars, name, req_type, follow_link, & - type, is_defined, is_known, is_locked) +<>= + module subroutine var_list_get_var_properties & + (vars, name, req_type, follow_link, & + type, is_defined, is_known, is_locked) + class(var_list_t), intent(in) :: vars + type(string_t), intent(in) :: name + integer, intent(in), optional :: req_type + logical, intent(in), optional :: follow_link + integer, intent(out), optional :: type + logical, intent(out), optional :: is_defined, is_known, is_locked + end subroutine var_list_get_var_properties +<>= + module subroutine var_list_get_var_properties & + (vars, name, req_type, follow_link, & + type, is_defined, is_known, is_locked) class(var_list_t), intent(in) :: vars type(string_t), intent(in) :: name integer, intent(in), optional :: req_type logical, intent(in), optional :: follow_link integer, intent(out), optional :: type logical, intent(out), optional :: is_defined, is_known, is_locked type(var_entry_t), pointer :: var var => var_list_get_var_ptr & (vars, name, type=req_type, follow_link=follow_link) if (associated (var)) then if (present (type)) type = var_entry_get_type (var) if (present (is_defined)) is_defined = var_entry_is_defined (var) if (present (is_known)) is_known = var_entry_is_known (var) if (present (is_locked)) is_locked = var_entry_is_locked (var) else if (present (type)) type = V_NONE if (present (is_defined)) is_defined = .false. if (present (is_known)) is_known = .false. if (present (is_locked)) is_locked = .false. end if end subroutine var_list_get_var_properties @ %def var_list_get_var_properties @ Return the value, assuming that the type is correct. We consider only variable entries that have been [[defined]]. For convenience, allow both variable and fixed-length (literal) strings. <>= procedure :: get_lval => var_list_get_lval procedure :: get_ival => var_list_get_ival procedure :: get_rval => var_list_get_rval procedure :: get_cval => var_list_get_cval procedure :: get_pval => var_list_get_pval procedure :: get_aval => var_list_get_aval procedure :: get_sval => var_list_get_sval +<>= + module function var_list_get_lval (vars, name, follow_link) result (lval) + logical :: lval + type(string_t), intent(in) :: name + class(var_list_t), intent(in) :: vars + logical, intent(in), optional :: follow_link + end function var_list_get_lval + module function var_list_get_ival (vars, name, follow_link) result (ival) + integer :: ival + type(string_t), intent(in) :: name + class(var_list_t), intent(in) :: vars + logical, intent(in), optional :: follow_link + end function var_list_get_ival + module function var_list_get_rval (vars, name, follow_link) result (rval) + real(default) :: rval + type(string_t), intent(in) :: name + class(var_list_t), intent(in) :: vars + logical, intent(in), optional :: follow_link + end function var_list_get_rval + module function var_list_get_cval (vars, name, follow_link) result (cval) + complex(default) :: cval + type(string_t), intent(in) :: name + class(var_list_t), intent(in) :: vars + logical, intent(in), optional :: follow_link + end function var_list_get_cval + module function var_list_get_aval (vars, name, follow_link) result (aval) + type(pdg_array_t) :: aval + type(string_t), intent(in) :: name + class(var_list_t), intent(in) :: vars + logical, intent(in), optional :: follow_link + end function var_list_get_aval + module function var_list_get_pval (vars, name, follow_link) result (pval) + type(subevt_t) :: pval + type(string_t), intent(in) :: name + class(var_list_t), intent(in) :: vars + logical, intent(in), optional :: follow_link + end function var_list_get_pval + module function var_list_get_sval (vars, name, follow_link) result (sval) + type(string_t) :: sval + type(string_t), intent(in) :: name + class(var_list_t), intent(in) :: vars + logical, intent(in), optional :: follow_link + end function var_list_get_sval <>= - function var_list_get_lval (vars, name, follow_link) result (lval) + module function var_list_get_lval (vars, name, follow_link) result (lval) logical :: lval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr & (vars, name, V_LOG, follow_link, defined=.true.) if (associated (var)) then if (var_has_value (var)) then lval = var%lval else lval = .false. end if else lval = .false. end if end function var_list_get_lval - function var_list_get_ival (vars, name, follow_link) result (ival) + module function var_list_get_ival (vars, name, follow_link) result (ival) integer :: ival type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr & (vars, name, V_INT, follow_link, defined=.true.) if (associated (var)) then if (var_has_value (var)) then ival = var%ival else ival = 0 end if else ival = 0 end if end function var_list_get_ival - function var_list_get_rval (vars, name, follow_link) result (rval) + module function var_list_get_rval (vars, name, follow_link) result (rval) real(default) :: rval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr & (vars, name, V_REAL, follow_link, defined=.true.) if (associated (var)) then if (var_has_value (var)) then rval = var%rval else rval = 0 end if else rval = 0 end if end function var_list_get_rval - function var_list_get_cval (vars, name, follow_link) result (cval) + module function var_list_get_cval (vars, name, follow_link) result (cval) complex(default) :: cval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr & (vars, name, V_CMPLX, follow_link, defined=.true.) if (associated (var)) then if (var_has_value (var)) then cval = var%cval else cval = 0 end if else cval = 0 end if end function var_list_get_cval - function var_list_get_aval (vars, name, follow_link) result (aval) + module function var_list_get_aval (vars, name, follow_link) result (aval) type(pdg_array_t) :: aval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr & (vars, name, V_PDG, follow_link, defined=.true.) if (associated (var)) then if (var_has_value (var)) then aval = var%aval end if end if end function var_list_get_aval - function var_list_get_pval (vars, name, follow_link) result (pval) + module function var_list_get_pval (vars, name, follow_link) result (pval) type(subevt_t) :: pval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr & (vars, name, V_SEV, follow_link, defined=.true.) if (associated (var)) then if (var_has_value (var)) then pval = var%pval end if end if end function var_list_get_pval - function var_list_get_sval (vars, name, follow_link) result (sval) + module function var_list_get_sval (vars, name, follow_link) result (sval) type(string_t) :: sval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr & (vars, name, V_STR, follow_link, defined=.true.) if (associated (var)) then if (var_has_value (var)) then sval = var%sval else sval = "" end if else sval = "" end if end function var_list_get_sval @ %def var_list_get_lval @ %def var_list_get_ival @ %def var_list_get_rval @ %def var_list_get_cval @ %def var_list_get_pval @ %def var_list_get_aval @ %def var_list_get_sval @ Check for a valid value, given a pointer. Issue error messages if invalid. <>= function var_has_value (var) result (valid) logical :: valid type(var_entry_t), pointer :: var if (associated (var)) then if (var%is_known) then valid = .true. else call msg_error ("The value of variable '" // char (var%name) & // "' is unknown but must be known at this point.") valid = .false. end if else call msg_error ("Variable '" // char (var%name) & // "' is undefined but must have a known value at this point.") valid = .false. end if end function var_has_value @ %def var_has_value @ Return pointers instead of values, including a pointer to the [[known]] entry. <>= procedure :: get_lptr => var_list_get_lptr procedure :: get_iptr => var_list_get_iptr procedure :: get_rptr => var_list_get_rptr procedure :: get_cptr => var_list_get_cptr procedure :: get_aptr => var_list_get_aptr procedure :: get_pptr => var_list_get_pptr procedure :: get_sptr => var_list_get_sptr +<>= + module subroutine var_list_get_lptr (var_list, name, lptr, known) + class(var_list_t), intent(in) :: var_list + type(string_t), intent(in) :: name + logical, pointer, intent(out) :: lptr + logical, pointer, intent(out), optional :: known + end subroutine var_list_get_lptr + module subroutine var_list_get_iptr (var_list, name, iptr, known) + class(var_list_t), intent(in) :: var_list + type(string_t), intent(in) :: name + integer, pointer, intent(out) :: iptr + logical, pointer, intent(out), optional :: known + end subroutine var_list_get_iptr + module subroutine var_list_get_rptr (var_list, name, rptr, known) + class(var_list_t), intent(in) :: var_list + type(string_t), intent(in) :: name + real(default), pointer, intent(out) :: rptr + logical, pointer, intent(out), optional :: known + end subroutine var_list_get_rptr + module subroutine var_list_get_cptr (var_list, name, cptr, known) + class(var_list_t), intent(in) :: var_list + type(string_t), intent(in) :: name + complex(default), pointer, intent(out) :: cptr + logical, pointer, intent(out), optional :: known + end subroutine var_list_get_cptr + module subroutine var_list_get_aptr (var_list, name, aptr, known) + class(var_list_t), intent(in) :: var_list + type(string_t), intent(in) :: name + type(pdg_array_t), pointer, intent(out) :: aptr + logical, pointer, intent(out), optional :: known + type(var_entry_t), pointer :: var + end subroutine var_list_get_aptr + module subroutine var_list_get_pptr (var_list, name, pptr, known) + class(var_list_t), intent(in) :: var_list + type(string_t), intent(in) :: name + type(subevt_t), pointer, intent(out) :: pptr + logical, pointer, intent(out), optional :: known + end subroutine var_list_get_pptr + module subroutine var_list_get_sptr (var_list, name, sptr, known) + class(var_list_t), intent(in) :: var_list + type(string_t), intent(in) :: name + type(string_t), pointer, intent(out) :: sptr + logical, pointer, intent(out), optional :: known + end subroutine var_list_get_sptr <>= - subroutine var_list_get_lptr (var_list, name, lptr, known) + module subroutine var_list_get_lptr (var_list, name, lptr, known) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name logical, pointer, intent(out) :: lptr logical, pointer, intent(out), optional :: known type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_LOG) if (associated (var)) then lptr => var_entry_get_lval_ptr (var) if (present (known)) known => var_entry_get_known_ptr (var) else lptr => null () if (present (known)) known => null () end if end subroutine var_list_get_lptr - subroutine var_list_get_iptr (var_list, name, iptr, known) + module subroutine var_list_get_iptr (var_list, name, iptr, known) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name integer, pointer, intent(out) :: iptr logical, pointer, intent(out), optional :: known type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_INT) if (associated (var)) then iptr => var_entry_get_ival_ptr (var) if (present (known)) known => var_entry_get_known_ptr (var) else iptr => null () if (present (known)) known => null () end if end subroutine var_list_get_iptr - subroutine var_list_get_rptr (var_list, name, rptr, known) + module subroutine var_list_get_rptr (var_list, name, rptr, known) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name real(default), pointer, intent(out) :: rptr logical, pointer, intent(out), optional :: known type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_REAL) if (associated (var)) then rptr => var_entry_get_rval_ptr (var) if (present (known)) known => var_entry_get_known_ptr (var) else rptr => null () if (present (known)) known => null () end if end subroutine var_list_get_rptr - subroutine var_list_get_cptr (var_list, name, cptr, known) + module subroutine var_list_get_cptr (var_list, name, cptr, known) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name complex(default), pointer, intent(out) :: cptr logical, pointer, intent(out), optional :: known type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_CMPLX) if (associated (var)) then cptr => var_entry_get_cval_ptr (var) if (present (known)) known => var_entry_get_known_ptr (var) else cptr => null () if (present (known)) known => null () end if end subroutine var_list_get_cptr - subroutine var_list_get_aptr (var_list, name, aptr, known) + module subroutine var_list_get_aptr (var_list, name, aptr, known) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name type(pdg_array_t), pointer, intent(out) :: aptr logical, pointer, intent(out), optional :: known type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_PDG) if (associated (var)) then aptr => var_entry_get_aval_ptr (var) if (present (known)) known => var_entry_get_known_ptr (var) else aptr => null () if (present (known)) known => null () end if end subroutine var_list_get_aptr - subroutine var_list_get_pptr (var_list, name, pptr, known) + module subroutine var_list_get_pptr (var_list, name, pptr, known) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name type(subevt_t), pointer, intent(out) :: pptr logical, pointer, intent(out), optional :: known type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_SEV) if (associated (var)) then pptr => var_entry_get_pval_ptr (var) if (present (known)) known => var_entry_get_known_ptr (var) else pptr => null () if (present (known)) known => null () end if end subroutine var_list_get_pptr - subroutine var_list_get_sptr (var_list, name, sptr, known) + module subroutine var_list_get_sptr (var_list, name, sptr, known) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name type(string_t), pointer, intent(out) :: sptr logical, pointer, intent(out), optional :: known type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_STR) if (associated (var)) then sptr => var_entry_get_sval_ptr (var) if (present (known)) known => var_entry_get_known_ptr (var) else sptr => null () if (present (known)) known => null () end if end subroutine var_list_get_sptr @ %def var_list_get_lptr @ %def var_list_get_iptr @ %def var_list_get_rptr @ %def var_list_get_cptr @ %def var_list_get_aptr @ %def var_list_get_pptr @ %def var_list_get_sptr @ This bunch of methods handles the procedure-pointer cases. <>= procedure :: get_obs1_iptr => var_list_get_obs1_iptr procedure :: get_obs2_iptr => var_list_get_obs2_iptr procedure :: get_obsev_iptr => var_list_get_obsev_iptr procedure :: get_obs1_rptr => var_list_get_obs1_rptr procedure :: get_obs2_rptr => var_list_get_obs2_rptr procedure :: get_obsev_rptr => var_list_get_obsev_rptr +<>= + module subroutine var_list_get_obs1_iptr (var_list, name, obs1_iptr, p1) + class(var_list_t), intent(in) :: var_list + type(string_t), intent(in) :: name + procedure(obs_unary_int), pointer, intent(out) :: obs1_iptr + type(prt_t), pointer, intent(out) :: p1 + end subroutine var_list_get_obs1_iptr + module subroutine var_list_get_obs2_iptr (var_list, name, obs2_iptr, p1, p2) + class(var_list_t), intent(in) :: var_list + type(string_t), intent(in) :: name + procedure(obs_binary_int), pointer, intent(out) :: obs2_iptr + type(prt_t), pointer, intent(out) :: p1, p2 + end subroutine var_list_get_obs2_iptr + module subroutine var_list_get_obsev_iptr (var_list, name, obsev_iptr, pval) + class(var_list_t), intent(in) :: var_list + type(string_t), intent(in) :: name + procedure(obs_sev_int), pointer, intent(out) :: obsev_iptr + type(subevt_t), pointer, intent(out) :: pval + end subroutine var_list_get_obsev_iptr + module subroutine var_list_get_obs1_rptr (var_list, name, obs1_rptr, p1) + class(var_list_t), intent(in) :: var_list + type(string_t), intent(in) :: name + procedure(obs_unary_real), pointer, intent(out) :: obs1_rptr + type(prt_t), pointer, intent(out) :: p1 + end subroutine var_list_get_obs1_rptr + module subroutine var_list_get_obs2_rptr (var_list, name, obs2_rptr, p1, p2) + class(var_list_t), intent(in) :: var_list + type(string_t), intent(in) :: name + procedure(obs_binary_real), pointer, intent(out) :: obs2_rptr + type(prt_t), pointer, intent(out) :: p1, p2 + end subroutine var_list_get_obs2_rptr + module subroutine var_list_get_obsev_rptr (var_list, name, obsev_rptr, pval) + class(var_list_t), intent(in) :: var_list + type(string_t), intent(in) :: name + procedure(obs_sev_real), pointer, intent(out) :: obsev_rptr + type(subevt_t), pointer, intent(out) :: pval + end subroutine var_list_get_obsev_rptr <>= - subroutine var_list_get_obs1_iptr (var_list, name, obs1_iptr, p1) + module subroutine var_list_get_obs1_iptr (var_list, name, obs1_iptr, p1) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name procedure(obs_unary_int), pointer, intent(out) :: obs1_iptr type(prt_t), pointer, intent(out) :: p1 type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_OBS1_INT) if (associated (var)) then call var_entry_assign_obs1_int_ptr (obs1_iptr, var) p1 => var_entry_get_prt1_ptr (var) else obs1_iptr => null () p1 => null () end if end subroutine var_list_get_obs1_iptr - subroutine var_list_get_obs2_iptr (var_list, name, obs2_iptr, p1, p2) + module subroutine var_list_get_obs2_iptr (var_list, name, obs2_iptr, p1, p2) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name procedure(obs_binary_int), pointer, intent(out) :: obs2_iptr type(prt_t), pointer, intent(out) :: p1, p2 type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_OBS2_INT) if (associated (var)) then call var_entry_assign_obs2_int_ptr (obs2_iptr, var) p1 => var_entry_get_prt1_ptr (var) p2 => var_entry_get_prt2_ptr (var) else obs2_iptr => null () p1 => null () p2 => null () end if end subroutine var_list_get_obs2_iptr - subroutine var_list_get_obsev_iptr (var_list, name, obsev_iptr, pval) + module subroutine var_list_get_obsev_iptr (var_list, name, obsev_iptr, pval) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name procedure(obs_sev_int), pointer, intent(out) :: obsev_iptr type(subevt_t), pointer, intent(out) :: pval type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_OBSEV_INT) if (associated (var)) then call var_entry_assign_obsev_int_ptr (obsev_iptr, var) pval => var_entry_get_pval_ptr (var) else obsev_iptr => null () pval => null () end if end subroutine var_list_get_obsev_iptr - subroutine var_list_get_obs1_rptr (var_list, name, obs1_rptr, p1) + module subroutine var_list_get_obs1_rptr (var_list, name, obs1_rptr, p1) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name procedure(obs_unary_real), pointer, intent(out) :: obs1_rptr type(prt_t), pointer, intent(out) :: p1 type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_OBS1_REAL) if (associated (var)) then call var_entry_assign_obs1_real_ptr (obs1_rptr, var) p1 => var_entry_get_prt1_ptr (var) else obs1_rptr => null () p1 => null () end if end subroutine var_list_get_obs1_rptr - subroutine var_list_get_obs2_rptr (var_list, name, obs2_rptr, p1, p2) + module subroutine var_list_get_obs2_rptr (var_list, name, obs2_rptr, p1, p2) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name procedure(obs_binary_real), pointer, intent(out) :: obs2_rptr type(prt_t), pointer, intent(out) :: p1, p2 type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_OBS2_REAL) if (associated (var)) then call var_entry_assign_obs2_real_ptr (obs2_rptr, var) p1 => var_entry_get_prt1_ptr (var) p2 => var_entry_get_prt2_ptr (var) else obs2_rptr => null () p1 => null () p2 => null () end if end subroutine var_list_get_obs2_rptr - subroutine var_list_get_obsev_rptr (var_list, name, obsev_rptr, pval) + module subroutine var_list_get_obsev_rptr (var_list, name, obsev_rptr, pval) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name procedure(obs_sev_real), pointer, intent(out) :: obsev_rptr type(subevt_t), pointer, intent(out) :: pval type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_OBSEV_REAL) if (associated (var)) then call var_entry_assign_obsev_real_ptr (obsev_rptr, var) pval => var_entry_get_pval_ptr (var) else obsev_rptr => null () pval => null () end if end subroutine var_list_get_obsev_rptr @ %def var_list_get_obs1_iptr @ %def var_list_get_obs2_iptr @ %def var_list_get_obsev_iptr @ %def var_list_get_obs1_rptr @ %def var_list_get_obs2_rptr @ %def var_list_get_obsev_rptr @ \subsection{Process Result Variables} These variables are associated to process (integration) runs and their results. Their names contain brackets (so they look like function evaluations), therefore we need to special-case them. -<>= - public :: var_list_set_procvar_int - public :: var_list_set_procvar_real +<>= + procedure :: set_procvar_int => var_list_set_procvar_int + procedure :: set_procvar_real => var_list_set_procvar_real +<>= + module subroutine var_list_set_procvar_int (var_list, proc_id, name, ival) + class(var_list_t), intent(inout) :: var_list + type(string_t), intent(in) :: proc_id + type(string_t), intent(in) :: name + integer, intent(in), optional :: ival + end subroutine var_list_set_procvar_int + module subroutine var_list_set_procvar_real (var_list, proc_id, name, rval) + class(var_list_t), intent(inout) :: var_list + type(string_t), intent(in) :: proc_id + type(string_t), intent(in) :: name + real(default), intent(in), optional :: rval + end subroutine var_list_set_procvar_real <>= - subroutine var_list_set_procvar_int (var_list, proc_id, name, ival) - type(var_list_t), intent(inout) :: var_list + module subroutine var_list_set_procvar_int (var_list, proc_id, name, ival) + class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: proc_id type(string_t), intent(in) :: name integer, intent(in), optional :: ival type(string_t) :: var_name type(var_entry_t), pointer :: var var_name = name // "(" // proc_id // ")" var => var_list_get_var_ptr (var_list, var_name) if (.not. associated (var)) then call var_list%append_int (var_name, ival, intrinsic=.true.) else if (present (ival)) then call var_list%set_int (var_name, ival, is_known=.true.) end if end subroutine var_list_set_procvar_int - subroutine var_list_set_procvar_real (var_list, proc_id, name, rval) - type(var_list_t), intent(inout) :: var_list + module subroutine var_list_set_procvar_real (var_list, proc_id, name, rval) + class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: proc_id type(string_t), intent(in) :: name real(default), intent(in), optional :: rval type(string_t) :: var_name type(var_entry_t), pointer :: var var_name = name // "(" // proc_id // ")" var => var_list_get_var_ptr (var_list, var_name) if (.not. associated (var)) then call var_list%append_real (var_name, rval, intrinsic=.true.) else if (present (rval)) then call var_list%set_real (var_name, rval, is_known=.true.) end if end subroutine var_list_set_procvar_real @ %def var_list_set_procvar_int @ %def var_list_set_procvar_real @ \subsection{Observable initialization} Observables are formally treated as variables, which however are evaluated each time the observable is used. The arguments (pointers) to evaluate and the function are part of the variable-list entry. -<>= - public :: var_list_append_obs1_iptr - public :: var_list_append_obs2_iptr - public :: var_list_append_obs1_rptr - public :: var_list_append_obs2_rptr - public :: var_list_append_obsev_iptr - public :: var_list_append_obsev_rptr +<>= + procedure :: append_obs1_iptr => var_list_append_obs1_iptr + procedure :: append_obs2_iptr => var_list_append_obs2_iptr + procedure :: append_obs1_rptr => var_list_append_obs1_rptr + procedure :: append_obs2_rptr => var_list_append_obs2_rptr + procedure :: append_obsev_iptr => var_list_append_obsev_iptr + procedure :: append_obsev_rptr => var_list_append_obsev_rptr +<>= + module subroutine var_list_append_obs1_iptr & + (var_list, name, obs1_iptr, p1) + class(var_list_t), intent(inout) :: var_list + type(string_t), intent(in) :: name + procedure(obs_unary_int) :: obs1_iptr + type(prt_t), intent(in), target :: p1 + end subroutine var_list_append_obs1_iptr + module subroutine var_list_append_obs2_iptr & + (var_list, name, obs2_iptr, p1, p2) + class(var_list_t), intent(inout) :: var_list + type(string_t), intent(in) :: name + procedure(obs_binary_int) :: obs2_iptr + type(prt_t), intent(in), target :: p1, p2 + end subroutine var_list_append_obs2_iptr + module subroutine var_list_append_obsev_iptr & + (var_list, name, obsev_iptr, sev) + class(var_list_t), intent(inout) :: var_list + type(string_t), intent(in) :: name + procedure(obs_sev_int) :: obsev_iptr + type(subevt_t), intent(in), target :: sev + end subroutine var_list_append_obsev_iptr + module subroutine var_list_append_obs1_rptr & + (var_list, name, obs1_rptr, p1) + class(var_list_t), intent(inout) :: var_list + type(string_t), intent(in) :: name + procedure(obs_unary_real) :: obs1_rptr + type(prt_t), intent(in), target :: p1 + end subroutine var_list_append_obs1_rptr + module subroutine var_list_append_obs2_rptr & + (var_list, name, obs2_rptr, p1, p2) + class(var_list_t), intent(inout) :: var_list + type(string_t), intent(in) :: name + procedure(obs_binary_real) :: obs2_rptr + type(prt_t), intent(in), target :: p1, p2 + end subroutine var_list_append_obs2_rptr + module subroutine var_list_append_obsev_rptr & + (var_list, name, obsev_rptr, sev) + class(var_list_t), intent(inout) :: var_list + type(string_t), intent(in) :: name + procedure(obs_sev_real) :: obsev_rptr + type(subevt_t), intent(in), target :: sev + end subroutine var_list_append_obsev_rptr <>= - subroutine var_list_append_obs1_iptr (var_list, name, obs1_iptr, p1) - type(var_list_t), intent(inout) :: var_list + module subroutine var_list_append_obs1_iptr & + (var_list, name, obs1_iptr, p1) + class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name procedure(obs_unary_int) :: obs1_iptr type(prt_t), intent(in), target :: p1 type(var_entry_t), pointer :: var allocate (var) call var_entry_init_obs (var, name, V_OBS1_INT, p1) var%obs1_int => obs1_iptr call var_list_append (var_list, var) end subroutine var_list_append_obs1_iptr - subroutine var_list_append_obs2_iptr (var_list, name, obs2_iptr, p1, p2) - type(var_list_t), intent(inout) :: var_list + module subroutine var_list_append_obs2_iptr & + (var_list, name, obs2_iptr, p1, p2) + class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name procedure(obs_binary_int) :: obs2_iptr type(prt_t), intent(in), target :: p1, p2 type(var_entry_t), pointer :: var allocate (var) call var_entry_init_obs (var, name, V_OBS2_INT, p1, p2) var%obs2_int => obs2_iptr call var_list_append (var_list, var) end subroutine var_list_append_obs2_iptr - subroutine var_list_append_obsev_iptr (var_list, name, obsev_iptr, sev) - type(var_list_t), intent(inout) :: var_list + module subroutine var_list_append_obsev_iptr & + (var_list, name, obsev_iptr, sev) + class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name procedure(obs_sev_int) :: obsev_iptr type(subevt_t), intent(in), target :: sev type(var_entry_t), pointer :: var allocate (var) call var_entry_init_obs_sev (var, name, V_OBSEV_INT, sev) var%obsev_int => obsev_iptr call var_list_append (var_list, var) end subroutine var_list_append_obsev_iptr - subroutine var_list_append_obs1_rptr (var_list, name, obs1_rptr, p1) - type(var_list_t), intent(inout) :: var_list + module subroutine var_list_append_obs1_rptr & + (var_list, name, obs1_rptr, p1) + class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name procedure(obs_unary_real) :: obs1_rptr type(prt_t), intent(in), target :: p1 type(var_entry_t), pointer :: var allocate (var) call var_entry_init_obs (var, name, V_OBS1_REAL, p1) var%obs1_real => obs1_rptr call var_list_append (var_list, var) end subroutine var_list_append_obs1_rptr - subroutine var_list_append_obs2_rptr (var_list, name, obs2_rptr, p1, p2) - type(var_list_t), intent(inout) :: var_list + module subroutine var_list_append_obs2_rptr & + (var_list, name, obs2_rptr, p1, p2) + class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name procedure(obs_binary_real) :: obs2_rptr type(prt_t), intent(in), target :: p1, p2 type(var_entry_t), pointer :: var allocate (var) call var_entry_init_obs (var, name, V_OBS2_REAL, p1, p2) var%obs2_real => obs2_rptr call var_list_append (var_list, var) end subroutine var_list_append_obs2_rptr - subroutine var_list_append_obsev_rptr (var_list, name, obsev_rptr, sev) - type(var_list_t), intent(inout) :: var_list + module subroutine var_list_append_obsev_rptr & + (var_list, name, obsev_rptr, sev) + class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name procedure(obs_sev_real) :: obsev_rptr type(subevt_t), intent(in), target :: sev type(var_entry_t), pointer :: var allocate (var) call var_entry_init_obs_sev (var, name, V_OBSEV_REAL, sev) var%obsev_real => obsev_rptr call var_list_append (var_list, var) end subroutine var_list_append_obsev_rptr @ %def var_list_append_obs1_iptr @ %def var_list_append_obs2_iptr @ %def var_list_append_obs1_rptr @ %def var_list_append_obs2_rptr @ User observables: no pointer needs to be stored. -<>= - public :: var_list_append_uobs_int - public :: var_list_append_uobs_real +<>= + procedure :: append_uobs_int => var_list_append_uobs_int + procedure :: append_uobs_real => var_list_append_uobs_real +<>= + module subroutine var_list_append_uobs_int (var_list, name, p1, p2) + class(var_list_t), intent(inout) :: var_list + type(string_t), intent(in) :: name + type(prt_t), intent(in), target :: p1 + type(prt_t), intent(in), target, optional :: p2 + end subroutine var_list_append_uobs_int + module subroutine var_list_append_uobs_real (var_list, name, p1, p2) + class(var_list_t), intent(inout) :: var_list + type(string_t), intent(in) :: name + type(prt_t), intent(in), target :: p1 + type(prt_t), intent(in), target, optional :: p2 + end subroutine var_list_append_uobs_real <>= - subroutine var_list_append_uobs_int (var_list, name, p1, p2) - type(var_list_t), intent(inout) :: var_list + module subroutine var_list_append_uobs_int (var_list, name, p1, p2) + class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name type(prt_t), intent(in), target :: p1 type(prt_t), intent(in), target, optional :: p2 type(var_entry_t), pointer :: var allocate (var) if (present (p2)) then call var_entry_init_obs (var, name, V_UOBS2_INT, p1, p2) else call var_entry_init_obs (var, name, V_UOBS1_INT, p1) end if call var_list_append (var_list, var) end subroutine var_list_append_uobs_int - subroutine var_list_append_uobs_real (var_list, name, p1, p2) - type(var_list_t), intent(inout) :: var_list + module subroutine var_list_append_uobs_real (var_list, name, p1, p2) + class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name type(prt_t), intent(in), target :: p1 type(prt_t), intent(in), target, optional :: p2 type(var_entry_t), pointer :: var allocate (var) if (present (p2)) then call var_entry_init_obs (var, name, V_UOBS2_REAL, p1, p2) else call var_entry_init_obs (var, name, V_UOBS1_REAL, p1) end if call var_list_append (var_list, var) end subroutine var_list_append_uobs_real @ %def var_list_append_uobs_int @ %def var_list_append_uobs_real @ \subsection{API for variable lists} Set a new value. If the variable holds a pointer, this pointer is followed, e.g., a model parameter is actually set. If [[ignore]] is set, do nothing if the variable does not exist. If [[verbose]] is set, echo the new value. Clear a variable (all variables), i.e., undefine the value. <>= procedure :: unset => var_list_clear +<>= + module subroutine var_list_clear (vars, name, follow_link) + class(var_list_t), intent(inout) :: vars + type(string_t), intent(in) :: name + logical, intent(in), optional :: follow_link + end subroutine var_list_clear <>= - subroutine var_list_clear (vars, name, follow_link) + module subroutine var_list_clear (vars, name, follow_link) class(var_list_t), intent(inout) :: vars type(string_t), intent(in) :: name logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr (vars, name, follow_link=follow_link) if (associated (var)) then call var_entry_clear (var) end if end subroutine var_list_clear @ %def var_list_clear @ Setting the value, concise specific versions (implementing deferred TBP): <>= procedure :: set_ival => var_list_set_ival procedure :: set_rval => var_list_set_rval procedure :: set_cval => var_list_set_cval procedure :: set_lval => var_list_set_lval procedure :: set_sval => var_list_set_sval +<>= + module subroutine var_list_set_ival (vars, name, ival, follow_link) + class(var_list_t), intent(inout) :: vars + type(string_t), intent(in) :: name + integer, intent(in) :: ival + logical, intent(in), optional :: follow_link + end subroutine var_list_set_ival + module subroutine var_list_set_rval (vars, name, rval, follow_link) + class(var_list_t), intent(inout) :: vars + type(string_t), intent(in) :: name + real(default), intent(in) :: rval + logical, intent(in), optional :: follow_link + end subroutine var_list_set_rval + module subroutine var_list_set_cval (vars, name, cval, follow_link) + class(var_list_t), intent(inout) :: vars + type(string_t), intent(in) :: name + complex(default), intent(in) :: cval + logical, intent(in), optional :: follow_link + end subroutine var_list_set_cval + module subroutine var_list_set_lval (vars, name, lval, follow_link) + class(var_list_t), intent(inout) :: vars + type(string_t), intent(in) :: name + logical, intent(in) :: lval + logical, intent(in), optional :: follow_link + end subroutine var_list_set_lval + module subroutine var_list_set_sval (vars, name, sval, follow_link) + class(var_list_t), intent(inout) :: vars + type(string_t), intent(in) :: name + type(string_t), intent(in) :: sval + logical, intent(in), optional :: follow_link + end subroutine var_list_set_sval <>= - subroutine var_list_set_ival (vars, name, ival, follow_link) + module subroutine var_list_set_ival (vars, name, ival, follow_link) class(var_list_t), intent(inout) :: vars type(string_t), intent(in) :: name integer, intent(in) :: ival logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr (vars, name, follow_link=follow_link) if (associated (var)) then call var_entry_set_int (var, ival, is_known=.true.) end if end subroutine var_list_set_ival - subroutine var_list_set_rval (vars, name, rval, follow_link) + module subroutine var_list_set_rval (vars, name, rval, follow_link) class(var_list_t), intent(inout) :: vars type(string_t), intent(in) :: name real(default), intent(in) :: rval logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr (vars, name, follow_link=follow_link) if (associated (var)) then call var_entry_set_real (var, rval, is_known=.true.) end if end subroutine var_list_set_rval - subroutine var_list_set_cval (vars, name, cval, follow_link) + module subroutine var_list_set_cval (vars, name, cval, follow_link) class(var_list_t), intent(inout) :: vars type(string_t), intent(in) :: name complex(default), intent(in) :: cval logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr (vars, name, follow_link=follow_link) if (associated (var)) then call var_entry_set_cmplx (var, cval, is_known=.true.) end if end subroutine var_list_set_cval - subroutine var_list_set_lval (vars, name, lval, follow_link) + module subroutine var_list_set_lval (vars, name, lval, follow_link) class(var_list_t), intent(inout) :: vars type(string_t), intent(in) :: name logical, intent(in) :: lval logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr (vars, name, follow_link=follow_link) if (associated (var)) then call var_entry_set_log (var, lval, is_known=.true.) end if end subroutine var_list_set_lval - subroutine var_list_set_sval (vars, name, sval, follow_link) + module subroutine var_list_set_sval (vars, name, sval, follow_link) class(var_list_t), intent(inout) :: vars type(string_t), intent(in) :: name type(string_t), intent(in) :: sval logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr (vars, name, follow_link=follow_link) if (associated (var)) then call var_entry_set_string (var, sval, is_known=.true.) end if end subroutine var_list_set_sval @ %def var_list_set_ival @ %def var_list_set_rval @ %def var_list_set_cval @ %def var_list_set_lval @ %def var_list_set_sval @ Setting the value, verbose specific versions (as subroutines): <>= procedure :: set_log => var_list_set_log procedure :: set_int => var_list_set_int procedure :: set_real => var_list_set_real procedure :: set_cmplx => var_list_set_cmplx procedure :: set_subevt => var_list_set_subevt procedure :: set_pdg_array => var_list_set_pdg_array procedure :: set_string => var_list_set_string +<>= + module subroutine var_list_set_log & + (var_list, name, lval, is_known, ignore, force, verbose, model_name) + class(var_list_t), intent(inout), target :: var_list + type(string_t), intent(in) :: name + logical, intent(in) :: lval + logical, intent(in) :: is_known + logical, intent(in), optional :: ignore, force, verbose + type(string_t), intent(in), optional :: model_name + end subroutine var_list_set_log + module subroutine var_list_set_int & + (var_list, name, ival, is_known, ignore, force, verbose, model_name) + class(var_list_t), intent(inout), target :: var_list + type(string_t), intent(in) :: name + integer, intent(in) :: ival + logical, intent(in) :: is_known + logical, intent(in), optional :: ignore, force, verbose + type(string_t), intent(in), optional :: model_name + end subroutine var_list_set_int + module subroutine var_list_set_real & + (var_list, name, rval, is_known, ignore, force, & + verbose, model_name, pacified) + class(var_list_t), intent(inout), target :: var_list + type(string_t), intent(in) :: name + real(default), intent(in) :: rval + logical, intent(in) :: is_known + logical, intent(in), optional :: ignore, force, verbose, pacified + type(string_t), intent(in), optional :: model_name + end subroutine var_list_set_real + module subroutine var_list_set_cmplx & + (var_list, name, cval, is_known, ignore, force, & + verbose, model_name, pacified) + class(var_list_t), intent(inout), target :: var_list + type(string_t), intent(in) :: name + complex(default), intent(in) :: cval + logical, intent(in) :: is_known + logical, intent(in), optional :: ignore, force, verbose, pacified + type(string_t), intent(in), optional :: model_name + end subroutine var_list_set_cmplx + module subroutine var_list_set_pdg_array & + (var_list, name, aval, is_known, ignore, force, verbose, model_name) + class(var_list_t), intent(inout), target :: var_list + type(string_t), intent(in) :: name + type(pdg_array_t), intent(in) :: aval + logical, intent(in) :: is_known + logical, intent(in), optional :: ignore, force, verbose + type(string_t), intent(in), optional :: model_name + end subroutine var_list_set_pdg_array + module subroutine var_list_set_subevt & + (var_list, name, pval, is_known, ignore, force, verbose, model_name) + class(var_list_t), intent(inout), target :: var_list + type(string_t), intent(in) :: name + type(subevt_t), intent(in) :: pval + logical, intent(in) :: is_known + logical, intent(in), optional :: ignore, force, verbose + type(string_t), intent(in), optional :: model_name + end subroutine var_list_set_subevt + module subroutine var_list_set_string & + (var_list, name, sval, is_known, ignore, force, verbose, model_name) + class(var_list_t), intent(inout), target :: var_list + type(string_t), intent(in) :: name + type(string_t), intent(in) :: sval + logical, intent(in) :: is_known + logical, intent(in), optional :: ignore, force, verbose + type(string_t), intent(in), optional :: model_name + end subroutine var_list_set_string <>= - subroutine var_list_set_log & + module subroutine var_list_set_log & (var_list, name, lval, is_known, ignore, force, verbose, model_name) class(var_list_t), intent(inout), target :: var_list type(string_t), intent(in) :: name logical, intent(in) :: lval logical, intent(in) :: is_known logical, intent(in), optional :: ignore, force, verbose type(string_t), intent(in), optional :: model_name type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_LOG) if (associated (var)) then if (.not. var_entry_is_locked (var, force)) then select case (var%type) case (V_LOG) call var_entry_set_log (var, lval, is_known, verbose, model_name) case default call var_mismatch_error (name) end select else call var_locked_error (name) end if else call var_missing_error (name, ignore) end if end subroutine var_list_set_log - subroutine var_list_set_int & + module subroutine var_list_set_int & (var_list, name, ival, is_known, ignore, force, verbose, model_name) class(var_list_t), intent(inout), target :: var_list type(string_t), intent(in) :: name integer, intent(in) :: ival logical, intent(in) :: is_known logical, intent(in), optional :: ignore, force, verbose type(string_t), intent(in), optional :: model_name type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_INT) if (associated (var)) then if (.not. var_entry_is_locked (var, force)) then select case (var%type) case (V_INT) call var_entry_set_int (var, ival, is_known, verbose, model_name) case default call var_mismatch_error (name) end select else call var_locked_error (name) end if else call var_missing_error (name, ignore) end if end subroutine var_list_set_int - subroutine var_list_set_real & + module subroutine var_list_set_real & (var_list, name, rval, is_known, ignore, force, & verbose, model_name, pacified) class(var_list_t), intent(inout), target :: var_list type(string_t), intent(in) :: name real(default), intent(in) :: rval logical, intent(in) :: is_known logical, intent(in), optional :: ignore, force, verbose, pacified type(string_t), intent(in), optional :: model_name type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_REAL) if (associated (var)) then if (.not. var_entry_is_locked (var, force)) then select case (var%type) case (V_REAL) call var_entry_set_real & (var, rval, is_known, verbose, model_name, pacified) case default call var_mismatch_error (name) end select else call var_locked_error (name) end if else call var_missing_error (name, ignore) end if end subroutine var_list_set_real - subroutine var_list_set_cmplx & + module subroutine var_list_set_cmplx & (var_list, name, cval, is_known, ignore, force, & verbose, model_name, pacified) class(var_list_t), intent(inout), target :: var_list type(string_t), intent(in) :: name complex(default), intent(in) :: cval logical, intent(in) :: is_known logical, intent(in), optional :: ignore, force, verbose, pacified type(string_t), intent(in), optional :: model_name type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_CMPLX) if (associated (var)) then if (.not. var_entry_is_locked (var, force)) then select case (var%type) case (V_CMPLX) call var_entry_set_cmplx & (var, cval, is_known, verbose, model_name, pacified) case default call var_mismatch_error (name) end select else call var_locked_error (name) end if else call var_missing_error (name, ignore) end if end subroutine var_list_set_cmplx - subroutine var_list_set_pdg_array & + module subroutine var_list_set_pdg_array & (var_list, name, aval, is_known, ignore, force, verbose, model_name) class(var_list_t), intent(inout), target :: var_list type(string_t), intent(in) :: name type(pdg_array_t), intent(in) :: aval logical, intent(in) :: is_known logical, intent(in), optional :: ignore, force, verbose type(string_t), intent(in), optional :: model_name type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_PDG) if (associated (var)) then if (.not. var_entry_is_locked (var, force)) then select case (var%type) case (V_PDG) call var_entry_set_pdg_array & (var, aval, is_known, verbose, model_name) case default call var_mismatch_error (name) end select else call var_locked_error (name) end if else call var_missing_error (name, ignore) end if end subroutine var_list_set_pdg_array - subroutine var_list_set_subevt & + module subroutine var_list_set_subevt & (var_list, name, pval, is_known, ignore, force, verbose, model_name) class(var_list_t), intent(inout), target :: var_list type(string_t), intent(in) :: name type(subevt_t), intent(in) :: pval logical, intent(in) :: is_known logical, intent(in), optional :: ignore, force, verbose type(string_t), intent(in), optional :: model_name type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_SEV) if (associated (var)) then if (.not. var_entry_is_locked (var, force)) then select case (var%type) case (V_SEV) call var_entry_set_subevt & (var, pval, is_known, verbose, model_name) case default call var_mismatch_error (name) end select else call var_locked_error (name) end if else call var_missing_error (name, ignore) end if end subroutine var_list_set_subevt - subroutine var_list_set_string & + module subroutine var_list_set_string & (var_list, name, sval, is_known, ignore, force, verbose, model_name) class(var_list_t), intent(inout), target :: var_list type(string_t), intent(in) :: name type(string_t), intent(in) :: sval logical, intent(in) :: is_known logical, intent(in), optional :: ignore, force, verbose type(string_t), intent(in), optional :: model_name type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_STR) if (associated (var)) then if (.not. var_entry_is_locked (var, force)) then select case (var%type) case (V_STR) call var_entry_set_string & (var, sval, is_known, verbose, model_name) case default call var_mismatch_error (name) end select else call var_locked_error (name) end if else call var_missing_error (name, ignore) end if end subroutine var_list_set_string subroutine var_mismatch_error (name) type(string_t), intent(in) :: name call msg_fatal ("Type mismatch for variable '" // char (name) // "'") end subroutine var_mismatch_error subroutine var_locked_error (name) type(string_t), intent(in) :: name call msg_error ("Variable '" // char (name) // "' is not user-definable") end subroutine var_locked_error subroutine var_missing_error (name, ignore) type(string_t), intent(in) :: name logical, intent(in), optional :: ignore logical :: error if (present (ignore)) then error = .not. ignore else error = .true. end if if (error) then call msg_fatal ("Variable '" // char (name) // "' has not been declared") end if end subroutine var_missing_error @ %def var_list_set_log @ %def var_list_set_int @ %def var_list_set_real @ %def var_list_set_cmplx @ %def var_list_set_subevt @ %def var_list_set_pdg_array @ %def var_list_set_string @ %def var_mismatch_error @ %def var_missing_error @ Import values for the current variable list from another list. -<>= - public :: var_list_import <>= procedure :: import => var_list_import +<>= + module subroutine var_list_import (var_list, src_list) + class(var_list_t), intent(inout) :: var_list + type(var_list_t), intent(in) :: src_list + end subroutine var_list_import <>= - subroutine var_list_import (var_list, src_list) + module subroutine var_list_import (var_list, src_list) class(var_list_t), intent(inout) :: var_list type(var_list_t), intent(in) :: src_list type(var_entry_t), pointer :: var, src var => var_list%first do while (associated (var)) src => var_list_get_var_ptr (src_list, var%name) if (associated (src)) then call var_entry_copy_value (var, src) end if var => var%next end do end subroutine var_list_import @ %def var_list_import @ Mark all entries in the current variable list as undefined. This is done when a local variable list is discarded. If the local list is used again (by a loop), the entries will be re-initialized. -<>= - public :: var_list_undefine <>= procedure :: undefine => var_list_undefine +<>= + recursive module subroutine var_list_undefine (var_list, follow_link) + class(var_list_t), intent(inout) :: var_list + logical, intent(in), optional :: follow_link + end subroutine var_list_undefine <>= - recursive subroutine var_list_undefine (var_list, follow_link) + recursive module subroutine var_list_undefine (var_list, follow_link) class(var_list_t), intent(inout) :: var_list logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var logical :: rec rec = .true.; if (present (follow_link)) rec = follow_link var => var_list%first do while (associated (var)) call var_entry_undefine (var) var => var%next end do if (rec .and. associated (var_list%next)) then call var_list_undefine (var_list%next, follow_link=follow_link) end if end subroutine var_list_undefine @ %def var_list_undefine @ Make a deep copy of a variable list. -<>= - public :: var_list_init_snapshot <>= procedure :: init_snapshot => var_list_init_snapshot +<>= + recursive module subroutine var_list_init_snapshot & + (var_list, vars_in, follow_link) + class(var_list_t), intent(out) :: var_list + type(var_list_t), intent(in) :: vars_in + logical, intent(in), optional :: follow_link + end subroutine var_list_init_snapshot <>= - recursive subroutine var_list_init_snapshot (var_list, vars_in, follow_link) + recursive module subroutine var_list_init_snapshot & + (var_list, vars_in, follow_link) class(var_list_t), intent(out) :: var_list type(var_list_t), intent(in) :: vars_in logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var, var_in type(var_list_t), pointer :: var_list_next logical :: rec rec = .true.; if (present (follow_link)) rec = follow_link var_in => vars_in%first do while (associated (var_in)) allocate (var) call var_entry_init_copy (var, var_in) call var_entry_copy_value (var, var_in) call var_list_append (var_list, var) var_in => var_in%next end do if (rec .and. associated (vars_in%next)) then allocate (var_list_next) call var_list_init_snapshot (var_list_next, vars_in%next) call var_list%link (var_list_next) end if end subroutine var_list_init_snapshot @ %def var_list_init_snapshot @ Check if a user variable can be set. The [[new]] flag is set if the user variable has an explicit declaration. If an error occurs, return [[V_NONE]] as variable type. Also determine the actual type of generic numerical variables, which enter the procedure with type [[V_NONE]]. -<>= - public :: var_list_check_user_var <>= procedure :: check_user_var => var_list_check_user_var +<>= + module subroutine var_list_check_user_var (var_list, name, type, new) + class(var_list_t), intent(in), target :: var_list + type(string_t), intent(in) :: name + integer, intent(inout) :: type + logical, intent(in) :: new + end subroutine var_list_check_user_var <>= - subroutine var_list_check_user_var (var_list, name, type, new) + module subroutine var_list_check_user_var (var_list, name, type, new) class(var_list_t), intent(in), target :: var_list type(string_t), intent(in) :: name integer, intent(inout) :: type logical, intent(in) :: new type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name) if (associated (var)) then if (type == V_NONE) then type = var_entry_get_type (var) end if if (var_entry_is_locked (var)) then call msg_fatal ("Variable '" // char (name) & // "' is not user-definable") type = V_NONE return else if (new) then if (var_entry_is_intrinsic (var)) then call msg_fatal ("Intrinsic variable '" & // char (name) // "' redeclared") type = V_NONE return end if if (var_entry_get_type (var) /= type) then call msg_fatal ("Variable '" // char (name) // "' " & // "redeclared with different type") type = V_NONE return end if end if end if end subroutine var_list_check_user_var @ %def var_list_check_user_var @ \subsection{Default values for global var list} <>= procedure :: init_defaults => var_list_init_defaults +<>= + module subroutine var_list_init_defaults (var_list, seed, paths) + class(var_list_t), intent(out) :: var_list + integer, intent(in) :: seed + type(paths_t), intent(in), optional :: paths + end subroutine var_list_init_defaults <>= - subroutine var_list_init_defaults (var_list, seed, paths) + module subroutine var_list_init_defaults (var_list, seed, paths) class(var_list_t), intent(out) :: var_list integer, intent(in) :: seed type(paths_t), intent(in), optional :: paths call var_list%set_beams_defaults (paths) call var_list%set_core_defaults (seed) call var_list%set_integration_defaults () call var_list%set_phase_space_defaults () call var_list%set_gamelan_defaults () call var_list%set_clustering_defaults () call var_list%set_isolation_recomb_defaults () call var_list%set_eio_defaults () call var_list%set_shower_defaults () call var_list%set_hadronization_defaults () call var_list%set_tauola_defaults () call var_list%set_mlm_matching_defaults () call var_list%set_powheg_matching_defaults () call var_list%append_log (var_str ("?ckkw_matching"), .false., & intrinsic=.true., description=var_str ('Master flag that switches ' // & 'on the CKKW(-L) (LO) matching between hard scattering matrix ' // & 'elements and QCD parton showers. Note that this is not yet ' // & '(completely) implemented in \whizard. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...})')) call var_list%set_openmp_defaults () call var_list%set_mpi_defaults () call var_list%set_nlo_defaults () end subroutine var_list_init_defaults @ %def var_list_init_defaults @ <>= procedure :: set_beams_defaults => var_list_set_beams_defaults +<>= + module subroutine var_list_set_beams_defaults (var_list, paths) + type(paths_t), intent(in), optional :: paths + class(var_list_t), intent(inout) :: var_list + end subroutine var_list_set_beams_defaults <>= - subroutine var_list_set_beams_defaults (var_list, paths) + module subroutine var_list_set_beams_defaults (var_list, paths) type(paths_t), intent(in), optional :: paths class(var_list_t), intent(inout) :: var_list call var_list%append_real (var_str ("sqrts"), & intrinsic=.true., & description=var_str ('Real variable in order to set the center-of-mass ' // & 'energy for the collisions (collider energy $\sqrt{s}$, not ' // & 'hard interaction energy $\sqrt{\hat{s}}$): \ttt{sqrts = {\em ' // & '} [ {\em } ]}. The physical unit can be one ' // & 'of the following \ttt{eV}, \ttt{keV}, \ttt{MeV}, \ttt{GeV}, ' // & 'and \ttt{TeV}. If absent, \whizard\ takes \ttt{GeV} as its ' // & 'standard unit. Note that this variable is absolutely mandatory ' // & 'for integration and simulation of scattering processes.')) call var_list%append_real (var_str ("luminosity"), 0._default, & intrinsic=.true., & description=var_str ('This specifier \ttt{luminosity = {\em ' // & '}} sets the integrated luminosity (in inverse femtobarns, ' // & 'fb${}^{-1}$) for the event generation of the processes in the ' // & '\sindarin\ input files. Note that WHIZARD itself chooses the ' // & 'number from the \ttt{luminosity} or from the \ttt{n\_events} ' // & 'specifier, whichever would give the larger number of events. ' // & 'As this depends on the cross section under consideration, it ' // & 'might be different for different processes in the process list. ' // & '(cf. \ttt{n\_events}, \ttt{\$sample}, \ttt{sample\_format}, \ttt{?unweighted})')) call var_list%append_log (var_str ("?sf_trace"), .false., & intrinsic=.true., & description=var_str ('Debug flag that writes out detailed information ' // & 'about the structure function setup into the file \ttt{{\em ' // & '}\_sftrace.dat}. This file name can be changed ' // & 'with ($\to$) \ttt{\$sf\_trace\_file}.')) call var_list%append_string (var_str ("$sf_trace_file"), var_str (""), & intrinsic=.true., & description=var_str ('\ttt{\$sf\_trace\_file = "{\em }"} ' // & 'allows to change the detailed structure function information ' // & 'switched on by the debug flag ($\to$) \ttt{?sf\_trace} into ' // & 'a different file \ttt{{\em }} than the default ' // & '\ttt{{\em }\_sftrace.dat}.')) call var_list%append_log (var_str ("?sf_allow_s_mapping"), .true., & intrinsic=.true., & description=var_str ('Flag that determines whether special mappings ' // & 'for processes with structure functions and $s$-channel resonances ' // & 'are applied, e.g. Drell-Yan at hadron colliders, or $Z$ production ' // & 'at linear colliders with beamstrahlung and ISR.')) if (present (paths)) then call var_list%append_string (var_str ("$lhapdf_dir"), paths%lhapdfdir, & intrinsic=.true., & description=var_str ('String variable that tells the path ' // & 'where the \lhapdf\ library and PDF sets can be found. When ' // & 'the library has been correctly recognized during configuration, ' // & 'this is automatically set by \whizard. (cf. also \ttt{lhapdf}, ' // & '\ttt{\$lhapdf\_file}, \ttt{lhapdf\_photon}, \ttt{\$lhapdf\_photon\_file}, ' // & '\ttt{lhapdf\_member}, \ttt{lhapdf\_photon\_scheme})')) else call var_list%append_string (var_str ("$lhapdf_dir"), var_str(""), & intrinsic=.true., & description=var_str ('String variable that tells the path ' // & 'where the \lhapdf\ library and PDF sets can be found. When ' // & 'the library has been correctly recognized during configuration, ' // & 'this is automatically set by \whizard. (cf. also \ttt{lhapdf}, ' // & '\ttt{\$lhapdf\_file}, \ttt{lhapdf\_photon}, \ttt{\$lhapdf\_photon\_file}, ' // & '\ttt{lhapdf\_member}, \ttt{lhapdf\_photon\_scheme})')) end if call var_list%append_string (var_str ("$lhapdf_file"), var_str (""), & intrinsic=.true., & description=var_str ('This string variable \ttt{\$lhapdf\_file ' // & '= "{\em }"} allows to specify the PDF set \ttt{{\em ' // & '}} from the external \lhapdf\ library. It must match ' // & 'the exact name of the PDF set from the \lhapdf\ library. The ' // & 'default is empty, and the default set from \lhapdf\ is taken. ' // & 'Only one argument is possible, the PDF set must be identical ' // & 'for both beams, unless there are fundamentally different beam ' // & 'particles like proton and photon. (cf. also \ttt{lhapdf}, \ttt{\$lhapdf\_dir}, ' // & '\ttt{lhapdf\_photon}, \ttt{\$lhapdf\_photon\_file}, \ttt{lhapdf\_photon\_scheme}, ' // & '\ttt{lhapdf\_member})')) call var_list%append_string (var_str ("$lhapdf_photon_file"), var_str (""), & intrinsic=.true., & description=var_str ('String variable \ttt{\$lhapdf\_photon\_file ' // & '= "{\em }"} analagous to ($\to$) \ttt{\$lhapdf\_file} ' // & 'for photon PDF structure functions from the external \lhapdf\ ' // & 'library. The name must exactly match the one of the set from ' // & '\lhapdf. (cf. \ttt{beams}, \ttt{lhapdf}, \ttt{\$lhapdf\_dir}, ' // & '\ttt{\$lhapdf\_file}, \ttt{\$lhapdf\_photon\_file}, \ttt{lhapdf\_member}, ' // & '\ttt{lhapdf\_photon\_scheme})')) call var_list%append_int (var_str ("lhapdf_member"), 0, & intrinsic=.true., & description=var_str ('Integer variable that specifies the number ' // & 'of the corresponding PDF set chosen via the command ($\to$) ' // & '\ttt{\$lhapdf\_file} or ($\to$) \ttt{\$lhapdf\_photon\_file} ' // & 'from the external \lhapdf\ library. E.g. error PDF sets can ' // & 'be chosen by this. (cf. also \ttt{lhapdf}, \ttt{\$lhapdf\_dir}, ' // & '\ttt{\$lhapdf\_file}, \ttt{lhapdf\_photon}, \ttt{\$lhapdf\_photon\_file}, ' // & '\ttt{lhapdf\_photon\_scheme})')) call var_list%append_int (var_str ("lhapdf_photon_scheme"), 0, & intrinsic=.true., & description=var_str ('Integer parameter that controls the different ' // & 'available schemes for photon PDFs inside the external \lhapdf\ ' // & 'library. For more details see the \lhapdf\ manual. (cf. also ' // & '\ttt{lhapdf}, \ttt{\$lhapdf\_dir}, \ttt{\$lhapdf\_file}, \ttt{lhapdf\_photon}, ' // & '\ttt{\$lhapdf\_photon\_file}, \ttt{lhapdf\_member})')) call var_list%append_string (var_str ("$pdf_builtin_set"), var_str ("CTEQ6L"), & intrinsic=.true., & description=var_str ("For \whizard's internal PDF structure functions " // & 'for hadron colliders, this string variable allows to set the ' // & 'particular PDF set. (cf. also \ttt{pdf\_builtin}, \ttt{pdf\_builtin\_photon})')) call var_list%append_log (var_str ("?hoppet_b_matching"), .false., & intrinsic=.true., & description=var_str ('Flag that switches on the matching between ' // & '4- and 5-flavor schemes for hadron collider $b$-parton initiated ' // & 'processes. Works either with builtin PDFs or with the external ' // & '\lhapdf\ interface. Needs the external \ttt{HOPPET} library ' // & 'to be linked. (cf. \ttt{beams}, \ttt{pdf\_builtin}, \ttt{lhapdf})')) call var_list%append_real (var_str ("isr_alpha"), 0._default, & intrinsic=.true., & description=var_str ('For lepton collider initial-state QED ' // & 'radiation (ISR), this real parameter sets the value of $\alpha_{em}$ ' // & 'used in the structure function. If not set, it is taken from ' // & 'the parameter set of the physics model in use (cf. also \ttt{isr}, ' // & '\ttt{isr\_q\_max}, \ttt{isr\_mass}, \ttt{isr\_order}, \ttt{?isr\_recoil}, ' // & '\ttt{?isr\_keep\_energy})')) call var_list%append_real (var_str ("isr_q_max"), 0._default, & intrinsic=.true., & description=var_str ('This real parameter allows to set the ' // & 'scale of the initial-state QED radiation (ISR) structure function. ' // & 'If not set, it is taken internally to be $\sqrt{s}$. (cf. ' // & 'also \ttt{isr}, \ttt{isr\_alpha}, \ttt{isr\_mass}, \ttt{isr\_order}, ' // & '\ttt{?isr\_recoil}, \ttt{?isr\_keep\_energy})')) call var_list%append_real (var_str ("isr_mass"), 0._default, & intrinsic=.true., & description=var_str ('This real parameter allows to set by hand ' // & 'the mass of the incoming particle for lepton collider initial-state ' // & 'QED radiation (ISR). If not set, the mass for the initial beam ' // & 'particle is taken from the model in use. (cf. also \ttt{isr}, ' // & '\ttt{isr\_q\_max}, \ttt{isr\_alpha}, \ttt{isr\_order}, \ttt{?isr\_recoil}, ' // & '\ttt{?isr\_keep\_energy})')) call var_list%append_int (var_str ("isr_order"), 3, & intrinsic=.true., & description=var_str ('For lepton collider initial-state QED ' // & 'radiation (ISR), this integer parameter allows to set the order ' // & 'up to which hard-collinear radiation is taken into account. ' // & 'Default is the highest available, namely third order. (cf. ' // & 'also \ttt{isr}, \ttt{isr\_q\_max}, \ttt{isr\_mass}, \ttt{isr\_alpha}, ' // & '\ttt{?isr\_recoil}, \ttt{?isr\_keep\_energy})')) call var_list%append_log (var_str ("?isr_recoil"), .false., & intrinsic=.true., & description=var_str ('Flag to switch on recoil, i.e. a non-vanishing ' // & '$p_T$-kick for the lepton collider initial-state QED radiation ' // & '(ISR). (cf. also \ttt{isr}, \ttt{isr}, \ttt{isr\_alpha}, \ttt{isr\_mass}, ' // & '\ttt{isr\_order}, \ttt{isr\_q\_max})')) call var_list%append_log (var_str ("?isr_keep_energy"), .false., & intrinsic=.true., & description=var_str ('As the splitting kinematics for the ISR ' // & 'structure function violates Lorentz invariance when the recoil ' // & 'is switched on, this flag forces energy conservation when set ' // & 'to true, otherwise violating energy conservation. (cf. also ' // & '\ttt{isr}, \ttt{isr\_q\_max}, \ttt{isr\_mass}, \ttt{isr\_order}, ' // & '\ttt{?isr\_recoil}, \ttt{?isr\_alpha})')) call var_list%append_log (var_str ("?isr_handler"), .false., & intrinsic=.true., & description=var_str ('Activate ISR ' // & 'handler for event generation (no effect on integration). ' // & 'Requires \ttt{isr\_recoil = false}')) call var_list%append_string (var_str ("$isr_handler_mode"), & var_str ("trivial"), & intrinsic=.true., & description=var_str ('Operation mode for the ISR ' // & 'event handler. Allowed values: \ttt{trivial} (no effect), ' // & '\ttt{recoil} (recoil kinematics with two photons)')) call var_list%append_log (var_str ("?isr_handler_keep_mass"), .true., & intrinsic=.true., & description=var_str ('If \ttt{true} (default), force the incoming ' // & 'partons of the hard process (after radiation) on their mass ' // & 'shell. Otherwise, insert massless on-shell momenta. This ' // & 'applies only for event generation (no effect on integration, ' // & 'cf.\ also \ttt{?isr\_handler})')) call var_list%append_string (var_str ("$epa_mode"), & var_str ("default"), intrinsic=.true., & description=var_str ('For the equivalent photon approximation ' // & '(EPA), this string variable defines the mode, i.e. the explicit ' // & 'formula for the EPA distribution. For more details cf. the manual. ' // & 'Possible are \ttt{default} (\ttt{Budnev\_617}), \ttt{Budnev\_616e}, ' // & '\ttt{log\_power}, \ttt{log\_simple}, and \ttt{log}. ' // & '(cf. also \ttt{epa}, \ttt{epa\_x\_min}, \ttt{epa\_mass}, \ttt{epa\_e\_max}, ' // & '\ttt{epa\_q\_min}, \ttt{?epa\_recoil}, \ttt{?epa\_keep\_energy}, ' // & '\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})')) call var_list%append_real (var_str ("epa_alpha"), 0._default, & intrinsic=.true., & description=var_str ('For the equivalent photon approximation ' // & '(EPA), this real parameter sets the value of $\alpha_{em}$ ' // & 'used in the structure function. If not set, it is taken from ' // & 'the parameter set of the physics model in use (cf. also \ttt{epa}, ' // & '\ttt{epa\_x\_min}, \ttt{epa\_mass}, \ttt{epa\_e\_max}, \ttt{epa\_q\_min}, ' // & '\ttt{?epa\_recoil}, \ttt{?epa\_keep\_energy}, \ttt{\$epa\_mode}, ' // & '\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})')) call var_list%append_real (var_str ("epa_x_min"), 0._default, & intrinsic=.true., & description=var_str ('Real parameter that sets the lower cutoff ' // & 'for the energy fraction in the splitting for the equivalent-photon ' // & 'approximation (EPA). This parameter has to be set by the user ' // & 'to a non-zero value smaller than one. (cf. also \ttt{epa}, ' // & '\ttt{epa\_e\_max}, \ttt{epa\_mass}, \ttt{epa\_alpha}, \ttt{epa\_q\_min}, ' // & '\ttt{?epa\_recoil}, \ttt{?epa\_keep\_energy}, \ttt{\$epa\_mode}, ' // & '\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})')) call var_list%append_real (var_str ("epa_q_min"), 0._default, & intrinsic=.true., & description=var_str ('In the equivalent-photon approximation ' // & '(EPA), this real parameters sets the minimal value for the ' // & 'transferred momentum. Either this parameter or the mass of ' // & 'the beam particle has to be non-zero. (cf. also \ttt{epa}, ' // & '\ttt{epa\_x\_min}, \ttt{epa\_mass}, \ttt{epa\_alpha}, \ttt{epa\_q\_max}, ' // & '\ttt{?epa\_recoil}, \ttt{?epa\_keep\_energy}, \ttt{\$epa\_mode}, ' // & '\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})')) call var_list%append_real (var_str ("epa_q_max"), 0._default, & intrinsic=.true., & description=var_str ('This real parameter allows to set the ' // & 'upper energy cutoff for the equivalent-photon approximation ' // & '(EPA). If not set, \whizard\ simply takes the collider energy, ' // & '$\sqrt{s}$. (cf. also \ttt{epa}, \ttt{epa\_x\_min}, \ttt{epa\_mass}, ' // & '\ttt{epa\_alpha}, \ttt{epa\_q\_min}, \ttt{?epa\_recoil}, \ttt{\$epa\_mode}, ' // & '\ttt{?epa\_keep\_energy}, \ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})')) call var_list%append_real (var_str ("epa_mass"), 0._default, & intrinsic=.true., & description=var_str ('This real parameter allows to set by hand ' // & 'the mass of the incoming particle for the equivalent-photon ' // & 'approximation (EPA). If not set, the mass for the initial beam ' // & 'particle is taken from the model in use. (cf. also \ttt{epa}, ' // & '\ttt{epa\_x\_min}, \ttt{epa\_e\_max}, \ttt{epa\_alpha}, \ttt{epa\_q\_min}, ' // & '\ttt{?epa\_recoil}, \ttt{?epa\_keep\_energy}, \ttt{\$epa\_mode}. ' // & '\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})')) call var_list%append_log (var_str ("?epa_recoil"), .false., & intrinsic=.true., & description=var_str ('Flag to switch on recoil, i.e. a non-vanishing ' // & '$p_T$-kick for the equivalent-photon approximation (EPA). ' // & '(cf. also \ttt{epa}, \ttt{epa\_x\_min}, \ttt{epa\_mass}, \ttt{epa\_alpha}, ' // & '\ttt{epa\_e\_max}, \ttt{epa\_q\_min}, \ttt{?epa\_keep\_energy}, ' // & '\ttt{\$epa\_mode}, \ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})')) call var_list%append_log (var_str ("?epa_keep_energy"), .false., & intrinsic=.true., & description=var_str ('As the splitting kinematics for the EPA ' // & 'structure function violates Lorentz invariance when the recoil ' // & 'is switched on, this flag forces energy conservation when set ' // & 'to true, otherwise violating energy conservation. (cf. also ' // & '\ttt{epa}, \ttt{epa\_x\_min}, \ttt{epa\_mass}, \ttt{epa\_alpha}, ' // & '\ttt{epa\_q\_min}, \ttt{?epa\_recoil}, \ttt{\$epa\_mode}, ' // & '\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})')) call var_list%append_log (var_str ("?epa_handler"), .false., & intrinsic=.true., & description=var_str ('Activate EPA ' // & 'handler for event generation (no effect on integration). ' // & 'Requires \ttt{epa\_recoil = false}')) call var_list%append_string (var_str ("$epa_handler_mode"), & var_str ("trivial"), & intrinsic=.true., & description=var_str ('Operation mode for the EPA ' // & 'event handler. Allowed values: \ttt{trivial} (no effect), ' // & '\ttt{recoil} (recoil kinematics with two beams)')) call var_list%append_real (var_str ("ewa_x_min"), 0._default, & intrinsic=.true., & description=var_str ('Real parameter that sets the lower cutoff ' // & 'for the energy fraction in the splitting for the equivalent ' // & '$W$ approximation (EWA). This parameter has to be set by the ' // & 'user to a non-zero value smaller than one. (cf. also \ttt{ewa}, ' // & '\ttt{ewa\_pt\_max}, \ttt{ewa\_mass}, \ttt{?ewa\_keep\_energy}, ' // & '\ttt{?ewa\_recoil})')) call var_list%append_real (var_str ("ewa_pt_max"), 0._default, & intrinsic=.true., & description=var_str ('This real parameter allows to set the ' // & 'upper $p_T$ cutoff for the equivalent $W$ approximation (EWA). ' // & 'If not set, \whizard\ simply takes the collider energy, $\sqrt{s}$. ' // & '(cf. also \ttt{ewa}, \ttt{ewa\_x\_min}, \ttt{ewa\_mass}, \ttt{?ewa\_keep\_energy}, ' // & '\ttt{?ewa\_recoil})')) call var_list%append_real (var_str ("ewa_mass"), 0._default, & intrinsic=.true., & description=var_str ('This real parameter allows to set by hand ' // & 'the mass of the incoming particle for the equivalent $W$ approximation ' // & '(EWA). If not set, the mass for the initial beam particle is ' // & 'taken from the model in use. (cf. also \ttt{ewa}, \ttt{ewa\_x\_min}, ' // & '\ttt{ewa\_pt\_max}, \ttt{?ewa\_keep\_energy}, \ttt{?ewa\_recoil})')) call var_list%append_log (var_str ("?ewa_recoil"), .false., & intrinsic=.true., & description=var_str ('For the equivalent $W$ approximation (EWA), ' // & 'this flag switches on recoil, i.e. non-collinear splitting. ' // & '(cf. also \ttt{ewa}, \ttt{ewa\_x\_min}, \ttt{ewa\_pt\_max}, ' // & '\ttt{ewa\_mass}, \ttt{?ewa\_keep\_energy})')) call var_list%append_log (var_str ("?ewa_keep_energy"), .false., & intrinsic=.true., & description=var_str ('As the splitting kinematics for the equivalent ' // & '$W$ approximation (EWA) violates Lorentz invariance when the ' // & 'recoil is switched on, this flag forces energy conservation ' // & 'when set to true, otherwise violating energy conservation. ' // & '(cf. also \ttt{ewa}, \ttt{ewa\_x\_min}, \ttt{ewa\_pt\_max}, ' // & '\ttt{ewa\_mass}, \ttt{?ewa\_recoil})')) call var_list%append_log (var_str ("?circe1_photon1"), .false., & intrinsic=.true., & description=var_str ('Flag to tell \whizard\ to use the photon ' // & 'of the \circeone\ beamstrahlung structure function as initiator ' // & 'for the hard scattering process in the first beam. (cf. also ' // & '\ttt{circe1}, \ttt{?circe1\_photon2}, \ttt{circe1\_sqrts}, ' // & '\ttt{?circe1\_generate}, \ttt{?circe1\_map}, \ttt{circe1\_eps}, ' // & '\newline \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // & '\ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \newline' // & '\ttt{?circe1\_with\_radiation})')) call var_list%append_log (var_str ("?circe1_photon2"), .false., & intrinsic=.true., & description=var_str ('Flag to tell \whizard\ to use the photon ' // & 'of the \circeone\ beamstrahlung structure function as initiator ' // & 'for the hard scattering process in the second beam. (cf. also ' // & '\ttt{circe1}, \ttt{?circe1\_photon1}, \ttt{circe1\_sqrts}, ' // & '\ttt{?circe1\_generate}, \ttt{?circe1\_map}, \ttt{circe1\_eps}, ' // & '\newline \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // & '\ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{circe1\_chat}, ' // & '\newline\ttt{?circe1\_with\_radiation})')) call var_list%append_real (var_str ("circe1_sqrts"), & intrinsic=.true., & description=var_str ('Real parameter that allows to set the ' // & 'value of the collider energy for the lepton collider beamstrahlung ' // & 'structure function \circeone. If not set, $\sqrt{s}$ is taken. ' // & '(cf. also \ttt{circe1}, \ttt{?circe1\_photon1}, \ttt{?circe1\_photon2}, ' // & '\ttt{?circe1\_generate}, \ttt{?circe1\_map}, \ttt{circe1\_eps}, ' // & '\newline \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // & '\ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \newline' // & '\ttt{?circe1\_with\_radiation})')) call var_list%append_log (var_str ("?circe1_generate"), .true., & intrinsic=.true., & description=var_str ('Flag that determines whether the \circeone\ ' // & 'structure function for lepton collider beamstrahlung uses the ' // & 'generator mode for the spectrum, or a pre-defined (semi-)analytical ' // & 'parameterization. Default is the generator mode. (cf. also ' // & '\ttt{circe1}, \ttt{?circe1\_photon1}, \newline \ttt{?circe1\_photon2}, ' // & '\ttt{circe1\_sqrts}, \ttt{?circe1\_map}, \ttt{circe1\_mapping\_slope}, ' // & '\ttt{circe1\_eps}, \newline \ttt{circe1\_ver}, \ttt{circe1\_rev}, ' // & '\ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \ttt{?circe1\_with\_radiation})')) call var_list%append_log (var_str ("?circe1_map"), .true., & intrinsic=.true., & description=var_str ('Flag that determines whether the \circeone\ ' // & 'structure function for lepton collider beamstrahlung uses special ' // & 'mappings for $s$-channel resonances. (cf. also \ttt{circe1}, ' // & '\ttt{?circe1\_photon1}, \newline \ttt{?circe1\_photon2}, ' // & '\ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, ' // & '\ttt{circe1\_mapping\_slope}, \ttt{circe1\_eps}, \newline ' // & '\ttt{circe1\_ver}, \ttt{circe1\_rev}, \ttt{\$circe1\_acc}, ' // & '\ttt{circe1\_chat}, \ttt{?circe1\_with\_radiation})')) call var_list%append_real (var_str ("circe1_mapping_slope"), 2._default, & intrinsic=.true., & description=var_str ('Real parameter that allows to vary the ' // & 'slope of the mapping function for the \circeone\ structure ' // & 'function for lepton collider beamstrahlung from the default ' // & 'value \ttt{2.}. (cf. also \ttt{circe1}, \ttt{?circe1\_photon1}, ' // & '\ttt{?circe1\_photon2}, \ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, ' // & '\ttt{?circe1\_map}, \ttt{circe1\_eps}, \ttt{circe1\_ver}, ' // & '\ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \newline' // & '\ttt{?circe1\_with\_radiation})')) call var_list%append_real (var_str ("circe1_eps"), 1e-5_default, & intrinsic=.true., & description=var_str ('Real parameter, that takes care of the ' // & 'mapping of the peak in the lepton collider beamstrahlung structure ' // & 'function spectrum of \circeone. (cf. also \ttt{circe1}, \ttt{?circe1\_photons}, ' // & '\ttt{?circe1\_photon2}, \ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, ' // & '\ttt{?circe1\_map}, \ttt{circe1\_eps}, \newline ' // & '\ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, \ttt{circe1\_rev}, ' // & '\ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \newline\ttt{?circe1\_with\_radiation})')) call var_list%append_int (var_str ("circe1_ver"), 0, intrinsic=.true., & description=var_str ('Integer parameter that sets the internal ' // & 'versioning number of the \circeone\ structure function for lepton-collider ' // & 'beamstrahlung. It has to be set by the user explicitly, it takes ' // & 'values from one to ten. (cf. also \ttt{circe1}, \ttt{?circe1\_photon1}, ' // & '\ttt{?circe1\_photon2}, \ttt{?circe1\_generate}, \ttt{?circe1\_map}, ' // & '\ttt{circe1\_eps}, \ttt{circe1\_mapping\_slope}, \ttt{circe1\_sqrts}, ' // & '\ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{circe1\_chat}, ' // & '\ttt{?circe1\_with\_radiation})')) call var_list%append_int (var_str ("circe1_rev"), 0, intrinsic=.true., & description=var_str ('Integer parameter that sets the internal ' // & 'revision number of the \circeone\ structure function for lepton-collider ' // & 'beamstrahlung. The default \ttt{0} translates always into the ' // & 'most recent version; older versions have to be accessed through ' // & 'the explicit revision date. For more details cf.~the \circeone ' // & 'manual. (cf. also \ttt{circe1}, \ttt{?circe1\_photon1}, \ttt{?circe1\_photon2}, ' // & '\ttt{?circe1\_generate}, \ttt{?circe1\_map}, \ttt{circe1\_eps}, ' // & '\ttt{circe1\_mapping\_slope}, \ttt{circe1\_sqrts}, \ttt{circe1\_ver}, ' // & '\ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \ttt{?circe1\_with\_radiation})')) call var_list%append_string (var_str ("$circe1_acc"), var_str ("SBAND"), & intrinsic=.true., & description=var_str ('String variable that specifies the accelerator ' // & 'type for the \circeone\ structure function for lepton-collider ' // & 'beamstrahlung. (\ttt{?circe1\_photons}, \ttt{?circe1\_photon2}, ' // & '\ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, \ttt{?circe1\_map}, ' // & '\ttt{circe1\_eps}, \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // & '\newline \ttt{circe1\_rev}, \ttt{circe1\_chat}, \ttt{?circe1\_with\_radiation})')) call var_list%append_int (var_str ("circe1_chat"), 0, intrinsic=.true., & description=var_str ('Chattiness of the \circeone\ structure ' // & 'function for lepton-collider beamstrahlung. The higher the integer ' // & 'value, the more information will be given out by the \circeone\ ' // & 'package. (\ttt{?circe1\_photons}, \ttt{?circe1\_photon2}, ' // & '\ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, \ttt{?circe1\_map}, ' // & '\ttt{circe1\_eps}, \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // & '\newline \ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{?circe1\_with\_radiation})')) call var_list%append_log (var_str ("?circe1_with_radiation"), .false., & intrinsic=.true., & description=var_str ('This logical decides whether the additional photon ' // & 'or electron ("beam remnant") will be considered in the event record or ' // & 'not. (\ttt{?circe1\_photons}, \ttt{?circe1\_photon2}, ' // & '\ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, \ttt{?circe1\_map}, ' // & '\ttt{circe1\_eps}, \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // & '\newline \ttt{circe1\_rev}, \ttt{\$circe1\_acc})')) call var_list%append_log (var_str ("?circe2_polarized"), .true., & intrinsic=.true., & description=var_str ('Flag whether the photon spectra from the ' // & '\circetwo\ structure function for lepton colliders should be ' // & 'treated polarized. (cf. also \ttt{circe2}, \ttt{\$circe2\_file}, ' // & '\ttt{\$circe2\_design})')) call var_list%append_string (var_str ("$circe2_file"), & intrinsic=.true., & description=var_str ('String variable by which the corresponding ' // & 'photon collider spectrum for the \circetwo\ structure function ' // & 'can be selected. (cf. also \ttt{circe2}, \ttt{?circe2\_polarized}, ' // & '\ttt{\$circe2\_design})')) call var_list%append_string (var_str ("$circe2_design"), var_str ("*"), & intrinsic=.true., & description=var_str ('String variable that sets the collider ' // & 'design for the \circetwo\ structure function for photon collider ' // & 'spectra. (cf. also \ttt{circe2}, \ttt{\$circe2\_file}, \ttt{?circe2\_polarized})')) call var_list%append_real (var_str ("gaussian_spread1"), 0._default, & intrinsic=.true., & description=var_str ('Parameter that sets the energy spread ' // & '($\sigma$ value) of the first beam for a Gaussian spectrum. ' // & '(cf. \ttt{gaussian})')) call var_list%append_real (var_str ("gaussian_spread2"), 0._default, & intrinsic=.true., & description=var_str ('Ditto, for the second beam.')) call var_list%append_string (var_str ("$beam_events_file"), & intrinsic=.true., & description=var_str ('String variable that allows to set the ' // & "name of the external file from which a beamstrahlung's spectrum " // & 'for lepton colliders as pairs of energy fractions is read in. ' // & '(cf. also \ttt{beam\_events}, \ttt{?beam\_events\_warn\_eof})')) call var_list%append_log (var_str ("?beam_events_warn_eof"), .true., & intrinsic=.true., & description=var_str ('Flag that tells \whizard\ to ' // & 'issue a warning when in a simulation the end of an external ' // & "file for beamstrahlung's spectra for lepton colliders are reached, " // & 'and energy fractions from the beginning of the file are reused. ' // & '(cf. also \ttt{beam\_events}, \ttt{\$beam\_events\_file})')) call var_list%append_log (var_str ("?energy_scan_normalize"), .false., & intrinsic=.true., & description=var_str ('Normalization flag for the energy scan ' // & 'structure function: if set the total cross section is normalized ' // & 'to unity. (cf. also \ttt{energy\_scan})')) call var_list%append_string (var_str ("$negative_sf"), var_str ("default"), & intrinsic=.true., & description=var_str ('String variable to set the behavior to either ' // & 'keep negative structure function/PDF values or set them to zero. ' // & 'The default (\ttt{"default"}) takes the first option for NLO and the ' // & 'second for LO processes. Explicit behavior can be set with ' // & '\ttt{"positive"} or \ttt{"negative"}.')) end subroutine var_list_set_beams_defaults @ %def var_list_set_beams_defaults @ <>= procedure :: set_core_defaults => var_list_set_core_defaults +<>= + module subroutine var_list_set_core_defaults (var_list, seed) + class(var_list_t), intent(inout) :: var_list + integer, intent(in) :: seed + end subroutine var_list_set_core_defaults <>= - subroutine var_list_set_core_defaults (var_list, seed) + module subroutine var_list_set_core_defaults (var_list, seed) class(var_list_t), intent(inout) :: var_list integer, intent(in) :: seed logical, target, save :: known = .true. !!! ?????? real(default), parameter :: real_specimen = 1. call var_list_append_log_ptr & (var_list, var_str ("?logging"), logging, known, & intrinsic=.true., & description=var_str ('This logical -- when set to \ttt{false} ' // & '-- suppresses writing out a logfile (default: \ttt{whizard.log}) ' // & 'for the whole \whizard\ run, or when \whizard\ is run with the ' // & '\ttt{--no-logging} option, to suppress parts of the logging ' // & 'when setting it to \ttt{true} again at a later part of the ' // & '\sindarin\ input file. Mainly for debugging purposes. ' // & '(cf. also \ttt{?openmp\_logging}, \ttt{?mpi\_logging})')) call var_list%append_string (var_str ("$job_id"), & intrinsic=.true., & description=var_str ('Arbitrary string that can be used for ' // & 'creating unique names. The variable is initialized with the ' // & 'value of the \ttt{job\_id} option on startup. (cf. also ' // & '\ttt{\$compile\_workspace}, \ttt{\$run\_id})')) call var_list%append_string (var_str ("$compile_workspace"), & intrinsic=.true., & description=var_str ('If set, create process source code ' // & 'and process-driver library code in a subdirectory with this ' // & 'name. If non-existent, the directory will be created. (cf. ' // & 'also \ttt{\$job\_id}, \ttt{\$run\_id}, \ttt{\$integrate\_workspace})')) call var_list%append_int (var_str ("seed"), seed, & intrinsic=.true., & description=var_str ('Integer variable \ttt{seed = {\em }} ' // & 'that allows to set a specific random seed \ttt{num}. If not ' // & 'set, \whizard\ takes the time from the system clock to determine ' // & 'the random seed.')) call var_list%append_string (var_str ("$model_name"), & intrinsic=.true., & description=var_str ('This variable makes the locally used physics ' // & 'model available as a string, e.g. as \ttt{show (\$model\_name)}. ' // & 'However, the user is not able to change the current model by ' // & 'setting this variable to a different string. (cf. also \ttt{model}, ' // & '\ttt{\$library\_name}, \ttt{printf}, \ttt{show})')) call var_list%append_int (var_str ("process_num_id"), & intrinsic=.true., & description=var_str ('Using the integer \ttt{process\_num\_id ' // & '= {\em }} one can set a numerical identifier for processes ' // & 'within a process library. This can be set either just before ' // & 'the corresponding \ttt{process} definition or as an optional ' // & 'local argument of the latter. (cf. also \ttt{process}, ' // & '\ttt{?proc\_as\_run\_id}, \ttt{lcio\_run\_id})')) call var_list%append_log (var_str ("?proc_as_run_id"), .true., & intrinsic=.true., & description=var_str ('Normally, for LCIO the process ID (cf. ' // & '\ttt{process\_num\_id}) is used as run ID, unless this flag is ' // & 'set to \ttt{false}, cf. also \ttt{process}, \ttt{lcio\_run\_id}.')) call var_list%append_int (var_str ("lcio_run_id"), 0, & intrinsic=.true., & description=var_str ('Allows to set an integer run ID for the LCIO ' // & 'event format. Normally, the process ID is taken as run ID, unless ' // & 'the flag (cf.) \ttt{?proc\_as\_run\_id} is set to \ttt{false}, ' // & 'cf. also \ttt{process}.')) call var_list%append_string (var_str ("$method"), var_str ("omega"), & intrinsic=.true., & description=var_str ('This string variable specifies the method ' // & 'for the matrix elements to be used in the evaluation. The default ' // & "is the intrinsic \oMega\ matrix element generator " // & '(\ttt{"omega"}), other options are: \ttt{"ovm"}, \ttt{"unit\_test"}, ' // & '\ttt{"template\_unity"}, \ttt{"threshold"}. For processes defined ' // & '\ttt{"template"}, with \ttt{nlo\_calculation = ...}, please refer to ' // & '\ttt{\$born\_me\_method}, \ttt{\$real\_tree\_me\_method}, ' // & '\ttt{\$loop\_me\_method} and \ttt{\$correlation\_me\_method}.')) call var_list%append_log (var_str ("?report_progress"), .true., & intrinsic=.true., & description=var_str ('Flag for the \oMega\ matrix element generator ' // & 'whether to print out status messages about progress during ' // & 'matrix element generation. (cf. also \ttt{\$method}, \ttt{\$omega\_flags})')) call var_list%append_log (var_str ("?me_verbose"), .false., & description=var_str ("Flag determining whether " // & "the makefile command for generating and compiling the \oMega\ matrix " // & "element code is silent or verbose. Default is silent.")) call var_list%append_string (var_str ("$restrictions"), var_str (""), & intrinsic=.true., & description=var_str ('This is an optional argument for process ' // & 'definitions for the matrix element method \ttt{"omega"}. Using ' // & 'the following construction, it defines a string variable, \ttt{process ' // & '\newline {\em } = {\em }, {\em } ' // & '=> {\em }, {\em }, ... \{ \$restrictions ' // & '= "{\em }" \}}. The string argument \ttt{{\em ' // & '}} is directly transferred during the code ' // & 'generation to the ME generator \oMega. It has to be of the form ' // & '\ttt{n1 + n2 + ... \url{~} {\em }}, where ' // & '\ttt{n1} and so on are the numbers of the particles above in ' // & 'the process definition. The tilde specifies a certain intermediate ' // & 'state to be equal to the particle(s) in \ttt{particle (list)}. ' // & 'An example is \ttt{process eemm\_z = e1, E1 => e2, E2 ' // & '\{ \$restrictions = "1+2 \url{~} Z" \} } restricts the code ' // & 'to be generated for the process $e^- e^+ \to \mu^- \mu^+$ to ' // & 'the $s$-channel $Z$-boson exchange. For more details see Sec.~\ref{sec:omega_me} ' // & '(cf. also \ttt{process})')) call var_list%append_log (var_str ("?omega_write_phs_output"), .false., & intrinsic=.true., & description=var_str ('This flag decides whether a the phase-space ' // & 'output is produced by the \oMega\ matrix element generator. This ' // & 'output is written to file(s) and contains the Feynman diagrams ' // & 'which belong to the process(es) under consideration. The file is ' // & 'mandatory whenever the variable \ttt{\$phs\_method} has the value ' // & '\ttt{fast\_wood}, i.e. if the phase-space file is provided by ' // & 'cascades2.')) call var_list%append_string (var_str ("$omega_flags"), var_str (""), & intrinsic=.true., & description=var_str ('String variable that allows to pass flags ' // & 'to the \oMega\ matrix element generator. Normally, \whizard\ ' // & 'takes care of all flags automatically. Note that for restrictions ' // & 'of intermediate states, there is a special string variable: ' // & '(cf. $\to$) \ttt{\$restrictions}.')) call var_list%append_log (var_str ("?read_color_factors"), .true., & intrinsic=.true., & description=var_str ('This flag decides whether to read QCD ' // & 'color factors from the matrix element provided by each method, ' // & 'or to try and calculate the color factors in \whizard\ internally.')) call var_list%append_log (var_str ("?slha_read_input"), .true., & intrinsic=.true., & description=var_str ('Flag which decides whether \whizard\ reads ' // & 'in the SM and parameter information from the \ttt{SMINPUTS} ' // & 'and \ttt{MINPAR} common blocks of the SUSY Les Houches Accord ' // & 'files. (cf. also \ttt{read\_slha}, \ttt{write\_slha}, \ttt{?slha\_read\_spectrum}, ' // & '\ttt{?slha\_read\_decays})')) call var_list%append_log (var_str ("?slha_read_spectrum"), .true., & intrinsic=.true., & description=var_str ('Flag which decides whether \whizard\ reads ' // & 'in the whole spectrum and mixing angle information from the ' // & 'common blocks of the SUSY Les Houches Accord files. (cf. also ' // & '\ttt{read\_slha}, \ttt{write\_slha}, \ttt{?slha\_read\_decays}, ' // & '\ttt{?slha\_read\_input})')) call var_list%append_log (var_str ("?slha_read_decays"), .false., & intrinsic=.true., & description=var_str ('Flag which decides whether \whizard\ reads ' // & 'in the widths and branching ratios from the \ttt{DCINFO} common ' // & 'block of the SUSY Les Houches Accord files. (cf. also \ttt{read\_slha}, ' // & '\ttt{write\_slha}, \ttt{?slha\_read\_spectrum}, \ttt{?slha\_read\_input})')) call var_list%append_string (var_str ("$library_name"), & intrinsic=.true., & description=var_str ('Similar to \ttt{\$model\_name}, this string ' // & 'variable is used solely to access the name of the active process ' // & 'library, e.g. in \ttt{printf} statements. (cf. \ttt{compile}, ' // & '\ttt{library}, \ttt{printf}, \ttt{show}, \ttt{\$model\_name})')) call var_list%append_log (var_str ("?alphas_is_fixed"), .true., & intrinsic=.true., & description=var_str ('Flag that tells \whizard\ to use a non-running ' // & 'QCD $\alpha_s$. Note that this has to be set explicitly to $\ttt{false}$ ' // & 'if the user wants to use one of the running $\alpha_s$ options. ' // & '(cf. also \ttt{alphas\_order}, \ttt{?alphas\_from\_lhapdf}, ' // & '\ttt{?alphas\_from\_pdf\_builtin}, \ttt{alphas\_nf}, \ttt{?alphas\_from\_mz}, ' // & '\newline \ttt{?alphas\_from\_lambda\_qcd}, \ttt{lambda\_qcd})')) call var_list%append_log (var_str ("?alpha_is_fixed"), .true., & intrinsic=.true., & description=var_str ('Flag that tells \whizard\ to use a non-running ' // & 'QED $\alpha$. Note that this has to be set explicitly to $\ttt{false}$ ' // & 'if the user wants to use one of the running $\alpha$ options. ' // & '(cf. also \ttt{alpha\_order}, \ttt{alpha\_nf}, \ttt{alpha\_lep}, ' // & '\ttt{?alphas\_from\_me}')) call var_list%append_log (var_str ("?alphas_from_lhapdf"), .false., & intrinsic=.true., & description=var_str ('Flag that tells \whizard\ to use a running ' // & '$\alpha_s$ from the \lhapdf\ library (which has to be correctly ' // & 'linked). Note that \ttt{?alphas\_is\_fixed} has to be set ' // & 'explicitly to $\ttt{false}$. (cf. also \ttt{alphas\_order}, ' // & '\ttt{?alphas\_is\_fixed}, \ttt{?alphas\_from\_pdf\_builtin}, ' // & '\ttt{alphas\_nf}, \ttt{?alphas\_from\_mz}, \ttt{?alphas\_from\_lambda\_qcd}, ' // & '\ttt{lambda\_qcd})')) call var_list%append_log (var_str ("?alphas_from_pdf_builtin"), .false., & intrinsic=.true., & description=var_str ('Flag that tells \whizard\ to use a running ' // & '$\alpha_s$ from the internal PDFs. Note that in that case \ttt{?alphas\_is\_fixed} ' // & 'has to be set explicitly to $\ttt{false}$. (cf. also ' // & '\ttt{alphas\_order}, \ttt{?alphas\_is\_fixed}, \ttt{?alphas\_from\_lhapdf}, ' // & '\ttt{alphas\_nf}, \ttt{?alphas\_from\_mz}, \newline \ttt{?alphas\_from\_lambda\_qcd}, ' // & '\ttt{lambda\_qcd})')) call var_list%append_log (var_str ("?alpha_evolve_analytic"), .true., & intrinsic=.true., & description=var_str ('Flag that tells \whizard\ to use analytic running ' // & 'formulae for $\alpha$ instead of a numeric Runge-Kutta. ' // & '(cf. also \ttt{alpha\_order}, \ttt{?alpha\_is\_fixed}, ' // & '\ttt{alpha\_nf}, \ttt{alpha\_nlep}, \ttt{?alpha\_from\_me}) ')) call var_list%append_int (var_str ("alphas_order"), 0, & intrinsic=.true., & description=var_str ('Integer parameter that sets the order ' // & 'of the internal evolution for running $\alpha_s$ in \whizard: ' // & 'the default, \ttt{0}, is LO running, \ttt{1} is NLO, \ttt{2} ' // & 'is NNLO. (cf. also \ttt{alphas\_is\_fixed}, \ttt{?alphas\_from\_lhapdf}, ' // & '\ttt{?alphas\_from\_pdf\_builtin}, \ttt{alphas\_nf}, \ttt{?alphas\_from\_mz}, ' // & '\newline \ttt{?alphas\_from\_lambda\_qcd}, \ttt{lambda\_qcd})')) call var_list%append_int (var_str ("alpha_order"), 0, & intrinsic=.true., & description=var_str ('Integer parameter that sets the order ' // & 'of the internal evolution for running $\alpha$ in \whizard: ' // & 'the default, \ttt{0}, is LO running, \ttt{1} is NLO. ' // & '(cf. also \ttt{alpha\_is\_fixed}, \ttt{alpha\_nf}, \ttt{alphas\_lep}, ' // & '\ttt{?alpha\_from\_me})')) call var_list%append_int (var_str ("alphas_nf"), 5, & intrinsic=.true., & description=var_str ('Integer parameter that sets the number ' // & 'of active quark flavors for the internal evolution for running ' // & '$\alpha_s$ in \whizard. (cf. also ' // & '\ttt{alphas\_is\_fixed}, \ttt{?alphas\_from\_lhapdf}, \ttt{?alphas\_from\_pdf\_builtin}, ' // & '\ttt{alphas\_order}, \ttt{?alphas\_from\_mz}, \newline ' // & '\ttt{?alphas\_from\_lambda\_qcd}, \ttt{lambda\_qcd})')) call var_list%append_int (var_str ("alpha_nf"), -1, & intrinsic=.true., & description=var_str ('Integer parameter that sets the number ' // & 'of active quark flavors for the internal evolution for running ' // & '$\alpha$ in \whizard. The default, \ttt{-1}, keeps it equal to \ttt{alphas\_nf} ' // & '\ttt{alpha\_is\_fixed}, \ttt{alphas\_order}, \ttt{?alpha\_from\_me}, ' // & '\ttt{?alpha\_evolve\_analytic}')) call var_list%append_int (var_str ("alpha_nlep"), 1, & intrinsic=.true., & description=var_str ('Integer parameter that sets the number ' // & 'of active leptons in the running of $\alpha$ in \whizard. The deffault is' // & 'one, with only the electron considered massless (cf. also ' // & '\ttt{alpha\_is\_fixed}, \ttt{alpha\_nf}, ' // & '\ttt{alpha\_order}, \ttt{?alpha\_from\_me}, \ttt{?alpha\_evolve\_analytic})')) call var_list%append_log (var_str ("?alphas_from_mz"), .false., & intrinsic=.true., & description=var_str ('Flag that tells \whizard\ to use its internal ' // & 'running $\alpha_s$ from $\alpha_s(M_Z)$. Note that in that ' // & 'case \ttt{?alphas\_is\_fixed} has to be set explicitly to ' // & '$\ttt{false}$. (cf. also \ttt{alphas\_order}, \ttt{?alphas\_is\_fixed}, ' // & '\ttt{?alphas\_from\_lhapdf}, \ttt{alphas\_nf}, \ttt{?alphas\_from\_pdf\_builtin}, ' // & '\newline \ttt{?alphas\_from\_lambda\_qcd}, \ttt{lambda\_qcd})')) call var_list%append_log (var_str ("?alphas_from_lambda_qcd"), .false., & intrinsic=.true., & description=var_str ('Flag that tells \whizard\ to use its internal ' // & 'running $\alpha_s$ from $\alpha_s(\Lambda_{QCD})$. Note that ' // & 'in that case \ttt{?alphas\_is\_fixed} has to be set explicitly ' // & 'to $\ttt{false}$. (cf. also \ttt{alphas\_order}, \ttt{?alphas\_is\_fixed}, ' // & '\ttt{?alphas\_from\_lhapdf}, \ttt{alphas\_nf}, \ttt{?alphas\_from\_pdf\_builtin}, ' // & '\newline \ttt{?alphas\_from\_mz}, \ttt{lambda\_qcd})')) call var_list%append_real (var_str ("lambda_qcd"), 200.e-3_default, & intrinsic=.true., & description=var_str ('Real parameter that sets the value for ' // & '$\Lambda_{QCD}$ used in the internal evolution for running ' // & '$\alpha_s$ in \whizard. (cf. also \ttt{alphas\_is\_fixed}, ' // & '\ttt{?alphas\_from\_lhapdf}, \ttt{alphas\_nf}, ' // & '\newline \ttt{?alphas\_from\_pdf\_builtin}, ' // & '\ttt{?alphas\_from\_mz}, \ttt{?alphas\_from\_lambda\_qcd}, ' // & '\ttt{alphas\_order})')) call var_list%append_log (var_str ("?fatal_beam_decay"), .true., & intrinsic=.true., & description=var_str ('Logical variable that let the user decide ' // & 'whether the possibility of a beam decay is treated as a fatal ' // & 'error or only as a warning. An example is a process $b t \to ' // & 'X$, where the bottom quark as an inital state particle appears ' // & 'as a possible decay product of the second incoming particle, ' // & 'the top quark. This might trigger inconsistencies or instabilities ' // & 'in the phase space set-up.')) call var_list%append_log (var_str ("?helicity_selection_active"), .true., & intrinsic=.true., & description=var_str ('Flag that decides whether \whizard\ uses ' // & 'a numerical selection rule for vanishing helicities: if active, ' // & 'then, if a certain helicity combination yields an absolute ' // & '(\oMega) matrix element smaller than a certain threshold ($\to$ ' // & '\ttt{helicity\_selection\_threshold}) more often than a certain ' // & 'cutoff ($\to$ \ttt{helicity\_selection\_cutoff}), it will be dropped.')) call var_list%append_real (var_str ("helicity_selection_threshold"), & 1E10_default, & intrinsic=.true., & description=var_str ('Real parameter that gives the threshold ' // & 'for the absolute value of a certain helicity combination of ' // & 'an (\oMega) amplitude. If a certain number ($\to$ ' // & '\ttt{helicity\_selection\_cutoff}) of calls stays below this ' // & 'threshold, that combination will be dropped from then on. (cf. ' // & 'also \ttt{?helicity\_selection\_active})')) call var_list%append_int (var_str ("helicity_selection_cutoff"), 1000, & intrinsic=.true., & description=var_str ('Integer parameter that gives the number ' // & "a certain helicity combination of an (\oMega) amplitude has " // & 'to be below a certain threshold ($\to$ \ttt{helicity\_selection\_threshold}) ' // & 'in order to be dropped from then on. (cf. also \ttt{?helicity\_selection\_active})')) call var_list%append_string (var_str ("$rng_method"), var_str ("tao"), & intrinsic=.true., & description=var_str ('String variable that allows to set the ' // & 'method for the random number generation. Default is Donald ' // & "Knuth' RNG method \ttt{TAO}.")) call var_list%append_log (var_str ("?vis_diags"), .false., & intrinsic=.true., & description=var_str ('Logical variable that allows to give out ' // & "a Postscript or PDF file for the Feynman diagrams for a \oMega\ " // & 'process. (cf. \ttt{?vis\_diags\_color}).')) call var_list%append_log (var_str ("?vis_diags_color"), .false., & intrinsic=.true., & description=var_str ('Same as \ttt{?vis\_diags}, but switches ' // & 'on color flow instead of Feynman diagram generation. (cf. \ttt{?vis\_diags}).')) call var_list%append_log (var_str ("?check_event_file"), .true., & intrinsic=.true., & description=var_str ('Setting this to false turns off all sanity ' // & 'checks when reading a raw event file with previously generated ' // & 'events. Use this at your own risk; the program may return ' // & 'wrong results or crash if data do not match. (cf. also \ttt{?check\_grid\_file}, ' // & '\ttt{?check\_phs\_file})')) call var_list%append_string (var_str ("$event_file_version"), var_str (""), & intrinsic=.true., & description=var_str ('String variable that allows to set the ' // & 'format version of the \whizard\ internal binary event format.')) call var_list%append_int (var_str ("n_events"), 0, & intrinsic=.true., & description=var_str ('This specifier \ttt{n\_events = {\em }} ' // & 'sets the number of events for the event generation of the processes ' // & 'in the \sindarin\ input files. Note that WHIZARD itself chooses ' // & 'the number from the \ttt{n\_events} or from the \ttt{luminosity} ' // & 'specifier, whichever would give the larger number of events. ' // & 'As this depends on the cross section under consideration, it ' // & 'might be different for different processes in the process list. ' // & '(cf. \ttt{luminosity}, \ttt{\$sample}, \ttt{sample\_format}, ' // & '\ttt{?unweighted}, \ttt{event\_index\_offset})')) call var_list%append_int (var_str ("event_index_offset"), 0, & intrinsic=.true., & description=var_str ('The value ' // & '\ttt{event\_index\_offset = {\em }} ' // & 'initializes the event counter for a subsequent ' // & 'event sample. By default (value 0), the first event ' // & 'gets index value 1, incrementing by one for each generated event ' // & 'within a sample. The event counter is initialized again ' // & 'for each new sample (i.e., \ttt{integrate} command). ' // & 'If events are read from file, and the ' // & 'event file format supports event numbering, the event numbers ' // & 'will be taken from file instead, and the value of ' // & '\ttt{event\_index\_offset} has no effect. ' // & '(cf. \ttt{luminosity}, \ttt{\$sample}, \ttt{sample\_format}, ' // & '\ttt{?unweighted}, \ttt{n\_events})')) call var_list%append_log (var_str ("?unweighted"), .true., & intrinsic=.true., & description=var_str ('Flag that distinguishes between unweighted ' // & 'and weighted event generation. (cf. also \ttt{simulate}, \ttt{n\_events}, ' // & '\ttt{luminosity}, \ttt{event\_index\_offset})')) call var_list%append_real (var_str ("safety_factor"), 1._default, & intrinsic=.true., & description=var_str ('This real variable \ttt{safety\_factor ' // & '= {\em }} reduces the acceptance probability for unweighting. ' // & 'If greater than one, excess events become less likely, but ' // & 'the reweighting efficiency also drops. (cf. \ttt{simulate}, \ttt{?unweighted})')) call var_list%append_log (var_str ("?negative_weights"), .false., & intrinsic=.true., & description=var_str ('Flag that tells \whizard\ to allow negative ' // & 'weights in integration and simulation. (cf. also \ttt{simulate}, ' // & '\ttt{?unweighted})')) call var_list%append_log (var_str ("?resonance_history"), .false., & intrinsic=.true., & description=var_str ( & 'The logical variable \texttt{?resonance\_history ' // & '= true/false} specifies whether during a simulation pass, ' // & 'the event generator should try to reconstruct intermediate ' // & 'resonances. If activated, appropriate resonant subprocess ' // & 'matrix element code will be automatically generated. ')) call var_list%append_real (var_str ("resonance_on_shell_limit"), & 4._default, & intrinsic=.true., & description=var_str ( & 'The real variable \texttt{resonance\_on\_shell\_limit ' // & '= {\em }} specifies the maximum relative distance from a ' // & 'resonance peak, such that the kinematical configuration ' // & 'can still be considered on-shell. This is relevant only if ' // & '\texttt{?resonance\_history = true}.')) call var_list%append_real (var_str ("resonance_on_shell_turnoff"), & 0._default, & intrinsic=.true., & description=var_str ( & 'The real variable \texttt{resonance\_on\_shell\_turnoff ' // & '= {\em }}, if positive, ' // & 'controls the smooth transition from resonance-like ' // & 'to background-like events. The relative strength of a ' // & 'resonance is reduced by a Gaussian with width given by this ' // & 'variable. In any case, events are treated as background-like ' // & 'when the off-shellness is greater than ' // & '\texttt{resonance\_on\_shell\_limit}. All of this applies ' // & 'only if \texttt{?resonance\_history = true}.')) call var_list%append_real (var_str ("resonance_background_factor"), & 1._default, & intrinsic=.true., & description=var_str ( & 'The real variable \texttt{resonance\_background\_factor} ' // & 'controls resonance insertion if a resonance ' // & 'history applies to a particular event. In determining '// & 'whether event kinematics qualifies as resonant or non-resonant, ' //& 'the non-resonant probability is multiplied by this factor ' // & 'Setting the factor to zero removes the background ' // & 'configuration as long as the kinematics qualifies as on-shell ' // & 'as qualified by \texttt{resonance\_on\_shell\_limit}.')) call var_list%append_log (var_str ("?keep_beams"), .false., & intrinsic=.true., & description=var_str ('The logical variable \ttt{?keep\_beams ' // & '= true/false} specifies whether beam particles and beam remnants ' // & 'are included when writing event files. For example, in order ' // & 'to read Les Houches accord event files into \pythia, no beam ' // & 'particles are allowed.')) call var_list%append_log (var_str ("?keep_remnants"), .true., & intrinsic=.true., & description=var_str ('The logical variable \ttt{?keep\_beams ' // & '= true/false} is respected only if \ttt{?keep\_beams} is set. ' // & 'If \ttt{true}, beam remnants are tagged as outgoing particles ' // & 'if they have been neither showered nor hadronized, i.e., have ' // & 'no children. If \ttt{false}, beam remnants are also included ' // & 'in the event record, but tagged as unphysical. Note that for ' // & 'ISR and/or beamstrahlung spectra, the radiated photons are ' // & 'considered as beam remnants.')) call var_list%append_log (var_str ("?rescan_force"), .false., & intrinsic=.true., & description=var_str ('Flag that allows to bypass essential ' // & 'checks on the particle set when reading event/rescanning files ' // & 'into \whizard. (cf. \ttt{rescan}, \ttt{?update\_event}, \ttt{?update\_sqme}, ' // & '\newline \ttt{?update\_weight})')) call var_list%append_log (var_str ("?recover_beams"), .true., & intrinsic=.true., & description=var_str ('Flag that decides whether the beam particles ' // & 'should be reconstructed when reading event/rescanning files ' // & 'into \whizard. (cf. \ttt{rescan}, \ttt{?update\_event}, \ttt{?update\_sqme}, ' // & '\newline \ttt{?update\_weight})')) call var_list%append_log (var_str ("?update_event"), .false., & intrinsic=.true., & description=var_str ('Flag that decides whether the events in ' // & 'an event file should be rebuilt from the hard process when ' // & 'reading event/rescanning files into \whizard. (cf. \ttt{rescan}, ' // & '\ttt{?recover\_beams}, \ttt{?update\_sqme}, \ttt{?update\_weight})')) call var_list%append_log (var_str ("?update_sqme"), .false., & intrinsic=.true., & description=var_str ('Flag that decides whether the squared ' // & 'matrix element in an event file should be updated/recalculated ' // & 'when reading event/rescanning files into \whizard. (cf. \ttt{rescan}, ' // & '\newline \ttt{?recover\_beams}, \ttt{?update\_event}, \ttt{?update\_weight})')) call var_list%append_log (var_str ("?update_weight"), .false., & intrinsic=.true., & description=var_str ('Flag that decides whether the weights ' // & 'in an event file should be updated/recalculated when reading ' // & 'event/rescanning files into \whizard. (cf. \ttt{rescan}, \ttt{?recover\_beams}, ' // & '\newline \ttt{?update\_event}, \ttt{?update\_sqme})')) call var_list%append_log (var_str ("?use_alphas_from_file"), .false., & intrinsic=.true., & description=var_str ('Flag that decides whether the current ' // & '$\alpha_s$ definition should be used when recalculating matrix ' // & 'elements for events read from file, or the value that is stored ' // & 'in the file for that event. (cf. \ttt{rescan}, \ttt{?update\_sqme}, ' // & '\ttt{?use\_scale\_from\_file})')) call var_list%append_log (var_str ("?use_scale_from_file"), .false., & intrinsic=.true., & description=var_str ('Flag that decides whether the current ' // & 'energy-scale expression should be used when recalculating matrix ' // & 'elements for events read from file, or the value that is stored ' // & 'in the file for that event. (cf. \ttt{rescan}, \ttt{?update\_sqme}, ' // & '\ttt{?use\_alphas\_from\_file})')) call var_list%append_log (var_str ("?allow_decays"), .true., & intrinsic=.true., & description=var_str ('Master flag to switch on cascade decays ' // & 'for final state particles as an event transform. As a default, ' // & 'it is switched on. (cf. also \ttt{?auto\_decays}, ' // & '\ttt{auto\_decays\_multiplicity}, \ttt{?auto\_decays\_radiative}, ' // & '\ttt{?decay\_rest\_frame})')) call var_list%append_log (var_str ("?auto_decays"), .false., & intrinsic=.true., & description=var_str ('Flag, particularly as optional argument of the ($\to$) ' // & '\ttt{unstable} command, that tells \whizard\ to automatically ' // & 'determine the decays of that particle up to the final state ' // & 'multplicity ($\to$) \ttt{auto\_decays\_multiplicity}. Depending ' // & 'on the flag ($\to$) \ttt{?auto\_decays\_radiative}, radiative ' // & 'decays will be taken into account or not. (cf. also \ttt{unstable}, ' // & '\ttt{?isotropic\_decay}, \ttt{?diagonal\_decay})')) call var_list%append_int (var_str ("auto_decays_multiplicity"), 2, & intrinsic=.true., & description=var_str ('Integer parameter, that sets -- ' // & 'for the ($\to$) \ttt{?auto\_decays} option to let \whizard\ ' // & 'automatically determine the decays of a particle set as ($\to$) ' // & '\ttt{unstable} -- the maximal final state multiplicity that ' // & 'is taken into account. The default is \ttt{2}. The flag \ttt{?auto\_decays\_radiative} ' // & 'decides whether radiative decays are taken into account. (cf.\ ' // & 'also \ttt{unstable}, \ttt{?auto\_decays})')) call var_list%append_log (var_str ("?auto_decays_radiative"), .false., & intrinsic=.true., & description=var_str ("If \whizard's automatic detection " // & 'of decay channels are switched on ($\to$ \ttt{?auto\_decays} ' // & 'for the ($\to$) \ttt{unstable} command, this flags decides ' // & 'whether radiative decays (e.g. containing additional photon(s)/gluon(s)) ' // & 'are taken into account or not. (cf. also \ttt{unstable}, \ttt{auto\_decays\_multiplicity})')) call var_list%append_log (var_str ("?decay_rest_frame"), .false., & intrinsic=.true., & description=var_str ('Flag that allows to force a particle decay ' // & 'to be simulated in its rest frame. This simplifies the calculation ' // & 'for decays as stand-alone processes, but makes the process ' // & 'unsuitable for use in a decay chain.')) call var_list%append_log (var_str ("?isotropic_decay"), .false., & intrinsic=.true., & description=var_str ('Flag that -- in case of using factorized ' // & 'production and decays using the ($\to$) \ttt{unstable} command ' // & '-- tells \whizard\ to switch off spin correlations completely ' // & '(isotropic decay). (cf. also \ttt{unstable}, \ttt{?auto\_decays}, ' // & '\ttt{decay\_helicity}, \ttt{?diagonal\_decay})')) call var_list%append_log (var_str ("?diagonal_decay"), .false., & intrinsic=.true., & description=var_str ('Flag that -- in case of using factorized ' // & 'production and decays using the ($\to$) \ttt{unstable} command ' // & '-- tells \whizard\ instead of full spin correlations to take ' // & 'only the diagonal entries in the spin-density matrix (i.e. ' // & 'classical spin correlations). (cf. also \ttt{unstable}, \ttt{?auto\_decays}, ' // & '\ttt{decay\_helicity}, \ttt{?isotropic\_decay})')) call var_list%append_int (var_str ("decay_helicity"), & intrinsic=.true., & description=var_str ('If this parameter is given an integer ' // & 'value, any particle decay triggered by a subsequent \ttt{unstable} ' // & 'declaration will receive a projection on the given helicity ' // & 'state for the unstable particle. (cf. also \ttt{unstable}, ' // & '\ttt{?isotropic\_decay}, \ttt{?diagonal\_decay}. The latter ' // & 'parameters, if true, take precdence over any \ttt{?decay\_helicity} setting.)')) call var_list%append_log (var_str ("?polarized_events"), .false., & intrinsic=.true., & description=var_str ('Flag that allows to select certain helicity ' // & 'combinations in final state particles in the event files, ' // & 'and perform analysis on polarized event samples. (cf. also ' // & '\ttt{simulate}, \ttt{polarized}, \ttt{unpolarized})')) call var_list%append_string (var_str ("$polarization_mode"), & var_str ("helicity"), & intrinsic=.true., & description=var_str ('String variable that specifies the mode in ' // & 'which the polarization of particles is handled when polarized events ' // & 'are written out. Possible options are \ttt{"ignore"}, \ttt{"helicity"}, ' // & '\ttt{"factorized"}, and \ttt{"correlated"}. For more details cf. the ' // & 'detailed section.')) call var_list%append_log (var_str ("?colorize_subevt"), .false., & intrinsic=.true., & description=var_str ('Flag that enables color-index tracking ' // & 'in the subevent (\ttt{subevt}) objects that are used for ' // & 'internal event analysis.')) call var_list%append_real (var_str ("tolerance"), 0._default, & intrinsic=.true., & description=var_str ('Real variable that defines the absolute ' // & 'tolerance with which the (logical) function \ttt{expect} accepts ' // & 'equality or inequality: \ttt{tolerance = {\em }}. This ' // & 'can e.g. be used for cross-section tests and backwards compatibility ' // & 'checks. (cf. also \ttt{expect})')) call var_list%append_int (var_str ("checkpoint"), 0, & intrinsic = .true., & description=var_str ('Setting this integer variable to a positive ' // & 'integer $n$ instructs simulate to print out a progress summary ' // & 'every $n$ events.')) call var_list%append_int (var_str ("event_callback_interval"), 0, & intrinsic = .true., & description=var_str ('Setting this integer variable to a positive ' // & 'integer $n$ instructs simulate to print out a progress summary ' // & 'every $n$ events.')) call var_list%append_log (var_str ("?pacify"), .false., & intrinsic=.true., & description=var_str ('Flag that allows to suppress numerical ' // & 'noise and give screen and log file output with a lower number ' // & 'of significant digits. Mainly for debugging purposes. (cf. also ' // & '\ttt{?sample\_pacify})')) call var_list%append_string (var_str ("$out_file"), var_str (""), & intrinsic=.true., & description=var_str ('This character variable allows to specify ' // & 'the name of the data file to which the histogram and plot data ' // & 'are written (cf. also \ttt{write\_analysis}, \ttt{open\_out}, ' // & '\ttt{close\_out})')) call var_list%append_log (var_str ("?out_advance"), .true., & intrinsic=.true., & description=var_str ('Flag that sets advancing in the \ttt{printf} ' // & 'output commands, i.e. continuous printing with no line feed ' // & 'etc. (cf. also \ttt{printf})')) call var_list%append_int (var_str ("real_range"), & range (real_specimen), intrinsic = .true., locked = .true., & description=var_str ('This integer gives the decimal exponent ' // & 'range of the numeric model for the real float type in use. It cannot ' // & 'be set by the user. (cf. also \ttt{real\_precision}, ' // & '\ttt{real\_epsilon}, \ttt{real\_tiny}).')) call var_list%append_int (var_str ("real_precision"), & precision (real_specimen), intrinsic = .true., locked = .true., & description=var_str ('This integer gives the precision of ' // & 'the numeric model for the real float type in use. It cannot ' // & 'be set by the user. (cf. also \ttt{real\_range}, ' // & '\ttt{real\_epsilon}, \ttt{real\_tiny}).')) call var_list%append_real (var_str ("real_epsilon"), & epsilon (real_specimen), intrinsic = .true., locked = .true., & description=var_str ('This gives the smallest number $E$ ' // & 'of the same kind as the float type for which $1 + E > 1$. ' // & 'It cannot be set by the user. (cf. also \ttt{real\_range}, ' // & '\ttt{real\_tiny}, \ttt{real\_precision}).')) call var_list%append_real (var_str ("real_tiny"), & tiny (real_specimen), intrinsic = .true., locked = .true., & description=var_str ('This gives the smallest positive (non-zero) ' // & 'number in the numeric model for the real float type in use. ' // & 'It cannot be set by the user. (cf. also \ttt{real\_range}, ' // & '\ttt{real\_epsilon}, \ttt{real\_precision}).')) end subroutine var_list_set_core_defaults @ %def var_list_set_core_defaults @ <>= procedure :: set_integration_defaults => var_list_set_integration_defaults +<>= + module subroutine var_list_set_integration_defaults (var_list) + class(var_list_t), intent(inout) :: var_list + end subroutine var_list_set_integration_defaults <>= - subroutine var_list_set_integration_defaults (var_list) + module subroutine var_list_set_integration_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_string (var_str ("$integration_method"), var_str ("vamp"), & intrinsic=.true., & description=var_str ('This string variable specifies the method ' // & 'for performing the multi-dimensional phase-space integration. ' // & 'The default is the \vamp\ algorithm (\ttt{"vamp"}), other options ' // & 'are via the numerical midpoint rule (\ttt{"midpoint"}) or an ' // & 'alternate \vamptwo\ implementation that is MPI-parallelizable ' // & '(\ttt{"vamp2"}).')) call var_list%append_int (var_str ("threshold_calls"), 10, & intrinsic=.true., & description=var_str ('This integer variable gives a limit for ' // & 'the number of calls in a given channel which acts as a lower ' // & 'threshold for the channel weight. If the number of calls in ' // & 'that channel falls below this threshold, the weight is not ' // & 'lowered further but kept at this threshold. (cf. also ' // & '\ttt{channel\_weights\_power})')) call var_list%append_int (var_str ("min_calls_per_channel"), 10, & intrinsic=.true., & description=var_str ('Integer parameter that modifies the settings ' // & "of the \vamp\ integrator's grid parameters. It sets the minimal " // & 'number every channel must be called. If the number of calls ' // & 'from the iterations is too small, \whizard\ will automatically ' // & 'increase the number of calls. (cf. \ttt{iterations}, \ttt{min\_calls\_per\_bin}, ' // & '\ttt{min\_bins}, \ttt{max\_bins})')) call var_list%append_int (var_str ("min_calls_per_bin"), 10, & intrinsic=.true., & description=var_str ('Integer parameter that modifies the settings ' // & "of the \vamp\ integrator's grid parameters. It sets the minimal " // & 'number every bin in an integration dimension must be called. ' // & 'If the number of calls from the iterations is too small, \whizard\ ' // & 'will automatically increase the number of calls. (cf. \ttt{iterations}, ' // & '\ttt{min\_calls\_per\_channel}, \ttt{min\_bins}, \ttt{max\_bins})')) call var_list%append_int (var_str ("min_bins"), 3, & intrinsic=.true., & description=var_str ('Integer parameter that modifies the settings ' // & "of the \vamp\ integrator's grid parameters. It sets the minimal " // & 'number of bins per integration dimension. (cf. \ttt{iterations}, ' // & '\ttt{max\_bins}, \ttt{min\_calls\_per\_channel}, \ttt{min\_calls\_per\_bin})')) call var_list%append_int (var_str ("max_bins"), 20, & intrinsic=.true., & description=var_str ('Integer parameter that modifies the settings ' // & "of the \vamp\ integrator's grid parameters. It sets the maximal " // & 'number of bins per integration dimension. (cf. \ttt{iterations}, ' // & '\ttt{min\_bins}, \ttt{min\_calls\_per\_channel}, \ttt{min\_calls\_per\_bin})')) call var_list%append_log (var_str ("?stratified"), .true., & intrinsic=.true., & description=var_str ('Flag that switches between stratified ' // & 'and importance sampling for the \vamp\ integration method.')) call var_list%append_log (var_str ("?use_vamp_equivalences"), .true., & intrinsic=.true., & description=var_str ('Flag that decides whether equivalence ' // & 'relations (symmetries) between different integration channels ' // & 'are used by the \vamp\ integrator.')) call var_list%append_log (var_str ("?vamp_verbose"), .false., & intrinsic=.true., & description=var_str ('Flag that sets the chattiness of the \vamp\ ' // & 'integrator. If set, not only errors, but also all warnings and ' // & 'messages will be written out (not the default). (cf. also \newline ' // & '\ttt{?vamp\_history\_global}, \ttt{?vamp\_history\_global\_verbose}, ' // & '\ttt{?vamp\_history\_channels}, \newline \ttt{?vamp\_history\_channels\_verbose})')) call var_list%append_log (var_str ("?vamp_history_global"), & .true., intrinsic=.true., & description=var_str ('Flag that decides whether the global history ' // & 'of the grid adaptation of the \vamp\ integrator are written ' // & 'into the process logfiles. (cf. also \ttt{?vamp\_history\_global\_verbose}, ' // & '\ttt{?vamp\_history\_channels}, \ttt{?vamp\_history\_channels\_verbose}, ' // & '\ttt{?vamp\_verbose})')) call var_list%append_log (var_str ("?vamp_history_global_verbose"), & .false., intrinsic=.true., & description=var_str ('Flag that decides whether the global history ' // & 'of the grid adaptation of the \vamp\ integrator are written ' // & 'into the process logfiles in an extended version. Only for debugging ' // & 'purposes. (cf. also \ttt{?vamp\_history\_global}, \ttt{?vamp\_history\_channels}, ' // & '\ttt{?vamp\_verbose}, \ttt{?vamp\_history\_channels\_verbose})')) call var_list%append_log (var_str ("?vamp_history_channels"), & .false., intrinsic=.true., & description=var_str ('Flag that decides whether the history of ' // & 'the grid adaptation of the \vamp\ integrator for every single ' // & 'channel are written into the process logfiles. Only for debugging ' // & 'purposes. (cf. also \ttt{?vamp\_history\_global\_verbose}, ' // & '\ttt{?vamp\_history\_global}, \ttt{?vamp\_verbose}, \newline ' // & '\ttt{?vamp\_history\_channels\_verbose})')) call var_list%append_log (var_str ("?vamp_history_channels_verbose"), & .false., intrinsic=.true., & description=var_str ('Flag that decides whether the history of ' // & 'the grid adaptation of the \vamp\ integrator for every single ' // & 'channel are written into the process logfiles in an extended ' // & 'version. Only for debugging purposes. (cf. also \ttt{?vamp\_history\_global}, ' // & '\ttt{?vamp\_history\_channels}, \ttt{?vamp\_verbose}, \ttt{?vamp\_history\_global\_verbose})')) call var_list%append_string (var_str ("$run_id"), var_str (""), & intrinsic=.true., & description=var_str ('String variable \ttt{\$run\_id = "{\em ' // & '}"} that allows to set a special ID for a particular process ' // & 'run, e.g. in a scan. The run ID is then attached to the process ' // & 'log file: \newline \ttt{{\em }\_{\em }.{\em ' // & '}.log}, the \vamp\ grid file: \newline \ttt{{\em }\_{\em ' // & '}.{\em }.vg}, and the phase space file: \newline ' // & '\ttt{{\em }\_{\em }.{\em }.phs}. ' // & 'The run ID string distinguishes among several runs for the ' // & 'same process. It identifies process instances with respect ' // & 'to adapted integration grids and similar run-specific data. ' // & 'The run ID is kept when copying processes for creating instances, ' // & 'however, so it does not distinguish event samples. (cf.\ also ' // & '\ttt{\$job\_id}, \ttt{\$compile\_workspace}')) call var_list%append_int (var_str ("n_calls_test"), 0, & intrinsic=.true., & description=var_str ('Integer variable that allows to set a ' // & 'certain number of matrix element sampling test calls without ' // & 'actually integrating the process under consideration. (cf. ' // & '\ttt{integrate})')) call var_list%append_log (var_str ("?integration_timer"), .true., & intrinsic=.true., & description=var_str ('This flag switches the integration timer ' // & 'on and off, that gives the estimate for the duration of the ' // & 'generation of 10,000 unweighted events for each integrated ' // & 'process.')) call var_list%append_log (var_str ("?check_grid_file"), .true., & intrinsic=.true., & description=var_str ('Setting this to false turns off all sanity ' // & 'checks when reading a grid file with previous integration data. ' // & 'Use this at your own risk; the program may return wrong results ' // & 'or crash if data do not match. (cf. also \ttt{?check\_event\_file}, \ttt{?check\_phs\_file}) ')) call var_list%append_real (var_str ("accuracy_goal"), 0._default, & intrinsic=.true., & description=var_str ('Real parameter that allows the user to ' // & 'set a minimal accuracy that should be achieved in the Monte-Carlo ' // & 'integration of a certain process. If that goal is reached, ' // & 'grid and weight adapation stop, and this result is used for ' // & 'simulation. (cf. also \ttt{integrate}, \ttt{iterations}, ' // & '\ttt{error\_goal}, \ttt{relative\_error\_goal}, ' // & '\ttt{error\_threshold})')) call var_list%append_real (var_str ("error_goal"), 0._default, & intrinsic=.true., & description=var_str ('Real parameter that allows the user to ' // & 'set a minimal absolute error that should be achieved in the ' // & 'Monte-Carlo integration of a certain process. If that goal ' // & 'is reached, grid and weight adapation stop, and this result ' // & 'is used for simulation. (cf. also \ttt{integrate}, \ttt{iterations}, ' // & '\ttt{accuracy\_goal}, \ttt{relative\_error\_goal}, \ttt{error\_threshold})')) call var_list%append_real (var_str ("relative_error_goal"), 0._default, & intrinsic=.true., & description=var_str ('Real parameter that allows the user to ' // & 'set a minimal relative error that should be achieved in the ' // & 'Monte-Carlo integration of a certain process. If that goal ' // & 'is reached, grid and weight adaptation stop, and this result ' // & 'is used for simulation. (cf. also \ttt{integrate}, \ttt{iterations}, ' // & '\ttt{accuracy\_goal}, \ttt{error\_goal}, \ttt{error\_threshold})')) call var_list%append_int (var_str ("integration_results_verbosity"), 1, & intrinsic=.true., & description=var_str ('Integer parameter for the verbosity of ' // & 'the integration results in the process-specific logfile.')) call var_list%append_real (var_str ("error_threshold"), & 0._default, intrinsic=.true., & description=var_str ('The real parameter \ttt{error\_threshold ' // & '= {\em }} declares that any error value (in absolute numbers) ' // & 'smaller than \ttt{{\em }} is to be considered zero. The ' // & 'units are \ttt{fb} for scatterings and \ttt{GeV} for decays. ' // & '(cf. also \ttt{integrate}, \ttt{iterations}, \ttt{accuracy\_goal}, ' // & '\ttt{error\_goal}, \ttt{relative\_error\_goal})')) call var_list%append_real (var_str ("channel_weights_power"), 0.25_default, & intrinsic=.true., & description=var_str ('Real parameter that allows to vary the ' // & 'exponent of the channel weights for the \vamp\ integrator.')) call var_list%append_string (var_str ("$integrate_workspace"), & intrinsic=.true., & description=var_str ('Character string that tells \whizard\ ' // & 'the subdirectory where to find the run-specific phase-space ' // & 'configuration and the \vamp\ and \vamptwo\ grid files. ' // & 'If undefined (as per default), \whizard\ creates them and ' // & 'searches for them in the ' // & 'current directory. (cf. also \ttt{\$job\_id}, ' // & '\ttt{\$run\_id}, \ttt{\$compile\_workspace})')) call var_list%append_int (var_str ("vamp_grid_checkpoint"), 1, & intrinsic=.true., & description=var_str ('Integer parameter for setting checkpoints to save ' // & 'the current state of the grids and the results so far of the integration. ' // & 'Allowed are all positive integer. Zero values corresponds to a checkpoint ' // & 'after each integration pass, a one value to a checkpoint after each iteration ' // & '(default) and an \(N\) value correspond to a checkpoint after \(N\) iterations ' // & ' or after each pass, respectively.')) call var_list%append_string (var_str ("$vamp_grid_format"), var_str ("ascii"), & intrinsic=.true., & description=var_str ('Character string that tells \whizard\ ' // & 'the file format for \ttt{vamp2} to use for writing and reading ' // & 'the configuration for the multi-channel integration setup and the ' // & '\vamptwo\ (only) grid data. The values can be \ttt{ascii} for a single ' // & 'human-readable grid file with ending \ttt{.vg2} or \ttt{binary} for two files, ' // & 'a human-readable header file with ending \ttt{.vg2} and binary file with ending ' // & '\ttt{.vgx2} storing the grid data.' // & 'The main purpose of the binary format is to perform faster I/O, e.g. for HPC runs.' // & '\whizard\ can convert between the different file formats automatically.')) call var_list%append_string (var_str ("$vamp_parallel_method"), var_str ("simple"), & intrinsic=.true., & description=var_str ('Character string that tells \whizard\ ' // & 'the parallel method to use for parallel integration within \ttt{vamp2}.' // & ' (i) \ttt{simple} (default) is a local work sharing approach without the need of communication ' // & 'between all workers except for the communication during result collection.' // & ' (ii) \ttt{load} is a global queue approach where the master worker acts as a' // & 'governor listening and providing work for each worker. The queue is filled and assigned with workers ' // & 'a-priori with respect to the assumed computational impact of each channel.' // & 'Both approaches use the same mechanism for result collection using non-blocking ' // & 'communication allowing for a efficient usage of the computing resources.')) end subroutine var_list_set_integration_defaults @ %def var_list_set_integration_defaults @ <>= procedure :: set_phase_space_defaults => var_list_set_phase_space_defaults +<>= + module subroutine var_list_set_phase_space_defaults (var_list) + class(var_list_t), intent(inout) :: var_list + end subroutine var_list_set_phase_space_defaults <>= - subroutine var_list_set_phase_space_defaults (var_list) + module subroutine var_list_set_phase_space_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_string (var_str ("$phs_method"), var_str ("default"), & intrinsic=.true., & description=var_str ('String variable that allows to choose ' // & 'the phase-space parameterization method. The default is the ' // & '\ttt{"wood"} method that takes into account electroweak/BSM ' // & 'resonances. Note that this might not be the best choice for ' // & '(pure) QCD amplitudes. (cf. also \ttt{\$phs\_file})')) call var_list%append_log (var_str ("?vis_channels"), .false., & intrinsic=.true., & description=var_str ('Optional logical argument for the \ttt{integrate} ' // & 'command that demands \whizard\ to generate a PDF or postscript ' // & 'output showing the classification of the found phase space ' // & 'channels (if the phase space method \ttt{wood} has been used) ' // & 'according to their properties: \ttt{integrate (foo) \{ iterations=3:10000 ' // & '?vis\_channels = true \}}. The default is \ttt{false}. (cf. ' // & 'also \ttt{integrate}, \ttt{?vis\_history})')) call var_list%append_log (var_str ("?check_phs_file"), .true., & intrinsic=.true., & description=var_str ('Setting this to false turns off all sanity ' // & 'checks when reading a previously generated phase-space configuration ' // & 'file. Use this at your own risk; the program may return wrong ' // & 'results or crash if data do not match. (cf. also \ttt{?check\_event\_file}, ' // & '\ttt{?check\_grid\_file})')) call var_list%append_string (var_str ("$phs_file"), var_str (""), & intrinsic=.true., & description=var_str ('This string variable allows the user to ' // & 'set an individual file name for the phase space parameterization ' // & 'for a particular process: \ttt{\$phs\_file = "{\em }"}. ' // & 'If not set, the default is \ttt{{\em }\_{\em }.{\em ' // & '}.phs}. (cf. also \ttt{\$phs\_method})')) call var_list%append_log (var_str ("?phs_only"), .false., & intrinsic=.true., & description=var_str ('Flag (particularly as optional argument ' // & 'of the $\to$ \ttt{integrate} command) that allows to only generate ' // & 'the phase space file, but not perform the integration. (cf. ' // & 'also \ttt{\$phs\_method}, \ttt{\$phs\_file})')) call var_list%append_real (var_str ("phs_threshold_s"), 50._default, & intrinsic=.true., & description=var_str ('For the phase space method \ttt{wood}, ' // & 'this real parameter sets the threshold below which particles ' // & 'are assumed to be massless in the $s$-channel like kinematic ' // & 'regions. (cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_off\_shell}, ' // & '\ttt{phs\_t\_channel}, \ttt{phs\_e\_scale}, \ttt{phs\_m\_scale}, ' // & '\newline \ttt{phs\_q\_scale}, \ttt{?phs\_keep\_resonant}, \ttt{?phs\_step\_mapping}, ' // & '\ttt{?phs\_step\_mapping\_exp}, \newline \ttt{?phs\_s\_mapping})')) call var_list%append_real (var_str ("phs_threshold_t"), 100._default, & intrinsic=.true., & description=var_str ('For the phase space method \ttt{wood}, ' // & 'this real parameter sets the threshold below which particles ' // & 'are assumed to be massless in the $t$-channel like kinematic ' // & 'regions. (cf. also \ttt{phs\_threshold\_s}, \ttt{phs\_off\_shell}, ' // & '\ttt{phs\_t\_channel}, \ttt{phs\_e\_scale}, \ttt{phs\_m\_scale}, ' // & '\newline \ttt{phs\_q\_scale}, \ttt{?phs\_keep\_resonant}, \ttt{?phs\_step\_mapping}, ' // & '\ttt{?phs\_step\_mapping\_exp}, \newline \ttt{?phs\_s\_mapping})')) call var_list%append_int (var_str ("phs_off_shell"), 2, & intrinsic=.true., & description=var_str ('Integer parameter that sets the number ' // & 'of off-shell (not $t$-channel-like, non-resonant) lines that ' // & 'are taken into account to find a valid phase-space setup in ' // & 'the \ttt{wood} phase-space method. (cf. also \ttt{phs\_threshold\_t}, ' // & '\ttt{phs\_threshold\_s}, \ttt{phs\_t\_channel}, \ttt{phs\_e\_scale}, ' // & '\ttt{phs\_m\_scale}, \ttt{phs\_q\_scale}, \ttt{?phs\_keep\_resonant}, ' // & '\ttt{?phs\_step\_mapping}, \newline \ttt{?phs\_step\_mapping\_exp}, ' // & '\ttt{?phs\_s\_mapping})')) call var_list%append_int (var_str ("phs_t_channel"), 6, & intrinsic=.true., & description=var_str ('Integer parameter that sets the number ' // & 'of $t$-channel propagators in multi-peripheral diagrams that ' // & 'are taken into account to find a valid phase-space setup in ' // & 'the \ttt{wood} phase-space method. (cf. also \ttt{phs\_threshold\_t}, ' // & '\ttt{phs\_threshold\_s}, \ttt{phs\_off\_shell}, \ttt{phs\_e\_scale}, ' // & '\ttt{phs\_m\_scale}, \ttt{phs\_q\_scale}, \ttt{?phs\_keep\_resonant}, ' // & '\ttt{?phs\_step\_mapping}, \newline \ttt{?phs\_step\_mapping\_exp}, ' // & '\ttt{?phs\_s\_mapping})')) call var_list%append_real (var_str ("phs_e_scale"), 10._default, & intrinsic=.true., & description=var_str ('Real parameter that sets the energy scale ' // & 'that acts as a cutoff for parameterizing radiation-like kinematics ' // & 'in the \ttt{wood} phase space method. \whizard\ takes the maximum ' // & 'of this value and the width of the propagating particle as ' // & 'a cutoff. (cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, ' // & '\ttt{phs\_t\_channel}, \ttt{phs\_off\_shell}, \ttt{phs\_m\_scale}, ' // & '\ttt{phs\_q\_scale}, \newline \ttt{?phs\_keep\_resonant}, \ttt{?phs\_step\_mapping}, ' // & '\ttt{?phs\_step\_mapping\_exp}, \ttt{?phs\_s\_mapping})')) call var_list%append_real (var_str ("phs_m_scale"), 10._default, & intrinsic=.true., & description=var_str ('Real parameter that sets the mass scale ' // & 'that acts as a cutoff for parameterizing collinear and infrared ' // & 'kinematics in the \ttt{wood} phase space method. \whizard\ ' // & 'takes the maximum of this value and the mass of the propagating ' // & 'particle as a cutoff. (cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, ' // & '\ttt{phs\_t\_channel}, \ttt{phs\_off\_shell}, \ttt{phs\_e\_scale}, ' // & '\ttt{phs\_q\_scale}, \newline \ttt{?phs\_keep\_resonant}, \ttt{?phs\_step\_mapping}, ' // & '\ttt{?phs\_step\_mapping\_exp}, \ttt{?phs\_s\_mapping})')) call var_list%append_real (var_str ("phs_q_scale"), 10._default, & intrinsic=.true., & description=var_str ('Real parameter that sets the momentum ' // & 'transfer scale that acts as a cutoff for parameterizing $t$- ' // & 'and $u$-channel like kinematics in the \ttt{wood} phase space ' // & 'method. \whizard\ takes the maximum of this value and the mass ' // & 'of the propagating particle as a cutoff. (cf. also \ttt{phs\_threshold\_t}, ' // & '\ttt{phs\_threshold\_s}, \ttt{phs\_t\_channel}, \ttt{phs\_off\_shell}, ' // & '\ttt{phs\_e\_scale}, \ttt{phs\_m\_scale}, \ttt{?phs\_keep\_resonant}, ' // & '\ttt{?phs\_step\_mapping}, \ttt{?phs\_step\_mapping\_exp}, ' // & '\newline \ttt{?phs\_s\_mapping})')) call var_list%append_log (var_str ("?phs_keep_nonresonant"), .true., & intrinsic=.true., & description=var_str ('Flag that decides whether the \ttt{wood} ' // & 'phase space method takes into account also non-resonant contributions. ' // & '(cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, ' // & '\ttt{phs\_t\_channel}, \ttt{phs\_off\_shell}, \ttt{phs\_m\_scale}, ' // & '\ttt{phs\_q\_scale}, \ttt{phs\_e\_scale}, \ttt{?phs\_step\_mapping}, ' // & '\newline \ttt{?phs\_step\_mapping\_exp}, \ttt{?phs\_s\_mapping})')) call var_list%append_log (var_str ("?phs_step_mapping"), .true., & intrinsic=.true., & description=var_str ('Flag that switches on (or off) a particular ' // & 'phase space mapping for resonances, where the mass and width ' // & 'of the resonance are explicitly set as channel cutoffs. (cf. ' // & 'also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, \ttt{phs\_t\_channel}, ' // & '\ttt{phs\_off\_shell}, \ttt{phs\_e\_scale}, \newline \ttt{phs\_m\_scale}, ' // & '\ttt{?phs\_keep\_resonant}, \ttt{?phs\_q\_scale}, \ttt{?phs\_step\_mapping\_exp}, ' // & '\newline \ttt{?phs\_s\_mapping})')) call var_list%append_log (var_str ("?phs_step_mapping_exp"), .true., & intrinsic=.true., & description=var_str ('Flag that switches on (or off) a particular ' // & 'phase space mapping for resonances, where the mass and width ' // & 'of the resonance are explicitly set as channel cutoffs. This ' // & 'is an exponential mapping in contrast to ($\to$) \ttt{?phs\_step\_mapping}. ' // & '(cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, ' // & '\ttt{phs\_t\_channel}, \ttt{phs\_off\_shell}, \ttt{phs\_e\_scale}, ' // & '\ttt{phs\_m\_scale}, \newline \ttt{?phs\_q\_scale}, \ttt{?phs\_keep\_resonant}, ' // & '\ttt{?phs\_step\_mapping}, \ttt{?phs\_s\_mapping})')) call var_list%append_log (var_str ("?phs_s_mapping"), .true., & intrinsic=.true., & description=var_str ('Flag that allows special mapping for $s$-channel ' // & 'resonances. (cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, ' // & '\ttt{phs\_t\_channel}, \ttt{phs\_off\_shell}, \ttt{phs\_e\_scale}, ' // & '\ttt{phs\_m\_scale}, \newline \ttt{?phs\_keep\_resonant}, \ttt{?phs\_q\_scale}, ' // & '\ttt{?phs\_step\_mapping}, \ttt{?phs\_step\_mapping\_exp})')) call var_list%append_log (var_str ("?vis_history"), .false., & intrinsic=.true., & description=var_str ('Optional logical argument for the \ttt{integrate} ' // & 'command that demands \whizard\ to generate a PDF or postscript ' // & 'output showing the adaptation history of the Monte-Carlo integration ' // & 'of the process under consideration. (cf. also \ttt{integrate}, ' // & '\ttt{?vis\_channels})')) end subroutine var_list_set_phase_space_defaults @ %def var_list_set_phase_space_defaults @ <>= procedure :: set_gamelan_defaults => var_list_set_gamelan_defaults +<>= + module subroutine var_list_set_gamelan_defaults (var_list) + class(var_list_t), intent(inout) :: var_list + end subroutine var_list_set_gamelan_defaults <>= - subroutine var_list_set_gamelan_defaults (var_list) + module subroutine var_list_set_gamelan_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_int (& var_str ("n_bins"), 20, & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: integer value that sets the number of bins in histograms. ' // & '(cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, \ttt{\$obs\_unit}, ' // & '\ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, \ttt{\$y\_label}, ' // & '\ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, \ttt{?y\_log}, ' // & '\ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, ' // & '\ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, ' // & '\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{?draw\_symbols}, ' // & '\newline \ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options}, ' // & '\ttt{\$symbol})')) call var_list%append_log (& var_str ("?normalize_bins"), .false., & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: flag that determines whether the weights shall be normalized ' // & 'to the bin width or not. (cf. also \ttt{n\_bins}, \ttt{\$obs\_label}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // & '\ttt{y\_max}, \ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, ' // & '\newline \ttt{?draw\_base}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{\$symbol}, \newline ' // & '\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \ttt{\$draw\_options}, ' // & '\ttt{\$err\_options})')) call var_list%append_string (var_str ("$obs_label"), var_str (""), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: this is a string variable \ttt{\$obs\_label = "{\em ' // & '}"} that allows to attach a label to a plotted ' // & 'or histogrammed observable. (cf. also \ttt{n\_bins}, \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{graph\_width\_mm}, ' // & '\ttt{graph\_height\_mm}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // & '\ttt{y\_max}, \ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, ' // & '\ttt{?draw\_histogram}, \ttt{?draw\_piecewise}, \newline \ttt{?fill\_curve}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // & '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})')) call var_list%append_string (var_str ("$obs_unit"), var_str (""), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: this is a string variable \ttt{\$obs\_unit = "{\em ' // & '}"} that allows to attach a \LaTeX\ physical unit ' // & 'to a plotted or histogrammed observable. (cf. also \ttt{n\_bins}, ' // & '\ttt{?normalize\_bins}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{?y\_log}, \ttt{?x\_log}, ' // & '\ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, \ttt{x\_min}, ' // & '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \ttt{?draw\_histogram}, ' // & '\ttt{?fill\_curve}, \ttt{?draw\_piecewise}, \ttt{?draw\_curve}, ' // & '\ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // & '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})')) call var_list%append_string (var_str ("$title"), var_str (""), & intrinsic=.true., & description=var_str ('This string variable sets the title of ' // & 'a plot in a \whizard\ analysis setup, e.g. a histogram or an ' // & 'observable. The syntax is \ttt{\$title = "{\em }"}. ' // & 'This title appears as a section header in the analysis file, ' // & 'but not in the screen output of the analysis. (cf. also \ttt{n\_bins}, ' // & '\ttt{?normalize\_bins}, \ttt{\$obs\_unit}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{?y\_log}, \ttt{?x\_log}, ' // & '\ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, \ttt{x\_min}, ' // & '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \ttt{?draw\_histogram}, ' // & '\ttt{?fill\_curve}, \ttt{?draw\_piecewise}, \newline \ttt{?draw\_curve}, ' // & '\ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // & '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})')) call var_list%append_string (var_str ("$description"), var_str (""), & intrinsic=.true., & description=var_str ('String variable that allows to specify ' // & 'a description text for the analysis, \ttt{\$description = "{\em ' // & '}"}. This line appears below the title ' // & 'of a corresponding analysis, on top of the respective plot. ' // & '(cf. also \ttt{analysis}, \ttt{n\_bins}, \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_unit}, \ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{?y\_log}, ' // & '\ttt{?x\_log}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \ttt{?draw\_histogram}, ' // & '\ttt{?fill\_curve}, \ttt{?draw\_piecewise}, \ttt{?draw\_curve}, ' // & '\ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // & '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})')) call var_list%append_string (var_str ("$x_label"), var_str (""), & intrinsic=.true., & description=var_str ('String variable, \ttt{\$x\_label = "{\em ' // & '}"}, that sets the $x$ axis label in a plot or ' // & 'histogram in a \whizard\ analysis. (cf. also \ttt{analysis}, ' // & '\ttt{n\_bins}, \ttt{?normalize\_bins}, \ttt{\$obs\_unit}, \ttt{\$y\_label}, ' // & '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \newline ' // & '\ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, ' // & '\ttt{?draw\_histogram}, \ttt{?fill\_curve}, \newline \ttt{?draw\_piecewise}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // & '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})')) call var_list%append_string (var_str ("$y_label"), var_str (""), & intrinsic=.true., & description=var_str ('String variable, \ttt{\$y\_label = "{\em ' // & '}"}, that sets the $y$ axis label in a plot or ' // & 'histogram in a \whizard\ analysis. (cf. also \ttt{analysis}, ' // & '\ttt{n\_bins}, \ttt{?normalize\_bins}, \ttt{\$obs\_unit}, \ttt{?y\_log}, ' // & '\ttt{?x\_log}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \newline ' // & '\ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, ' // & '\ttt{?draw\_histogram}, \ttt{?fill\_curve}, \newline \ttt{?draw\_piecewise}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // & '\newline \ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})')) call var_list%append_int (var_str ("graph_width_mm"), 130, & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: integer value that sets the width of a graph or histogram ' // & 'in millimeters. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, ' // & '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, \ttt{?draw\_base}, ' // & '\newline \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // & '\ttt{?draw\_errors}, \ttt{?draw\_symbols}, \newline \ttt{\$fill\_options}, ' // & '\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_int (var_str ("graph_height_mm"), 90, & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: integer value that sets the height of a graph or histogram ' // & 'in millimeters. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, ' // & '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, \ttt{?draw\_base}, ' // & '\newline \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // & '\ttt{?draw\_errors}, \ttt{?draw\_symbols}, \newline \ttt{\$fill\_options}, ' // & '\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_log (var_str ("?y_log"), .false., & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: flag that makes the $y$ axis logarithmic. (cf. also ' // & '\ttt{?normalize\_bins}, \ttt{\$obs\_label}, \ttt{\$obs\_unit}, ' // & '\ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, \ttt{\$y\_label}, ' // & '\ttt{graph\_height\_mm}, \ttt{graph\_width\_mm}, \ttt{?y\_log}, ' // & '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \newline ' // & '\ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, ' // & '\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \newline \ttt{?fill\_curve}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{?draw\_symbols}, ' // & '\ttt{\$fill\_options}, \newline \ttt{\$draw\_options}, \ttt{\$err\_options}, ' // & '\ttt{\$symbol})')) call var_list%append_log (var_str ("?x_log"), .false., & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: flag that makes the $x$ axis logarithmic. (cf. also ' // & '\ttt{?normalize\_bins}, \ttt{\$obs\_label}, \ttt{\$obs\_unit}, ' // & '\ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, \ttt{\$y\_label}, ' // & '\ttt{graph\_height\_mm}, \ttt{graph\_width\_mm}, \ttt{?y\_log}, ' // & '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \newline ' // & '\ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, ' // & '\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \newline \ttt{?fill\_curve}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{?draw\_symbols}, ' // & '\ttt{\$fill\_options}, \newline \ttt{\$draw\_options}, \ttt{\$err\_options}, ' // & '\ttt{\$symbol})')) call var_list%append_real (var_str ("x_min"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: real parameter that sets the lower limit of the $x$ ' // & 'axis plotting or histogram interval. (cf. also \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \newline \ttt{?x\_log}, \ttt{graph\_width\_mm}, ' // & '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \newline \ttt{?draw\_histogram}, ' // & '\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // & '\ttt{?draw\_errors}, \newline \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // & '\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_real (var_str ("x_max"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: real parameter that sets the upper limit of the $x$ ' // & 'axis plotting or histogram interval. (cf. also \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \newline \ttt{?x\_log}, \ttt{graph\_width\_mm}, ' // & '\ttt{x\_min}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \newline \ttt{?draw\_histogram}, ' // & '\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // & '\ttt{?draw\_errors}, \newline \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // & '\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_real (var_str ("y_min"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: real parameter that sets the lower limit of the $y$ ' // & 'axis plotting or histogram interval. (cf. also \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \newline \ttt{?x\_log}, \ttt{graph\_width\_mm}, ' // & '\ttt{x\_max}, \ttt{y\_max}, \ttt{x\_min}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \newline \ttt{?draw\_histogram}, ' // & '\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // & '\ttt{?draw\_errors}, \newline \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // & '\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_real (var_str ("y_max"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: real parameter that sets the upper limit of the $y$ ' // & 'axis plotting or histogram interval. (cf. also \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \newline \ttt{?x\_log}, \ttt{graph\_width\_mm}, ' // & '\ttt{x\_max}, \ttt{x\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \newline \ttt{?draw\_histogram}, ' // & '\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // & '\ttt{?draw\_errors}, \newline \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // & '\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_string (var_str ("$gmlcode_bg"), var_str (""), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: string variable that allows to define a background ' // & 'for plots and histograms (i.e. it is overwritten by the plot/histogram), ' // & 'e.g. a grid: \ttt{\$gmlcode\_bg = "standardgrid.lr(5);"}. For ' // & 'more details, see the \gamelan\ manual. (cf. also \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_width\_mm}, ' // & '\ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, ' // & '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_fg}, ' // & '\ttt{?draw\_histogram}, \ttt{?draw\_base}, \ttt{?draw\_piecewise}, ' // & '\newline \ttt{?fill\_curve}, \ttt{?draw\_curve}, \ttt{?draw\_errors}, ' // & '\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \newline \ttt{\$draw\_options}, ' // & '\ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_string (var_str ("$gmlcode_fg"), var_str (""), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: string variable that allows to define a foreground ' // & 'for plots and histograms (i.e. it overwrites the plot/histogram), ' // & 'e.g. a grid: \ttt{\$gmlcode\_bg = "standardgrid.lr(5);"}. For ' // & 'more details, see the \gamelan\ manual. (cf. also \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_width\_mm}, ' // & '\ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, ' // & '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{?draw\_histogram}, \ttt{?draw\_base}, \ttt{?draw\_piecewise}, ' // & '\newline \ttt{?fill\_curve}, \ttt{?draw\_curve}, \ttt{?draw\_errors}, ' // & '\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \newline \ttt{\$draw\_options}, ' // & '\ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_log (var_str ("?draw_histogram"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: flag that tells \whizard\ to either plot data as a ' // & 'histogram or as a continuous line (if $\to$ \ttt{?draw\_curve} ' // & 'is set \ttt{true}). (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // & '\ttt{y\_max}, \newline \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{?draw\_symbols}, ' // & '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options}, ' // & '\ttt{\$symbol})')) call var_list%append_log (var_str ("?draw_base"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: flag that tells \whizard\ to insert a \ttt{base} statement ' // & 'in the analysis code to calculate the plot data from a data ' // & 'set. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // & '\ttt{y\_max}, \newline \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // & '\ttt{\$symbol}, \newline \ttt{?draw\_histogram}, \ttt{?draw\_errors}, ' // & '\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \ttt{\$draw\_options}, ' // & '\newline \ttt{\$err\_options})')) call var_list%append_log (var_str ("?draw_piecewise"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: flag that tells \whizard\ to data from a data set piecewise, ' // & 'i.e. histogram style. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, ' // & '\ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_base}, \ttt{?fill\_curve}, ' // & '\ttt{\$symbol}, \ttt{?draw\_histogram}, \ttt{?draw\_errors}, ' // & '\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \ttt{\$draw\_options}, ' // & '\ttt{\$err\_options})')) call var_list%append_log (var_str ("?fill_curve"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: flag that tells \whizard\ to fill data curves (e.g. ' // & 'as a histogram). The style can be set with $\to$ \ttt{\$fill\_options ' // & '= "{\em }"}. (cf. also \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_width\_mm}, ' // & '\ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, ' // & '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \newline \ttt{\$gmlcode\_fg}, ' // & '\ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, \ttt{?draw\_piecewise}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_histogram}, \ttt{?draw\_errors}, ' // & '\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \ttt{\$draw\_options}, ' // & '\ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_log (var_str ("?draw_curve"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: flag that tells \whizard\ to either plot data as a ' // & 'continuous line or as a histogram (if $\to$ \ttt{?draw\_histogram} ' // & 'is set \ttt{true}). (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // & '\ttt{y\_max}, \newline \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // & '\ttt{?draw\_histogram}, \ttt{?draw\_errors}, \ttt{?draw\_symbols}, ' // & '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options}, ' // & '\ttt{\$symbol})')) call var_list%append_log (var_str ("?draw_errors"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: flag that determines whether error bars should be drawn ' // & 'or not. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // & '\ttt{y\_max}, \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, ' // & '\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_histogram}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // & '\newline \ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_log (var_str ("?draw_symbols"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: flag that determines whether particular symbols (specified ' // & 'by $\to$ \ttt{\$symbol = "{\em }"}) should be ' // & 'used for plotting data points (cf. also \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_width\_mm}, ' // & '\ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, ' // & '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_fg}, ' // & '\ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, \ttt{?draw\_piecewise}, ' // & '\ttt{?fill\_curve}, \ttt{?draw\_histogram}, \ttt{?draw\_curve}, ' // & '\ttt{?draw\_errors}, \ttt{\$fill\_options}, \ttt{\$draw\_options}, ' // & '\newline \ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_string (var_str ("$fill_options"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: \ttt{\$fill\_options = "{\em }"} is a ' // & 'string variable that allows to set fill options when plotting ' // & 'data as filled curves with the $\to$ \ttt{?fill\_curve} flag. ' // & 'For more details see the \gamelan\ manual. (cf. also \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_width\_mm}, ' // & '\ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, ' // & '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_fg}, ' // & '\ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, \ttt{?draw\_piecewise}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_histogram}, \ttt{?draw\_errors}, ' // & '\newline \ttt{?draw\_symbols}, \ttt{?fill\_curve}, \ttt{\$draw\_options}, ' // & '\ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_string (var_str ("$draw_options"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: \ttt{\$draw\_options = "{\em }"} is a ' // & 'string variable that allows to set specific drawing options ' // & 'for plots and histograms. For more details see the \gamelan\ ' // & 'manual. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // & '\ttt{y\_max}, \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, ' // & '\newline \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_histogram}, ' // & '\ttt{?draw\_errors}, \ttt{?draw\_symbols}, \newline \ttt{\$fill\_options}, ' // & '\ttt{?draw\_histogram}, \ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_string (var_str ("$err_options"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: \ttt{\$err\_options = "{\em }"} is a string ' // & 'variable that allows to set specific drawing options for errors ' // & 'in plots and histograms. For more details see the \gamelan\ ' // & 'manual. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // & '\ttt{y\_max}, \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, ' // & '\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_histogram}, ' // & '\ttt{?draw\_errors}, \newline \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // & '\ttt{?draw\_histogram}, \ttt{\$draw\_options}, \ttt{\$symbol})')) call var_list%append_string (var_str ("$symbol"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: \ttt{\$symbol = "{\em }"} is a string ' // & 'variable for the symbols that should be used for plotting data ' // & 'points. (cf. also \ttt{\$obs\_label}, \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \newline \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // & '\ttt{y\_max}, \newline \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // & '\newline \ttt{?draw\_histogram}, \ttt{?draw\_curve}, \ttt{?draw\_errors}, ' // & '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \newline \ttt{\$err\_options}, ' // & '\ttt{?draw\_symbols})')) call var_list%append_log (& var_str ("?analysis_file_only"), .false., & intrinsic=.true., & description=var_str ('Allows to specify that only \LaTeX\ files ' // & "for \whizard's graphical analysis are written out, but not processed. " // & '(cf. \ttt{compile\_analysis}, \ttt{write\_analysis})')) end subroutine var_list_set_gamelan_defaults @ %def var_list_set_gamelan_defaults @ FastJet parameters and friends <>= procedure :: set_clustering_defaults => var_list_set_clustering_defaults +<>= + module subroutine var_list_set_clustering_defaults (var_list) + class(var_list_t), intent(inout) :: var_list + end subroutine var_list_set_clustering_defaults <>= - subroutine var_list_set_clustering_defaults (var_list) + module subroutine var_list_set_clustering_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_int (& var_str ("kt_algorithm"), & kt_algorithm, & intrinsic = .true., locked = .true., & description=var_str ('Specifies a jet algorithm for the ($\to$) ' // & '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // & 'subevent function. At the moment only available for the ' // & 'interfaced external \fastjet\ package. (cf. also ' // & '\ttt{cambridge\_[for\_passive\_]algorithm}, ' // & '\ttt{plugin\_algorithm}, ' // & '\newline\ttt{genkt\_[for\_passive\_]algorithm}, ' // & '\ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_r})')) call var_list%append_int (& var_str ("cambridge_algorithm"), & cambridge_algorithm, intrinsic = .true., locked = .true., & description=var_str ('Specifies a jet algorithm for the ($\to$) ' // & '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // & 'subevent function. At the moment only available for the interfaced ' // & 'external \fastjet\ package. (cf. also \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_for\_passive\_algorithm}, \ttt{plugin\_algorithm}, ' // & '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // & '\ttt{jet\_r})')) call var_list%append_int (& var_str ("antikt_algorithm"), & antikt_algorithm, & intrinsic = .true., locked = .true., & description=var_str ('Specifies a jet algorithm for the ($\to$) ' // & '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // & 'subevent function. At the moment only available for the interfaced ' // & 'external \fastjet\ package. (cf. also \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{plugin\_algorithm}, ' // & '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // & '\ttt{jet\_r})')) call var_list%append_int (& var_str ("genkt_algorithm"), & genkt_algorithm, & intrinsic = .true., locked = .true., & description=var_str ('Specifies a jet algorithm for the ($\to$) ' // & '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // & 'subevent function. At the moment only available for the interfaced ' // & 'external \fastjet\ package. (cf. also \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_for\_passive\_algorithm}, \ttt{plugin\_algorithm}, ' // & '\ttt{genkt\_for\_passive\_algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // & '\ttt{jet\_r}), \ttt{jet\_p}')) call var_list%append_int (& var_str ("cambridge_for_passive_algorithm"), & cambridge_for_passive_algorithm, & intrinsic = .true., locked = .true., & description=var_str ('Specifies a jet algorithm for the ($\to$) ' // & '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // & 'subevent function. At the moment only available for the interfaced ' // & 'external \fastjet\ package. (cf. also \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_algorithm}, \ttt{plugin\_algorithm}, \newline ' // & '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // & '\ttt{jet\_r})')) call var_list%append_int (& var_str ("genkt_for_passive_algorithm"), & genkt_for_passive_algorithm, & intrinsic = .true., locked = .true., & description=var_str ('Specifies a jet algorithm for the ($\to$) ' // & '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // & 'subevent function. At the moment only available for the interfaced ' // & 'external \fastjet\ package. (cf. also \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_for\_passive\_algorithm}, \ttt{plugin\_algorithm}, ' // & '\ttt{genkt\_algorithm}, \ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_r})')) call var_list%append_int (& var_str ("ee_kt_algorithm"), & ee_kt_algorithm, & intrinsic = .true., locked = .true., & description=var_str ('Specifies a jet algorithm for the ($\to$) ' // & '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // & 'subevent function. At the moment only available for the interfaced ' // & 'external \fastjet\ package. (cf. also \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{plugin\_algorithm}, ' // & '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_genkt\_algorithm}, ' // & '\ttt{jet\_r})')) call var_list%append_int (& var_str ("ee_genkt_algorithm"), & ee_genkt_algorithm, & intrinsic = .true., locked = .true., & description=var_str ('Specifies a jet algorithm for the ($\to$) ' // & '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // & 'subevent function. At the moment only available for the interfaced ' // & 'external \fastjet\ package. (cf. also \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{plugin\_algorithm}, ' // & '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_kt\_algorithm}, ' // & '\ttt{jet\_r}), \ttt{jet\_p})')) call var_list%append_int (& var_str ("plugin_algorithm"), & plugin_algorithm, & intrinsic = .true., locked = .true., & description=var_str ('Specifies a jet algorithm for the ($\to$) ' // & '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // & 'subevent function. At the moment only available for the interfaced ' // & 'external \fastjet\ package. (cf. also \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_for\_passive\_algorithm}, \newline ' // & '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // & '\ttt{jet\_r})')) call var_list%append_int (& var_str ("undefined_jet_algorithm"), & undefined_jet_algorithm, & intrinsic = .true., locked = .true., & description=var_str ('This is just a place holder for any kind of jet ' // & 'jet algorithm that is not further specified. (cf. also \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_for\_passive\_algorithm}, \newline ' // & '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // & '\ttt{jet\_r}, \ttt{plugin\_algorithm})')) call var_list%append_int (& var_str ("jet_algorithm"), undefined_jet_algorithm, & intrinsic = .true., & description=var_str ('Variable that allows to set the type of ' // & 'jet algorithm when using the external \fastjet\ library. It ' // & 'accepts one of the following algorithms: ($\to$) \ttt{kt\_algorithm}, ' // & '\newline ($\to$) \ttt{cambridge\_[for\_passive\_]algorithm}, ' // & '($\to$) \ttt{antikt\_algorithm}, ($\to$) \ttt{plugin\_algorithm}, ' // & '($\to$) \ttt{genkt\_[for\_passive\_]algorithm}, ($\to$) ' // & '\ttt{ee\_[gen]kt\_algorithm}). (cf. also \ttt{cluster}, ' // & '\ttt{jet\_p}, \ttt{jet\_r}, \ttt{jet\_ycut})')) call var_list%append_real (& var_str ("jet_r"), 0._default, & intrinsic = .true., & description=var_str ('Value for the distance measure $R$ used in ' // & 'some algorithms that are available via the interface ' // & 'to the \fastjet\ package. (cf. also \ttt{cluster}, \ttt{combine}, ' // & '\ttt{jet\_algorithm}, \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{antikt\_algorithm}, ' // & '\newline \ttt{plugin\_algorithm}, \ttt{genkt\_[for\_passive\_]algorithm}, ' // & '\ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_p}, \newline\ttt{jet\_ycut})')) call var_list%append_real (& var_str ("jet_p"), 0._default, & intrinsic = .true., & description=var_str ('Value for the exponent of the distance measure $R$ in ' // & 'the generalized $k_T$ algorithms that are available via the interface ' // & 'to the \fastjet\ package. (cf. also \ttt{cluster}, \ttt{combine}, ' // & '\ttt{jet\_algorithm}, \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{antikt\_algorithm}, ' // & '\newline \ttt{plugin\_algorithm}, \ttt{genkt\_[for\_passive\_]algorithm}, ' // & '\ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_r}, \newline\ttt{jet\_ycut})')) call var_list%append_real (& var_str ("jet_ycut"), 0._default, & intrinsic = .true., & description=var_str ('Value for the $y$ separation measure used in ' // & 'the Cambridge-Aachen algorithms that are available via the interface ' // & 'to the \fastjet\ package. (cf. also \ttt{cluster}, \ttt{combine}, ' // & '\ttt{kt\_algorithm}, \ttt{jet\_algorithm}, ' // & '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{antikt\_algorithm}, ' // & '\newline \ttt{plugin\_algorithm}, \ttt{genkt\_[for\_passive\_]algorithm}, ' // & '\ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_p}, \newline\ttt{jet\_r})')) call var_list%append_real (& var_str ("jet_dcut"), 0._default, & intrinsic = .true., & description=var_str ('Value for the $d_{ij}$ separation measure used in ' // & 'the $e^+e^- k_T$ algorithms that are available via the interface ' // & 'to the \fastjet\ package. (cf. also \ttt{cluster}, \ttt{combine}, ' // & '\ttt{kt\_algorithm}, \ttt{jet\_algorithm}, ' // & '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{antikt\_algorithm}, ' // & '\newline \ttt{plugin\_algorithm}, \ttt{genkt\_[for\_passive\_]algorithm}, ' // & '\ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_p}, \newline\ttt{jet\_r})')) call var_list%append_log (& var_str ("?keep_flavors_when_clustering"), .false., & intrinsic = .true., & description=var_str ('The logical variable \ttt{?keep\_flavors\_when\_clustering ' // & '= true/false} specifies whether the flavor of a jet should be ' // & 'kept during \ttt{cluster} when a jet consists of one quark and ' // & 'zero or more gluons. Especially useful for cuts on b-tagged ' // & 'jets (cf. also \ttt{cluster}).')) end subroutine var_list_set_clustering_defaults @ %def var_list_set_clustering_defaults @ Frixione isolation and photon recombination parameters and all that: <>= procedure :: set_isolation_recomb_defaults => & var_list_set_isolation_recomb_defaults +<>= + module subroutine var_list_set_isolation_recomb_defaults (var_list) + class(var_list_t), intent(inout) :: var_list + end subroutine var_list_set_isolation_recomb_defaults <>= - subroutine var_list_set_isolation_recomb_defaults (var_list) + module subroutine var_list_set_isolation_recomb_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_real (var_str ("photon_iso_eps"), 1._default, & intrinsic=.true., & description=var_str ('Photon isolation parameter $\epsilon_\gamma$ ' // & '(energy fraction) from hep-ph/9801442 (cf. also ' // & '\ttt{photon\_iso\_n}, \ttt{photon\_iso\_r0})')) call var_list%append_real (var_str ("photon_iso_n"), 1._default, & intrinsic=.true., & description=var_str ('Photon isolation parameter $n$ ' // & '(cone function exponent) from hep-ph/9801442 (cf. also ' // & '\ttt{photon\_iso\_eps}, \ttt{photon\_iso\_r0})')) call var_list%append_real (var_str ("photon_iso_r0"), 0.4_default, & intrinsic=.true., & description=var_str ('Photon isolation parameter $R_0^\gamma$ ' // & '(isolation cone radius) from hep-ph/9801442 (cf. also ' // & '\ttt{photon\_iso\_eps}, \ttt{photon\_iso\_n})')) call var_list%append_real (var_str ("photon_rec_r0"), 0.1_default, & intrinsic=.true., & description=var_str ('Photon recombination parameter $R_0^\gamma$ ' // & 'for photon recombination in NLO EW calculations')) call var_list%append_log (& var_str ("?keep_flavors_when_recombining"), .true., & intrinsic = .true., & description=var_str ('The logical variable \ttt{?keep\_flavors\_when\_recombining ' // & '= true/false} specifies whether the flavor of a particle should be ' // & 'kept during \ttt{photon\_recombination} when a jet/lepton consists of one lepton/quark ' // & 'and zero or more photons (cf. also \ttt{photon\_recombination}).')) end subroutine var_list_set_isolation_recomb_defaults @ %def var_list_set_isolation_recomb_defaults <>= procedure :: set_eio_defaults => var_list_set_eio_defaults +<>= + module subroutine var_list_set_eio_defaults (var_list) + class(var_list_t), intent(inout) :: var_list + end subroutine var_list_set_eio_defaults <>= - subroutine var_list_set_eio_defaults (var_list) + module subroutine var_list_set_eio_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_string (var_str ("$sample"), var_str (""), & intrinsic=.true., & description=var_str ('String variable to set the (base) name ' // & 'of the event output format, e.g. \ttt{\$sample = "foo"} will ' // & 'result in an intrinsic binary format event file \ttt{foo.evx}. ' // & '(cf. also \ttt{sample\_format}, \ttt{simulate}, \ttt{hepevt}, ' // & '\ttt{ascii}, \ttt{athena}, \ttt{debug}, \ttt{long}, \ttt{short}, ' // & '\ttt{hepmc}, \ttt{lhef}, \ttt{lha}, \ttt{stdhep}, \ttt{stdhep\_up}, ' // & '\ttt{\$sample\_normalization}, \ttt{?sample\_pacify}, \ttt{sample\_max\_tries})')) call var_list%append_string (var_str ("$sample_normalization"), var_str ("auto"),& intrinsic=.true., & description=var_str ('String variable that allows to set the ' // & 'normalization of generated events. There are four options: ' // & 'option \ttt{"1"} (events normalized to one), \ttt{"1/n"} (sum ' // & 'of all events in a sample normalized to one), \ttt{"sigma"} ' // & '(events normalized to the cross section of the process), and ' // & '\ttt{"sigma/n"} (sum of all events normalized to the cross ' // & 'section). The default is \ttt{"auto"} where unweighted events ' // & 'are normalized to one, and weighted ones to the cross section. ' // & '(cf. also \ttt{simulate}, \ttt{\$sample}, \ttt{sample\_format}, ' // & '\ttt{?sample\_pacify}, \ttt{sample\_max\_tries}, \ttt{sample\_split\_n\_evt}, ' // & '\ttt{sample\_split\_n\_kbytes})')) call var_list%append_log (var_str ("?sample_pacify"), .false., & intrinsic=.true., & description=var_str ('Flag, mainly for debugging purposes: suppresses ' // & 'numerical noise in the output of a simulation. (cf. also \ttt{simulate}, ' // & '\ttt{\$sample}, \ttt{sample\_format}, \ttt{\$sample\_normalization}, ' // & '\ttt{sample\_max\_tries}, \ttt{sample\_split\_n\_evt}, ' // & '\ttt{sample\_split\_n\_kbytes})')) call var_list%append_log (var_str ("?sample_select"), .true., & intrinsic=.true., & description=var_str ('Logical that determines whether a selection should ' // & 'be applied to the output event format or not. If set to \ttt{false} a ' // & 'selection is only considered for the evaluation of observables. (cf. ' // & '\ttt{select}, \ttt{selection}, \ttt{analysis})')) call var_list%append_int (var_str ("sample_max_tries"), 10000, & intrinsic = .true., & description=var_str ('Integer variable that sets the maximal ' // & 'number of tries for generating a single event. The event might ' // & 'be vetoed because of a very low unweighting efficiency, errors ' // & 'in the event transforms like decays, shower, matching, hadronization ' // & 'etc. (cf. also \ttt{simulate}, \ttt{\$sample}, \ttt{sample\_format}, ' // & '\ttt{?sample\_pacify}, \ttt{\$sample\_normalization}, ' // & '\ttt{sample\_split\_n\_evt}, \newline\ttt{sample\_split\_n\_kbytes})')) call var_list%append_int (var_str ("sample_split_n_evt"), 0, & intrinsic = .true., & description=var_str ('When generating events, this integer parameter ' // & '\ttt{sample\_split\_n\_evt = {\em }} gives the number \ttt{{\em ' // & '}} of breakpoints in the event files, i.e. it splits the ' // & 'event files into \ttt{{\em } + 1} parts. The parts are ' // & 'denoted by \ttt{{\em }.{\em }.{\em ' // & '}}. Here, \ttt{{\em }} is an integer ' // & 'running from \ttt{0} to \ttt{{\em }}. The start can be ' // & 'reset by ($\to$) \ttt{sample\_split\_index}. (cf. also \ttt{simulate}, ' // & '\ttt{\$sample}, \ttt{sample\_format}, \ttt{sample\_max\_tries}, ' // & '\ttt{\$sample\_normalization}, \ttt{?sample\_pacify}, ' // & '\ttt{sample\_split\_n\_kbytes})')) call var_list%append_int (var_str ("sample_split_n_kbytes"), 0, & intrinsic = .true., & description=var_str ('When generating events, this integer parameter ' // & '\ttt{sample\_split\_n\_kbytes = {\em }} limits the file ' // & 'size of event files. Whenever an event file has exceeded this ' // & 'size, counted in kilobytes, the following events will be written ' // & 'to a new file. The naming conventions are the same as for ' // & '\ttt{sample\_split\_n\_evt}. (cf. also \ttt{simulate}, \ttt{\$sample}, ' // & '\ttt{sample\_format}, \ttt{sample\_max\_tries}, \ttt{\$sample\_normalization}, ' // & '\ttt{?sample\_pacify})')) call var_list%append_int (var_str ("sample_split_index"), 0, & intrinsic = .true., & description=var_str ('Integer number that gives the starting ' // & 'index \ttt{sample\_split\_index = {\em }} for ' // & 'the numbering of event samples \ttt{{\em }.{\em ' // & '}.{\em }} split by the \ttt{sample\_split\_n\_evt ' // & '= {\em }}. The index runs from \ttt{{\em }} ' // & 'to \newline \ttt{{\em } + {\em }}. (cf. also \ttt{simulate}, ' // & '\ttt{\$sample}, \ttt{sample\_format}, \newline\ttt{\$sample\_normalization}, ' // & '\ttt{sample\_max\_tries}, \ttt{?sample\_pacify})')) call var_list%append_string (var_str ("$rescan_input_format"), var_str ("raw"), & intrinsic=.true., & description=var_str ('String variable that allows to set the ' // & 'event format of the event file that is to be rescanned by the ' // & '($\to$) \ttt{rescan} command.')) call var_list%append_log (var_str ("?read_raw"), .true., & intrinsic=.true., & description=var_str ('This flag demands \whizard\ to (try to) ' // & 'read events (from the internal binary format) first before ' // & 'generating new ones. (cf. \ttt{simulate}, \ttt{?write\_raw}, ' // & '\ttt{\$sample}, \ttt{sample\_format})')) call var_list%append_log (var_str ("?write_raw"), .true., & intrinsic=.true., & description=var_str ("Flag to write out events in \whizard's " // & 'internal binary format. (cf. \ttt{simulate}, \ttt{?read\_raw}, ' // & '\ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$extension_raw"), var_str ("evx"), & intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_raw ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & "to which events in \whizard's internal format are written. If " // & 'not set, the default file name and suffix is \ttt{{\em }.evx}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$extension_default"), var_str ("evt"), & intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_default ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in a the standard \whizard\ verbose ASCII format ' // & 'are written. If not set, the default file name and suffix is ' // & '\ttt{{\em }.evt}. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample})')) call var_list%append_string (var_str ("$debug_extension"), var_str ("debug"), & intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$debug\_extension ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in a long verbose format with debugging information ' // & 'are written. If not set, the default file name and suffix is ' // & '\ttt{{\em }.debug}. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample}, \ttt{?debug\_process}, \ttt{?debug\_transforms}, ' // & '\ttt{?debug\_decay}, \ttt{?debug\_verbose})')) call var_list%append_log (var_str ("?debug_process"), .true., & intrinsic=.true., & description=var_str ('Flag that decides whether process information ' // & 'will be displayed in the ASCII debug event format ($\to$) \ttt{debug}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample}, \ttt{\$debug\_extension}, ' // & '\ttt{?debug\_decay}, \ttt{?debug\_transforms}, \ttt{?debug\_verbose})')) call var_list%append_log (var_str ("?debug_transforms"), .true., & intrinsic=.true., & description=var_str ('Flag that decides whether information ' // & 'about event transforms will be displayed in the ASCII debug ' // & 'event format ($\to$) \ttt{debug}. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample}, \ttt{?debug\_decay}, \ttt{\$debug\_extension}, ' // & '\ttt{?debug\_process}, \ttt{?debug\_verbose})')) call var_list%append_log (var_str ("?debug_decay"), .true., & intrinsic=.true., & description=var_str ('Flag that decides whether decay information ' // & 'will be displayed in the ASCII debug event format ($\to$) \ttt{debug}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample}, \ttt{\$debug\_extension}, ' // & '\ttt{?debug\_process}, \ttt{?debug\_transforms}, \ttt{?debug\_verbose})')) call var_list%append_log (var_str ("?debug_verbose"), .true., & intrinsic=.true., & description=var_str ('Flag that decides whether extensive verbose ' // & 'information will be included in the ASCII debug event format ' // & '($\to$) \ttt{debug}. (cf. also \ttt{sample\_format}, \ttt{\$sample}, ' // & '\ttt{\$debug\_extension}, \ttt{?debug\_decay}, \ttt{?debug\_transforms}, ' // & '\ttt{?debug\_process})')) call var_list%append_string (var_str ("$dump_extension"), var_str ("pset.dat"), & intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$dump\_extension ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & "to which events in \whizard's internal particle set format " // & 'are written. If not set, the default file name and suffix is ' // & '\ttt{{\em }.pset.dat}. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample}, \ttt{dump}, \ttt{?dump\_compressed}, ' // & '\ttt{?dump\_screen}, \ttt{?dump\_summary}, \ttt{?dump\_weights})')) call var_list%append_log (var_str ("?dump_compressed"), .false., & intrinsic=.true., & description=var_str ('Flag that, if set to \ttt{true}, issues ' // & 'a very compressed and clear version of the \ttt{dump} ($\to$) ' // & 'event format. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample}, \ttt{dump}, \ttt{\$dump\_extension}, ' // & '\ttt{?dump\_screen}, \ttt{?dump\_summary}, \ttt{?dump\_weights})')) call var_list%append_log (var_str ("?dump_weights"), .false., & intrinsic=.true., & description=var_str ('Flag that, if set to \ttt{true}, includes ' // & 'cross sections, weights and excess in the \ttt{dump} ($\to$) ' // & 'event format. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample}, \ttt{dump}, \ttt{?dump\_compressed}, ' // & '\ttt{\$dump\_extension}, \ttt{?dump\_screen}, \ttt{?dump\_summary})')) call var_list%append_log (var_str ("?dump_summary"), .false., & intrinsic=.true., & description=var_str ('Flag that, if set to \ttt{true}, includes ' // & 'a summary with momentum sums for incoming and outgoing particles ' // & 'as well as for beam remnants in the \ttt{dump} ($\to$) ' // & 'event format. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample}, \ttt{dump}, \ttt{?dump\_compressed}, ' // & '\ttt{\$dump\_extension}, \ttt{?dump\_screen}, \ttt{?dump\_weights})')) call var_list%append_log (var_str ("?dump_screen"), .false., & intrinsic=.true., & description=var_str ('Flag that, if set to \ttt{true}, outputs ' // & 'events for the \ttt{dump} ($\to$) event format on screen ' // & ' instead of to a file. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample}, \ttt{dump}, \ttt{?dump\_compressed}, ' // & '\ttt{\$dump\_extension}, \ttt{?dump\_summary}, \ttt{?dump\_weights})')) call var_list%append_log (var_str ("?hepevt_ensure_order"), .false., & intrinsic=.true., & description=var_str ('Flag to ensure that the particle set confirms ' // & 'the HEPEVT standard. This involves some copying and reordering ' // & 'to guarantee that mothers and daughters are always next to ' // & 'each other. Usually this is not necessary.')) call var_list%append_string (var_str ("$extension_hepevt"), var_str ("hepevt"), & intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_hepevt ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the \whizard\ version 1 style HEPEVT ASCII ' // & 'format are written. If not set, the default file name and suffix ' // & 'is \ttt{{\em }.hepevt}. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample})')) call var_list%append_string (var_str ("$extension_ascii_short"), & var_str ("short.evt"), intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_ascii\_short ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the so called short variant of the \whizard\ ' // & 'version 1 style HEPEVT ASCII format are written. If not set, ' // & 'the default file name and suffix is \ttt{{\em }.short.evt}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$extension_ascii_long"), & var_str ("long.evt"), intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_ascii\_long ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the so called long variant of the \whizard\ ' // & 'version 1 style HEPEVT ASCII format are written. If not set, ' // & 'the default file name and suffix is \ttt{{\em }.long.evt}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$extension_athena"), & var_str ("athena.evt"), intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_athena ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the ATHENA file format are written. If not ' // & 'set, the default file name and suffix is \ttt{{\em }.athena.evt}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$extension_mokka"), & var_str ("mokka.evt"), intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_mokka ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the MOKKA format are written. If not set, ' // & 'the default file name and suffix is \ttt{{\em }.mokka.evt}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$lhef_version"), var_str ("2.0"), & intrinsic = .true., & description=var_str ('Specifier for the Les Houches Accord (LHEF) ' // & 'event format files with XML headers to discriminate among different ' // & 'versions of this format. (cf. also \ttt{\$sample}, \ttt{sample\_format}, ' // & '\ttt{lhef}, \ttt{\$lhef\_extension}, \ttt{\$lhef\_extension}, ' // & '\ttt{?lhef\_write\_sqme\_prc}, \ttt{?lhef\_write\_sqme\_ref}, ' // & '\ttt{?lhef\_write\_sqme\_alt})')) call var_list%append_string (var_str ("$lhef_extension"), var_str ("lhe"), & intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$lhef\_extension ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the LHEF format are written. If not set, ' // & 'the default file name and suffix is \ttt{{\em }.lhe}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample}, \ttt{lhef}, ' // & '\ttt{\$lhef\_extension}, \ttt{\$lhef\_version}, \ttt{?lhef\_write\_sqme\_prc}, ' // & '\ttt{?lhef\_write\_sqme\_ref}, \ttt{?lhef\_write\_sqme\_alt})')) call var_list%append_log (var_str ("?lhef_write_sqme_prc"), .true., & intrinsic = .true., & description=var_str ('Flag that decides whether in the ($\to$) ' // & '\ttt{lhef} event format the weights of the squared matrix element ' // & 'of the corresponding process shall be written in the LHE file. ' // & '(cf. also \ttt{\$sample}, \ttt{sample\_format}, \ttt{lhef}, ' // & '\ttt{\$lhef\_extension}, \ttt{\$lhef\_extension}, \ttt{?lhef\_write\_sqme\_ref}, ' // & '\newline \ttt{?lhef\_write\_sqme\_alt})')) call var_list%append_log (var_str ("?lhef_write_sqme_ref"), .false., & intrinsic = .true., & description=var_str ('Flag that decides whether in the ($\to$) ' // & '\ttt{lhef} event format reference weights of the squared matrix ' // & 'element shall be written in the LHE file. (cf. also \ttt{\$sample}, ' // & '\ttt{sample\_format}, \ttt{lhef}, \ttt{\$lhef\_extension}, \ttt{\$lhef\_extension}, ' // & '\ttt{?lhef\_write\_sqme\_prc}, \ttt{?lhef\_write\_sqme\_alt})')) call var_list%append_log (var_str ("?lhef_write_sqme_alt"), .true., & intrinsic = .true., & description=var_str ('Flag that decides whether in the ($\to$) ' // & '\ttt{lhef} event format alternative weights of the squared matrix ' // & 'element shall be written in the LHE file. (cf. also \ttt{\$sample}, ' // & '\ttt{sample\_format}, \ttt{lhef}, \ttt{\$lhef\_extension}, \ttt{\$lhef\_extension}, ' // & '\ttt{?lhef\_write\_sqme\_prc}, \ttt{?lhef\_write\_sqme\_ref})')) call var_list%append_string (var_str ("$extension_lha"), var_str ("lha"), & intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_lha ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the (deprecated) LHA format are written. ' // & 'If not set, the default file name and suffix is \ttt{{\em }.lha}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$extension_hepmc"), var_str ("hepmc"), & intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_hepmc ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the HepMC format are written. If not set, ' // & 'the default file name and suffix is \ttt{{\em }.hepmc}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_log (var_str ("?hepmc_output_cross_section"), .false., & intrinsic = .true., & description=var_str ('Flag for the HepMC event format that allows ' // & 'to write out the cross section (and error) from the integration ' // & 'together with each HepMC event. This can be used by programs ' // & 'like Rivet to scale histograms according to the cross section. ' // & '(cf. also \ttt{hepmc})')) call var_list%append_log (var_str ("?hepmc3_write_flows"), .false., & intrinsic = .true., & description=var_str ('Flag for the HepMC3 event format that decides' // & 'whether to write out color flows. The default is \ttt{false}. ' // & '(cf. also \ttt{hepmc})')) call var_list%append_string (var_str ("$hepmc3_mode"), var_str ("HepMC3"), & intrinsic = .true., & description=var_str ('This specifies the writer mode for HepMC3. ' // & 'Possible values are \ttt{HepMC2}, \ttt{HepMC3} (default), ' // & '\ttt{HepEVT}, \ttt{Root}. and \ttt{RootTree} (cf. also \ttt{hepmc})')) call var_list%append_string (var_str ("$extension_lcio"), var_str ("slcio"), & intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_lcio ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the LCIO format are written. If not set, ' // & 'the default file name and suffix is \ttt{{\em }.slcio}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$extension_stdhep"), var_str ("hep"), & intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_stdhep ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the StdHEP format via the HEPEVT common ' // & 'block are written. If not set, the default file name and suffix ' // & 'is \ttt{{\em }.hep}. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample})')) call var_list%append_string (var_str ("$extension_stdhep_up"), & var_str ("up.hep"), intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_stdhep\_up ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the StdHEP format via the HEPRUP/HEPEUP ' // & 'common blocks are written. \ttt{{\em }.up.hep} ' // & 'is the default file name and suffix, if this variable not set. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$extension_stdhep_ev4"), & var_str ("ev4.hep"), intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_stdhep\_ev4 ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the StdHEP format via the HEPEVT/HEPEV4 ' // & 'common blocks are written. \ttt{{\em }.up.hep} ' // & 'is the default file name and suffix, if this variable not set. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$extension_hepevt_verb"), & var_str ("hepevt.verb"), intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_hepevt\_verb ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the \whizard\ version 1 style extended or ' // & 'verbose HEPEVT ASCII format are written. If not set, the default ' // & 'file name and suffix is \ttt{{\em }.hepevt.verb}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$extension_lha_verb"), & var_str ("lha.verb"), intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_lha\_verb ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the (deprecated) extended or verbose LHA ' // & 'format are written. If not set, the default file name and suffix ' // & 'is \ttt{{\em }.lha.verb}. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample})')) end subroutine var_list_set_eio_defaults @ %def var_list_set_eio_defaults @ <>= procedure :: set_shower_defaults => var_list_set_shower_defaults +<>= + module subroutine var_list_set_shower_defaults (var_list) + class(var_list_t), intent(inout) :: var_list + end subroutine var_list_set_shower_defaults <>= - subroutine var_list_set_shower_defaults (var_list) + module subroutine var_list_set_shower_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_log (var_str ("?allow_shower"), .true., & intrinsic=.true., & description=var_str ('Master flag to switch on (initial and ' // & 'final state) parton shower, matching/merging as an event ' // & 'transform. As a default, it is switched on. (cf. also \ttt{?ps\_ ' // & '....}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_log (var_str ("?ps_fsr_active"), .false., & intrinsic=.true., & description=var_str ('Flag that switches final-state QCD radiation ' // & '(FSR) on. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, ' // & '\ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_log (var_str ("?ps_isr_active"), .false., & intrinsic=.true., & description=var_str ('Flag that switches initial-state QCD ' // & 'radiation (ISR) on. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // & '...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_log (var_str ("?ps_taudec_active"), .false., & intrinsic=.true., & description=var_str ('Flag to switch on $\tau$ decays, at ' // & 'the moment only via the included external package \ttt{TAUOLA} ' // & 'and \ttt{PHOTOS}. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // & '...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_log (var_str ("?muli_active"), .false., & intrinsic=.true., & description=var_str ("Master flag that switches on \whizard's " // & 'module for multiple interaction with interleaved QCD parton ' // & 'showers for hadron colliders. Note that this feature is still ' // & 'experimental. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // & '...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...})')) call var_list%append_string (var_str ("$shower_method"), var_str ("WHIZARD"), & intrinsic=.true., & description=var_str ('String variable that allows to specify ' // & 'which parton shower is being used, the default, \ttt{"WHIZARD"}, ' // & 'is one of the in-house showers of \whizard. Other possibilities ' // & 'at the moment are only \ttt{"PYTHIA6"}.')) call var_list%append_log (var_str ("?shower_verbose"), .false., & intrinsic=.true., & description=var_str ('Flag to switch on verbose messages when ' // & 'using shower and/or hadronization. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...},')) call var_list%append_string (var_str ("$ps_PYTHIA_PYGIVE"), var_str (""), & intrinsic=.true., & description=var_str ('String variable that allows to pass options ' // & 'for tunes etc. to the attached \pythia\ parton shower or hadronization, ' // & 'e.g.: \ttt{\$ps\_PYTHIA\_PYGIVE = "MSTJ(41)=1"}. (cf. also ' // & '\newline \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_string (var_str ("$ps_PYTHIA8_config"), var_str (""), & intrinsic=.true., & description=var_str ('String variable that allows to pass options ' // & 'for tunes etc. to the attached \pythia\ttt{8} parton shower or hadronization, ' // & 'e.g.: \ttt{\$ps\_PYTHIA8\_config = "PartonLevel:MPI = off"}. (cf. also ' // & '\newline \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_string (var_str ("$ps_PYTHIA8_config_file"), var_str (""), & intrinsic=.true., & description=var_str ('String variable that allows to pass a filename to a ' // & '\pythia\ttt{8} configuration file.')) call var_list%append_real (& var_str ("ps_mass_cutoff"), 1._default, intrinsic = .true., & description=var_str ('Real value that sets the QCD parton shower ' // & 'lower cutoff scale, where hadronization sets in. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (& var_str ("ps_fsr_lambda"), 0.29_default, intrinsic = .true., & description=var_str ('By this real parameter, the value of $\Lambda_{QCD}$ ' // & 'used in running $\alpha_s$ for time-like showers is set (except ' // & 'for showers in the decay of a resonance). (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (& var_str ("ps_isr_lambda"), 0.29_default, intrinsic = .true., & description=var_str ('By this real parameter, the value of $\Lambda_{QCD}$ ' // & 'used in running $\alpha_s$ for space-like showers is set. (cf. ' // & 'also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, ' // & '\ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_int (& var_str ("ps_max_n_flavors"), 5, intrinsic = .true., & description=var_str ('This integer parameter sets the maxmimum ' // & 'number of flavors that can be produced in a QCD shower $g\to ' // & 'q\bar q$. It is also used as the maximal number of active flavors ' // & 'for the running of $\alpha_s$ in the shower (with a minimum ' // & 'of 3). (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_log (var_str ("?ps_isr_alphas_running"), .true., & intrinsic=.true., & description=var_str ('Flag that decides whether a running ' // & '$\alpha_s$ is taken in space-like QCD parton showers. (cf. ' // & 'also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, ' // & '\ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_log (var_str ("?ps_fsr_alphas_running"), .true., & intrinsic=.true., & description=var_str ('Flag that decides whether a running ' // & '$\alpha_s$ is taken in time-like QCD parton showers. (cf. ' // & 'also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, ' // & '\ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str ("ps_fixed_alphas"), & 0._default, intrinsic = .true., & description=var_str ('This real parameter sets the value of $\alpha_s$ ' // & 'if it is (cf. $\to$ \ttt{?ps\_isr\_alphas\_running}, \newline ' // & '\ttt{?ps\_fsr\_alphas\_running}) not running in initial and/or ' // & 'final-state QCD showers. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // & '...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_log (var_str ("?ps_isr_pt_ordered"), .false., & intrinsic=.true., & description=var_str ('By this flag, it can be switched between ' // & 'the analytic QCD ISR shower (\ttt{false}, default) and the ' // & '$p_T$ ISR QCD shower (\ttt{true}). (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_log (var_str ("?ps_isr_angular_ordered"), .true., & intrinsic=.true., & description=var_str ('If switched one, this flag forces opening ' // & 'angles of emitted partons in the QCD ISR shower to be strictly ' // & 'ordered, i.e. increasing towards the hard interaction. (cf. ' // & 'also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, ' // & '\ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("ps_isr_primordial_kt_width"), 0._default, intrinsic = .true., & description=var_str ('This real parameter sets the width $\sigma ' // & '= \braket{k_T^2}$ for the Gaussian primordial $k_T$ distribution ' // & 'inside the hadron, given by: $\exp[-k_T^2/\sigma^2] k_T dk_T$. ' // & '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("ps_isr_primordial_kt_cutoff"), 5._default, intrinsic = .true., & description=var_str ('Real parameter that sets the upper cutoff ' // & 'for the primordial $k_T$ distribution inside a hadron. (cf. ' // & 'also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, ' // & '\ttt{?hadronization\_active}, \ttt{?mlm\_ ...})')) call var_list%append_real (var_str & ("ps_isr_z_cutoff"), 0.999_default, intrinsic = .true., & description=var_str ('This real parameter allows to set the upper ' // & 'cutoff on the splitting variable $z$ in space-like QCD parton ' // & 'showers. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, ' // & '\ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("ps_isr_minenergy"), 1._default, intrinsic = .true., & description=var_str ('By this real parameter, the minimal effective ' // & 'energy (in the c.m. frame) of a time-like or on-shell-emitted ' // & 'parton in a space-like QCD shower is set. For a hard subprocess ' // & 'that is not in the rest frame, this number is roughly reduced ' // & 'by a boost factor $1/\gamma$ to the rest frame of the hard scattering ' // & 'process. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, ' // & '\ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("ps_isr_tscalefactor"), 1._default, intrinsic = .true., & description=var_str ('The $Q^2$ scale of the hard scattering ' // & 'process is multiplied by this real factor to define the maximum ' // & 'parton virtuality allowed in time-like QCD showers. This does ' // & 'only apply to $t$- and $u$-channels, while for $s$-channel resonances ' // & 'the maximum virtuality is set by $m^2$. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_log (var_str & ("?ps_isr_only_onshell_emitted_partons"), .false., intrinsic=.true., & description=var_str ('This flag if set true sets all emitted ' // & 'partons off space-like showers on-shell, i.e. it would not allow ' // & 'associated time-like showers. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) end subroutine var_list_set_shower_defaults @ %def var_list_set_shower_defaults @ <>= procedure :: set_hadronization_defaults => var_list_set_hadronization_defaults +<>= + module subroutine var_list_set_hadronization_defaults (var_list) + class(var_list_t), intent(inout) :: var_list + end subroutine var_list_set_hadronization_defaults <>= - subroutine var_list_set_hadronization_defaults (var_list) + module subroutine var_list_set_hadronization_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_log & (var_str ("?allow_hadronization"), .true., intrinsic=.true., & description=var_str ('Master flag to switch on hadronization ' // & 'as an event transform. As a default, it is switched on. (cf. ' // & 'also \ttt{?ps\_ ....}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, ' // & '\ttt{?hadronization\_active})')) call var_list%append_log & (var_str ("?hadronization_active"), .false., intrinsic=.true., & description=var_str ('Master flag to switch hadronization (through ' // & 'the attached \pythia\ package) on or off. As a default, it is ' // & 'off. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{?mlm\_ ...})')) call var_list%append_string & (var_str ("$hadronization_method"), var_str ("PYTHIA6"), intrinsic = .true., & description=var_str ("Determines whether \whizard's own " // & "hadronization or the (internally included) \pythiasix\ should be used.")) call var_list%append_real & (var_str ("hadron_enhanced_fraction"), 0.01_default, intrinsic = .true., & description=var_str ('Fraction of Lund strings that break with enhanced ' // & 'width. [not yet active]')) call var_list%append_real & (var_str ("hadron_enhanced_width"), 2.0_default, intrinsic = .true., & description=var_str ('Enhancement factor for the width of breaking ' // & 'Lund strings. [not yet active]')) end subroutine var_list_set_hadronization_defaults @ %def var_list_set_hadronization_defaults @ <>= procedure :: set_tauola_defaults => var_list_set_tauola_defaults +<>= + module subroutine var_list_set_tauola_defaults (var_list) + class(var_list_t), intent(inout) :: var_list + end subroutine var_list_set_tauola_defaults <>= - subroutine var_list_set_tauola_defaults (var_list) + module subroutine var_list_set_tauola_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_log (& var_str ("?ps_tauola_photos"), .false., intrinsic=.true., & description=var_str ('Flag to switch on \ttt{PHOTOS} for photon ' // & 'showering inside the \ttt{TAUOLA} package. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})')) call var_list%append_log (& var_str ("?ps_tauola_transverse"), .false., intrinsic=.true., & description=var_str ('Flag to switch transverse $\tau$ polarization ' // & 'on or off for Higgs decays into $\tau$ leptons. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})')) call var_list%append_log (& var_str ("?ps_tauola_dec_rad_cor"), .true., intrinsic=.true., & description=var_str ('Flag to switch radiative corrections for ' // & '$\tau$ decays in \ttt{TAUOLA} on or off. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})')) call var_list%append_int (& var_str ("ps_tauola_dec_mode1"), 0, intrinsic = .true., & description=var_str ('Integer code to request a specific $\tau$ ' // & 'decay within \ttt{TAUOLA} for the decaying $\tau$, and -- ' // & 'in correlated decays -- for the second $\tau$. For more information ' // & 'cf. the comments in the code or the \ttt{TAUOLA} manual. ' // & '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})')) call var_list%append_int (& var_str ("ps_tauola_dec_mode2"), 0, intrinsic = .true., & description=var_str ('Integer code to request a specific $\tau$ ' // & 'decay within \ttt{TAUOLA} for the decaying $\tau$, and -- ' // & 'in correlated decays -- for the second $\tau$. For more information ' // & 'cf. the comments in the code or the \ttt{TAUOLA} manual. ' // & '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})')) call var_list%append_real (& var_str ("ps_tauola_mh"), 125._default, intrinsic = .true., & description=var_str ('Real option to set the Higgs mass for Higgs ' // & 'decays into $\tau$ leptons in the interface to \ttt{TAUOLA}. ' // & '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})')) call var_list%append_real (& var_str ("ps_tauola_mix_angle"), 90._default, intrinsic = .true., & description=var_str ('Option to set the mixing angle between ' // & 'scalar and pseudoscalar Higgs bosons for Higgs decays into $\tau$ ' // & 'leptons in the interface to \ttt{TAUOLA}. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})')) call var_list%append_log (& var_str ("?ps_tauola_pol_vector"), .false., intrinsic = .true., & description=var_str ('Flag to decide whether for transverse $\tau$ ' // & 'polarization, polarization information should be taken from ' // & '\ttt{TAUOLA} or not. The default is just based on random numbers. ' // & '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})')) end subroutine var_list_set_tauola_defaults @ %def var_list_set_tauola_defaults @ <>= procedure :: set_mlm_matching_defaults => var_list_set_mlm_matching_defaults +<>= + module subroutine var_list_set_mlm_matching_defaults (var_list) + class(var_list_t), intent(inout) :: var_list + end subroutine var_list_set_mlm_matching_defaults <>= - subroutine var_list_set_mlm_matching_defaults (var_list) + module subroutine var_list_set_mlm_matching_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_log (var_str ("?mlm_matching"), .false., & intrinsic=.true., & description=var_str ('Master flag to switch on MLM (LO) jet ' // & 'matching between hard matrix elements and the QCD parton ' // & 'shower. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, ' // & '\ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_Qcut_ME"), 0._default, intrinsic = .true., & description=var_str ('Real parameter that in the MLM jet matching ' // & 'between hard matrix elements and QCD parton shower sets a possible ' // & 'virtuality cut on jets from the hard matrix element. (cf. also ' // & '\ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ' // & '...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_Qcut_PS"), 0._default, intrinsic = .true., & description=var_str ('Real parameter that in the MLM jet matching ' // & 'between hard matrix elements and QCD parton shower sets a possible ' // & 'virtuality cut on jets from the parton shower. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_ptmin"), 0._default, intrinsic = .true., & description=var_str ('This real parameter sets a minimal $p_T$ ' // & 'that enters the $y_{cut}$ jet clustering measure in the MLM ' // & 'jet matching between hard matrix elements and QCD parton showers. ' // & '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_etamax"), 0._default, intrinsic = .true., & description=var_str ('This real parameter sets a maximal pseudorapidity ' // & 'that enters the MLM jet matching between hard matrix elements ' // & 'and QCD parton showers. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // & '...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_Rmin"), 0._default, intrinsic = .true., & description=var_str ('Real parameter that sets a minimal $R$ ' // & 'distance value that enters the $y_{cut}$ jet clustering measure ' // & 'in the MLM jet matching between hard matrix elements and QCD ' // & 'parton showers. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // & '...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_Emin"), 0._default, intrinsic = .true., & description=var_str ('Real parameter that sets a minimal energy ' // & '$E_{min}$ value as an infrared cutoff in the MLM jet matching ' // & 'between hard matrix elements and QCD parton showers. (cf. also ' // & '\ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ' // & '...}, \ttt{?hadronization\_active})')) call var_list%append_int (var_str & ("mlm_nmaxMEjets"), 0, intrinsic = .true., & description=var_str ('This integer sets the maximal number of ' // & 'jets that are available from hard matrix elements in the MLM ' // & 'jet matching between hard matrix elements and QCD parton shower. ' // & '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_ETclusfactor"), 0.2_default, intrinsic = .true., & description=var_str ('This real parameter is a factor that enters ' // & 'the calculation of the $y_{cut}$ measure for jet clustering ' // & 'after the parton shower in the MLM jet matching between hard ' // & 'matrix elements and QCD parton showers. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_ETclusminE"), 5._default, intrinsic = .true., & description=var_str ('This real parameter is a minimal energy ' // & 'that enters the calculation of the $y_{cut}$ measure for jet ' // & 'clustering after the parton shower in the MLM jet matching between ' // & 'hard matrix elements and QCD parton showers. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_etaclusfactor"), 1._default, intrinsic = .true., & description=var_str ('This real parameter is a factor that enters ' // & 'the calculation of the $y_{cut}$ measure for jet clustering ' // & 'after the parton shower in the MLM jet matching between hard ' // & 'matrix elements and QCD parton showers. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_Rclusfactor"), 1._default, intrinsic = .true., & description=var_str ('This real parameter is a factor that enters ' // & 'the calculation of the $y_{cut}$ measure for jet clustering ' // & 'after the parton shower in the MLM jet matching between hard ' // & 'matrix elements and QCD parton showers. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_Eclusfactor"), 1._default, intrinsic = .true., & description=var_str ('This real parameter is a factor that enters ' // & 'the calculation of the $y_{cut}$ measure for jet clustering ' // & 'after the parton shower in the MLM jet matching between hard ' // & 'matrix elements and QCD parton showers. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) end subroutine var_list_set_mlm_matching_defaults @ %def var_list_set_mlm_matching_defaults @ <>= procedure :: set_powheg_matching_defaults => & var_list_set_powheg_matching_defaults +<>= + module subroutine var_list_set_powheg_matching_defaults (var_list) + class(var_list_t), intent(inout) :: var_list + end subroutine var_list_set_powheg_matching_defaults <>= - subroutine var_list_set_powheg_matching_defaults (var_list) + module subroutine var_list_set_powheg_matching_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_log (var_str ("?powheg_matching"), & .false., intrinsic = .true., & description=var_str ('Activates Powheg matching. Needs to be ' // & 'combined with the \ttt{?combined\_nlo\_integration}-method.')) call var_list%append_log (var_str ("?powheg_use_singular_jacobian"), & .false., intrinsic = .true., & description=var_str ('This allows to give a different ' // & 'normalization of the Jacobian, resulting in an alternative ' // & 'POWHEG damping in the singular regions.')) call var_list%append_int (var_str ("powheg_grid_size_xi"), & 5, intrinsic = .true., & description=var_str ('Number of $\xi$ points in the POWHEG grid.')) call var_list%append_int (var_str ("powheg_grid_size_y"), & 5, intrinsic = .true., & description=var_str ('Number of $y$ points in the POWHEG grid.')) call var_list%append_real (var_str ("powheg_pt_min"), & 1._default, intrinsic = .true., & description=var_str ('Lower $p_T$-cut-off for the POWHEG ' // & 'hardest emission.')) call var_list%append_real (var_str ("powheg_lambda"), & LAMBDA_QCD_REF, intrinsic = .true., & description=var_str ('Reference scale of the $\alpha_s$ evolution ' // & 'in the POWHEG matching algorithm.')) call var_list%append_log (var_str ("?powheg_test_sudakov"), & .false., intrinsic = .true., & description=var_str ('Performs an internal consistency check ' // & 'on the POWHEG event generation.')) call var_list%append_log (var_str ("?powheg_disable_sudakov"), & .false., intrinsic = .true., & description=var_str ('This flag allows to set the Sudakov form ' // & 'factor to one. This effectively results in a version of ' // & 'the matrix-element method (MEM) at NLO.')) end subroutine var_list_set_powheg_matching_defaults @ %def var_list_set_powheg_matching_defaults @ <>= procedure :: set_openmp_defaults => var_list_set_openmp_defaults +<>= + module subroutine var_list_set_openmp_defaults (var_list) + class(var_list_t), intent(inout) :: var_list + end subroutine var_list_set_openmp_defaults <>= - subroutine var_list_set_openmp_defaults (var_list) + module subroutine var_list_set_openmp_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_log (var_str ("?omega_openmp"), & openmp_is_active (), & intrinsic=.true., & description=var_str ('Flag to switch on or off OpenMP multi-threading ' // & "for \oMega\ matrix elements. (cf. also \ttt{\$method}, \ttt{\$omega\_flag})")) call var_list%append_log (var_str ("?openmp_is_active"), & openmp_is_active (), & locked=.true., intrinsic=.true., & description=var_str ('Flag to switch on or off OpenMP multi-threading ' // & 'for \whizard. (cf. also \ttt{?openmp\_logging}, \ttt{openmp\_num\_threads}, ' // & '\ttt{openmp\_num\_threads\_default}, \ttt{?omega\_openmp})')) call var_list%append_int (var_str ("openmp_num_threads_default"), & openmp_get_default_max_threads (), & locked=.true., intrinsic=.true., & description=var_str ('Integer parameter that shows the number ' // & 'of default OpenMP threads for multi-threading. Note that this ' // & 'parameter can only be accessed, but not reset by the user. (cf. ' // & 'also \ttt{?openmp\_logging}, \ttt{openmp\_num\_threads}, \ttt{?omega\_openmp})')) call var_list%append_int (var_str ("openmp_num_threads"), & openmp_get_max_threads (), & intrinsic=.true., & description=var_str ('Integer parameter that sets the number ' // & 'of OpenMP threads for multi-threading. (cf. also \ttt{?openmp\_logging}, ' // & '\ttt{openmp\_num\_threads\_default}, \ttt{?omega\_openmp})')) call var_list%append_log (var_str ("?openmp_logging"), & .true., intrinsic=.true., & description=var_str ('This logical -- when set to \ttt{false} ' // & '-- suppresses writing out messages about OpenMP parallelization ' // & '(number of used threads etc.) on screen and into the logfile ' // & '(default name \ttt{whizard.log}) for the whole \whizard\ run. ' // & 'Mainly for debugging purposes. (cf. also \ttt{?logging}, ' // & '\ttt{?mpi\_logging})')) end subroutine var_list_set_openmp_defaults @ %def var_list_set_openmp_defaults @ <>= procedure :: set_mpi_defaults => var_list_set_mpi_defaults +<>= + module subroutine var_list_set_mpi_defaults (var_list) + class(var_list_t), intent(inout) :: var_list + end subroutine var_list_set_mpi_defaults <>= - subroutine var_list_set_mpi_defaults (var_list) + module subroutine var_list_set_mpi_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_log (var_str ("?mpi_logging"), & .false., intrinsic=.true., & description=var_str('This logical -- when set to \ttt{false} ' // & '-- suppresses writing out messages about MPI parallelization ' // & '(number of used workers etc.) on screen and into the logfile ' // & '(default name \ttt{whizard.log}) for the whole \whizard\ run. ' // & 'Mainly for debugging purposes. (cf. also \ttt{?logging}, ' // & '\ttt{?openmp\_logging})')) end subroutine var_list_set_mpi_defaults @ %def var_list_set_mpi_defaults @ <>= procedure :: set_nlo_defaults => var_list_set_nlo_defaults +<>= + module subroutine var_list_set_nlo_defaults (var_list) + class(var_list_t), intent(inout) :: var_list + end subroutine var_list_set_nlo_defaults <>= - subroutine var_list_set_nlo_defaults (var_list) + module subroutine var_list_set_nlo_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_string (var_str ("$born_me_method"), & var_str (""), intrinsic = .true., & description=var_str ("This string variable specifies the method " // & "for the matrix elements to be used in the evaluation of the " // & "Born part of the NLO computation. The default is the empty string, " // & "i.e. the \ttt{\$method} being the intrinsic \oMega\ matrix element " // & 'generator (\ttt{"omega"}), other options ' // & 'are: \ttt{"ovm"}, \ttt{"unit\_test"}, \ttt{"template"}, ' // & '\ttt{"template\_unity"}, \ttt{"threshold"}, \ttt{"gosam"}, ' // & '\ttt{"openloops"}. Note that this option is inoperative if ' // & 'no NLO calculation is specified in the process definition. ' // & 'If you want ot use different matrix element methods in a LO ' // & 'computation, use the usual \ttt{method} command. (cf. also ' // & '\ttt{\$correlation\_me\_method}, ' // & '\ttt{\$dglap\_me\_method}, \ttt{\$loop\_me\_method} and ' // & '\ttt{\$real\_tree\_me\_method}.)')) call var_list%append_string (var_str ("$loop_me_method"), & var_str (""), intrinsic = .true., & description=var_str ('This string variable specifies the method ' // & 'for the matrix elements to be used in the evaluation of the ' // & 'virtual part of the NLO computation. The default is the empty string, ' // & 'i.e. the same as \ttt{\$method}. Working options are: ' // & '\ttt{"threshold"}, \ttt{"openloops"}, \ttt{"recola"}, \ttt{"gosam"}. ' // & '(cf. also \ttt{\$real\_tree\_me\_method}, \ttt{\$correlation\_me\_method} ' // & 'and \ttt{\$born\_me\_method}.)')) call var_list%append_string (var_str ("$correlation_me_method"), & var_str (""), intrinsic = .true., & description=var_str ('This string variable specifies ' // & 'the method for the matrix elements to be used in the evaluation ' // & 'of the color (and helicity) correlated part of the NLO computation. ' // & "The default is the same as the \ttt{\$method}, i.e. the intrinsic " // & "\oMega\ matrix element generator " // & '(\ttt{"omega"}), other options are: \ttt{"ovm"}, \ttt{"unit\_test"}, ' // & '\ttt{"template"}, \ttt{"template\_unity"}, \ttt{"threshold"}, ' // & '\ttt{"gosam"}, \ttt{"openloops"}. (cf. also ' // & '\ttt{\$born\_me\_method}, \ttt{\$dglap\_me\_method}, ' // & '\ttt{\$loop\_me\_method} and \newline' // & '\ttt{\$real\_tree\_me\_method}.)')) call var_list%append_string (var_str ("$real_tree_me_method"), & var_str (""), intrinsic = .true., & description=var_str ('This string variable specifies the method ' // & 'for the matrix elements to be used in the evaluation of the ' // & 'real part of the NLO computation. The default is the same as ' // & 'the \ttt{\$method}, i.e. the intrinsic ' // & "\oMega\ matrix element generator " // & '(\ttt{"omega"}), other options ' // & 'are: \ttt{"ovm"}, \ttt{"unit\_test"}, \ttt{"template"}, \ttt{"template\_unity"}, ' // & '\ttt{"threshold"}, \ttt{"gosam"}, \ttt{"openloops"}. (cf. also ' // & '\ttt{\$born\_me\_method}, \ttt{\$correlation\_me\_method}, ' // & '\ttt{\$dglap\_me\_method} and \ttt{\$loop\_me\_method}.)')) call var_list%append_string (var_str ("$dglap_me_method"), & var_str (""), intrinsic = .true., & description=var_str ('This string variable specifies the method ' // & 'for the matrix elements to be used in the evaluation of the ' // & 'DGLAP remnants of the NLO computation. The default is the same as ' // & "\ttt{\$method}, i.e. the \oMega\ matrix element generator " // & '(\ttt{"omega"}), other options ' // & 'are: \ttt{"ovm"}, \ttt{"unit\_test"}, \ttt{"template"}, \ttt{"template\_unity"}, ' // & '\ttt{"threshold"}, \ttt{"gosam"}, \ttt{"openloops"}. (cf. also \newline' // & '\ttt{\$born\_me\_method}, \ttt{\$correlation\_me\_method}, ' // & '\ttt{\$loop\_me\_method} and \ttt{\$real\_tree\_me\_method}.)')) call var_list%append_log (& var_str ("?test_soft_limit"), .false., intrinsic = .true., & description=var_str ('Sets the fixed values $\tilde{\xi} = 0.00001$ ' // & 'and $y = 0.5$ as radiation variables. This way, only soft, ' // & 'but non-collinear phase space points are generated, which allows ' // & 'for testing subtraction in this region.')) call var_list%append_log (& var_str ("?test_coll_limit"), .false., intrinsic = .true., & description=var_str ('Sets the fixed values $\tilde{\xi} = 0.5$ ' // & 'and $y = 0.9999999$ as radiation variables. This way, only collinear, ' // & 'but non-soft phase space points are generated, which allows ' // & 'for testing subtraction in this region. Can be combined with ' // & '\ttt{?test\_soft\_limit} to probe soft-collinear regions.')) call var_list%append_log (& var_str ("?test_anti_coll_limit"), .false., intrinsic = .true., & description=var_str ('Sets the fixed values $\tilde{\xi} = 0.5$ ' // & 'and $y = -0.9999999$ as radiation variables. This way, only anti-collinear, ' // & 'but non-soft phase space points are generated, which allows ' // & 'for testing subtraction in this region. Can be combined with ' // & '\ttt{?test\_soft\_limit} to probe soft-collinear regions.')) call var_list%append_string (var_str ("$select_alpha_regions"), & var_str (""), intrinsic = .true., & description=var_str ('Fixes the $\alpha_r$ in the real ' // & ' subtraction component. Allows for testing in one individual ' // & 'singular region.')) call var_list%append_string (var_str ("$virtual_selection"), & var_str ("Full"), intrinsic = .true., & description=var_str ('String variable to select either the full ' // & 'or only parts of the virtual components of an NLO calculation. ' // & 'Possible modes are \ttt{"Full"}, \ttt{"OLP"} and ' // & '\ttt{"Subtraction."}. Mainly for debugging purposes.')) call var_list%append_log (var_str ("?virtual_collinear_resonance_aware"), & .true., intrinsic = .true., & description=var_str ('This flag allows to switch between two ' // & 'different implementations of the collinear subtraction in the ' // & 'resonance-aware FKS setup.')) call var_list%append_real (& var_str ("blha_top_yukawa"), -1._default, intrinsic = .true., & description=var_str ('If this value is set, the given value will ' // & 'be used as the top Yukawa coupling instead of the top mass. ' // & 'Note that having different values for $y_t$ and $m_t$ must be ' // & 'supported by your OLP-library and yield errors if this is not the case.')) call var_list%append_string (var_str ("$blha_ew_scheme"), & var_str ("alpha_internal"), intrinsic = .true., & description=var_str ('String variable that transfers the electroweak ' // & 'renormalization scheme via BLHA to the one-loop provider. Possible ' // & 'values are \ttt{GF} or \ttt{Gmu} for the $G_\mu$ scheme, ' // & '\ttt{alpha\_internal} (default, $G_\mu$ scheme, but value of ' // & '$\alpha_S$ calculated internally by \whizard), \ttt{alpha\_mz} ' // & 'and \ttt{alpha\_0} (or \ttt{alpha\_thompson}) for different schemes ' // & 'with $\alpha$ as input.')) call var_list%append_int (var_str ("openloops_verbosity"), 1, & intrinsic = .true., & description=var_str ('Decides how much \openloops\ output is printed. ' // & 'Can have values 0, 1 and 2, where 2 is the highest verbosity level.')) call var_list%append_log (var_str ("?openloops_use_cms"), & .true., intrinsic = .true., & description=var_str ('Activates the complex mass scheme in ' // & '\openloops. (cf. also ' // & '\ttt{openloos\_verbosity}, \ttt{\$method}, ' // & '\ttt{?openloops\_switch\_off\_muon\_yukawa}, ' // & '\ttt{openloops\_stability\_log}, \newline' // & '\ttt{\$openloops\_extra\_cmd})')) call var_list%append_int (var_str ("openloops_phs_tolerance"), 7, & intrinsic = .true., & description=var_str ('This integer parameter gives via ' // & '\ttt{openloops\_phs\_tolerance = } the relative numerical ' // & 'tolerance $10^{-n}$ for the momentum conservation of the ' // & 'external particles within \openloops. (cf. also ' // & '\ttt{openloos\_verbosity}, \ttt{\$method}, ' // & '\ttt{?openloops\_switch\_off\_muon\_yukawa}, ' // & '\newline\ttt{openloops\_stability\_log}, ' // & '\ttt{\$openloops\_extra\_cmd})')) call var_list%append_int (var_str ("openloops_stability_log"), 0, & intrinsic = .true., & description=var_str ('Creates the directory \ttt{stability\_log} ' // & 'containing information about the performance of the \openloops ' // & 'matrix elements. Possible values are 0 (No output), 1 (On ' // & '\ttt{finish()}-call), 2 (Adaptive) and 3 (Always).')) call var_list%append_log (var_str ("?openloops_switch_off_muon_yukawa"), & .false., intrinsic = .true., & description=var_str ('Sets the Yukawa coupling of muons for ' // & '\openloops\ to zero. (cf. also ' // & '\ttt{openloos\_verbosity}, \ttt{\$method}, ' // & '\ttt{?openloops\_use\_cms}, \ttt{openloops\_stability\_log}, ' // & '\ttt{\$openloops\_extra\_cmd})')) call var_list%append_string (var_str ("$openloops_extra_cmd"), & var_str (""), intrinsic = .true., & description=var_str ('String variable to transfer customized ' // & 'special commands to \openloops. The three supported examples ' // & '\ttt{\$openloops\_extra\_command = "extra approx top/stop/not"} ' // & 'are for selection of subdiagrams in top production. (cf. also ' // & '\ttt{\$method}, \ttt{openloos\_verbosity}, ' // & '\ttt{?openloops\_use\_cms}, \ttt{openloops\_stability\_log}, ' // & '\ttt{?openloops\_switch\_off\_muon\_yukawa})')) call var_list%append_real (var_str ("ellis_sexton_scale"), & -1._default, intrinsic = .true., & description = var_str ('Real positive paramter for the Ellis-Sexton scale' // & '$\mathcal{Q}$ used both in the finite one-loop contribution provided by' // & 'the OLP and in the virtual counter terms. The NLO cross section is' // & 'independent of $\mathcal{Q}$. Therefore, this allows for debugging of' // & 'the implemention of the virtual counter terms. As the default' // & '$\mathcal{Q} = \mu_{\rm{R}}$ is chosen. So far, setting this parameter' // & 'only works for OpenLoops2, otherwise the default behaviour is invoked.')) call var_list%append_log (var_str ("?disable_subtraction"), & .false., intrinsic = .true., & description=var_str ('Disables the subtraction of soft and collinear ' // & 'divergences from the real matrix element.')) call var_list%append_real (var_str ("fks_dij_exp1"), & 1._default, intrinsic = .true., & description=var_str ('Fine-tuning parameters of the FKS ' // & 'final state partition functions. The exact meaning depends ' // & 'on the mapping implementation. (cf. also \ttt{fks\_dij\_exp2}, ' // & '\ttt{\$fks\_mapping\_type}, \ttt{fks\_xi\_min}, \ttt{fks\_y\_max})')) call var_list%append_real (var_str ("fks_dij_exp2"), & 1._default, intrinsic = .true., & description=var_str ('Fine-tuning parameters of the FKS ' // & 'initial state partition functions. The exact meaning depends ' // & 'on the mapping implementation. (cf. also \ttt{fks\_dij\_exp1}, ' // & '\ttt{\$fks\_mapping\_type}, \ttt{fks\_xi\_min}, \ttt{fks\_y\_max})')) call var_list%append_real (var_str ("fks_xi_min"), & 0._default, intrinsic = .true., & description=var_str ('Real parameter for the FKS ' // & 'phase space that sets the numerical lower value of the $\xi$ ' // & 'variable. Valid for the value range $[\texttt{tiny\_07},1]$, where ' // & 'value inputs out of bounds will take the value of the closest bound. ' // & 'Here, $\texttt{tiny\_07} = \texttt{1E0\_default * epsilon (0.\_default)}$, where ' // & '\ttt{epsilon} is an intrinsic Fortran function. (cf. also \ttt{fks\_dij\_exp1}, ' // & '\ttt{fks\_dij\_exp2}, \ttt{\$fks\_mapping\_type}, \ttt{fks\_y\_max})')) call var_list%append_real (var_str ("fks_y_max"), & 1._default, intrinsic = .true., & description=var_str ('Real parameter for the FKS ' // & 'phase space that sets the numerical upper value of the $\left|y\right|$ ' // & 'variable. Valid for ranges $[0,1]$, where value inputs out of bounds will take ' // & 'the value of the closest bound. Only supported for massless FSR. ' // & '(cf. also \ttt{fks\_dij\_exp1}, \ttt{\$fks\_mapping\_type}, \ttt{fks\_dij\_exp2})')) call var_list%append_log (var_str ("?vis_fks_regions"), & .false., intrinsic = .true., & description=var_str ('Logical variable that, if set to ' // & '\ttt{true}, generates \LaTeX\ code and executes it into a PDF ' // & ' to produce a table of all singular FKS regions and their ' // & ' flavor structures. The default is \ttt{false}.')) call var_list%append_real (var_str ("fks_xi_cut"), & 1.0_default, intrinsic = .true., & description = var_str ('(Experimental) Real parameter for the FKS ' // & 'phase space that applies a cut to $\xi$ variable with $0 < \xi_{\text{cut}}' // & '\leq \xi_{\text{max}}$. The dependence on the parameter vanishes between ' // & 'real subtraction and integrated subtraction term. Could thus be used for debugging. ' // & 'This is not implemented properly, use at your own risk!')) call var_list%append_real (var_str ("fks_delta_o"), & 2._default, intrinsic = .true., & description = var_str ('Real parameter for the FKS ' // & 'phase space that applies a cut to the $y$ variable with $0 < \delta_o \leq 2$ ' // & 'for final state singularities only. ' // & 'The dependence on the parameter vanishes between real subtraction and integrated ' // & 'subtraction term. For debugging purposes.')) call var_list%append_real (var_str ("fks_delta_i"), & 2._default, intrinsic = .true., & description = var_str ('Real parameter for the FKS ' // & 'phase space that applies a cut to the $y$ variable with ' // & '$0 < \delta_{\mathrm{I}} \leq 2$ '// & 'for initial state singularities only. ' // & 'The dependence on the parameter vanishes between real subtraction and integrated ' // & 'subtraction term. For debugging purposes.')) call var_list%append_string (var_str ("$fks_mapping_type"), & var_str ("default"), intrinsic = .true., & description=var_str ('Sets the FKS mapping type. Possible values ' // & 'are \ttt{"default"} and \ttt{"resonances"}. The latter option ' // & 'activates the resonance-aware subtraction mode and induces the ' // & 'generation of a soft mismatch component. (cf. also ' // & '\ttt{fks\_dij\_exp1}, \ttt{fks\_dij\_exp2}, \ttt{fks\_xi\_min}, ' // & '\ttt{fks\_y\_max})')) call var_list%append_string (var_str ("$resonances_exclude_particles"), & var_str ("default"), intrinsic = .true., & description=var_str ('Accepts a string of particle names. These ' // & 'particles will be ignored when the resonance histories are generated. ' // & 'If \ttt{\$fks\_mapping\_type} is not \ttt{"resonances"}, this ' // & 'option does nothing.')) call var_list%append_int (var_str ("alpha_power"), & 2, intrinsic = .true., & description=var_str ('Fixes the electroweak coupling ' // & 'powers used by BLHA matrix element generators. Setting these ' // & 'values is necessary for the correct generation of OLP-files. ' // & 'Having inconsistent values yields to error messages by the corresponding ' // & 'OLP-providers.')) call var_list%append_int (var_str ("alphas_power"), & 0, intrinsic = .true., & description=var_str ('Fixes the strong coupling ' // & 'powers used by BLHA matrix element generators. Setting these ' // & 'values is necessary for the correct generation of OLP-files. ' // & 'Having inconsistent values yields to error messages by the corresponding ' // & 'OLP-providers.')) call var_list%append_log (var_str ("?combined_nlo_integration"), & .false., intrinsic = .true., & description=var_str ('When this option is set to \ttt{true}, ' // & 'the NLO integration will not be performed in the separate components, ' // & 'but instead the sum of all components will be integrated directly. ' // & 'When fixed-order NLO events are requested, this integration ' // & 'mode is possible, but not necessary. However, it is necessary ' // & 'for POWHEG events.')) call var_list%append_log (var_str ("?fixed_order_nlo_events"), & .false., intrinsic = .true., & description=var_str ('Induces the generation of fixed-order ' // & 'NLO events.')) call var_list%append_log (var_str ("?check_event_weights_against_xsection"), & .false., intrinsic = .true., & description=var_str ('Activates an internal recording of event ' // & 'weights when unweighted events are generated. At the end of ' // & 'the simulation, the mean value of the weights and its standard ' // & 'deviation are displayed. This allows to cross-check event generation ' // & 'and integration, because the value displayed must be equal to ' // & 'the integration result.')) call var_list%append_log (var_str ("?keep_failed_events"), & .false., intrinsic = .true., & description=var_str ('In the context of weighted event generation, ' // & 'if set to \ttt{true}, events with failed kinematics will be ' // & 'written to the event output with an associated weight of zero. ' // & 'This way, the total cross section can be reconstructed from the event output.')) call var_list%append_int (var_str ("gks_multiplicity"), & 0, intrinsic = .true., & description=var_str ('Jet multiplicity for the GKS merging scheme.')) call var_list%append_string (var_str ("$gosam_filter_lo"), & var_str (""), intrinsic = .true., & description=var_str ('The filter string given to \gosam\ in order to ' // & 'filter out tree-level diagrams. (cf. also \ttt{\$gosam\_filter\_nlo}, ' // & '\ttt{\$gosam\_symmetries})')) call var_list%append_string (var_str ("$gosam_filter_nlo"), & var_str (""), intrinsic = .true., & description=var_str ('The same as \ttt{\$gosam\_filter\_lo}, but for ' // & 'loop matrix elements. (cf. also \ttt{\$gosam\_filter\_nlo}, ' // & '\ttt{\$gosam\_symmetries})')) call var_list%append_string (var_str ("$gosam_symmetries"), & var_str ("family,generation"), intrinsic = .true., & description=var_str ('String variable that is transferred to \gosam\ ' // & 'configuration file to determine whether certain helicity configurations ' // & 'are considered to be equal. Possible values are \ttt{flavour}, ' // & '\ttt{family} etc. For more info see the \gosam\ manual.')) call var_list%append_int (var_str ("form_threads"), & 2, intrinsic = .true., & description=var_str ('The number of threads used by \gosam\ when ' // & 'matrix elements are evaluated using \ttt{FORM}')) call var_list%append_int (var_str ("form_workspace"), & 1000, intrinsic = .true., & description=var_str ('The size of the workspace \gosam\ requires ' // & 'from \ttt{FORM}. Inside \ttt{FORM}, it corresponds to the heap ' // & 'size used by the algebra processor.')) call var_list%append_string (var_str ("$gosam_fc"), & var_str (""), intrinsic = .true., & description=var_str ('The Fortran compiler used by \gosam.')) call var_list%append_real (& var_str ("mult_call_real"), 1._default, & intrinsic = .true., & description=var_str ('(Real-valued) multiplier for the number ' // & 'of calls used in the integration of the real subtraction ' // & 'NLO component. This way, a higher accuracy can be achieved for ' // & 'the real component, while simultaneously avoiding redundant ' // & 'integration calls for the other components. (cf. also ' // & '\ttt{mult\_call\_dglap}, \ttt{mult\_call\_virt})')) call var_list%append_real (& var_str ("mult_call_virt"), 1._default, & intrinsic = .true., & description=var_str ('(Real-valued) multiplier for the number ' // & 'of calls used in the integration of the virtual NLO ' // & 'component. This way, a higher accuracy can be achieved for ' // & 'this component, while simultaneously avoiding redundant ' // & 'integration calls for the other components. (cf. also ' // & '\ttt{mult\_call\_dglap}, \ttt{mult\_call\_real})')) call var_list%append_real (& var_str ("mult_call_dglap"), 1._default, & intrinsic = .true., & description=var_str ('(Real-valued) multiplier for the number ' // & 'of calls used in the integration of the DGLAP remnant NLO ' // & 'component. This way, a higher accuracy can be achieved for ' // & 'this component, while simultaneously avoiding redundant ' // & 'integration calls for the other components. (cf. also ' // & '\ttt{mult\_call\_real}, \ttt{mult\_call\_virt})')) call var_list%append_string (var_str ("$dalitz_plot"), & var_str (''), intrinsic = .true., & description=var_str ('This string variable has two purposes: ' // & 'when different from the empty string, it switches on generation ' // & 'of the Dalitz plot file (ASCII tables) for the real emitters. ' // & 'The string variable itself provides the file name.')) call var_list%append_string (var_str ("$nlo_correction_type"), & var_str ("QCD"), intrinsic = .true., & description=var_str ('String variable which sets the NLO correction ' // & 'type via \ttt{nlo\_correction\_type = "{\em }"} to either ' // & '\ttt{"QCD"}, \ttt{"EW"}, or to all with \ttt{\em{}} ' // & 'set to \ttt{"Full"}. Must be set before the \texttt{process} statement.')) call var_list%append_string (var_str ("$exclude_gauge_splittings"), & var_str ("c:b:t:e2:e3"), intrinsic = .true., & description=var_str ('String variable that allows via ' // & '\ttt{\$exclude\_gauge\_splittings = "{\em ::\dots}"} ' // & 'to exclude fermion flavors from gluon/photon splitting into ' // & 'fermion pairs beyond LO. For example \ttt{\$exclude\_gauge\_splittings ' // & '= "c:s:b:t"} would lead to \ttt{gl => u U} and \ttt{gl => d ' // & 'D} as possible splittings in QCD. It is important to keep in ' // & 'mind that only the particles listed in the string are excluded! ' // & 'In QED this string would additionally allow for all splittings into ' // & 'lepton pairs \ttt{A => l L}. Therefore, once set the variable ' // & 'acts as a replacement of the default value, not as an addition! ' // & 'Note: \ttt{"\em "} can be both particle or antiparticle. It ' // & 'will always exclude the corresponding fermion pair. An empty ' // & 'string allows for all fermion flavors to take part in the splitting! ' // & 'Also, particles included in an \ttt{alias} are not excluded by ' // & '\ttt{\$exclude\_gauge\_splittings}!')) call var_list%append_log (var_str ("?nlo_use_born_scale"), & .false., intrinsic = .true., & description=var_str ('Flag that decides whether a scale expression ' // & 'defined for the Born component of an NLO process shall be applied ' // & 'to all other components as well or not. ' // & '(cf. also \ttt{?nlo\_cut\_all\_real\_sqmes})')) call var_list%append_log (var_str ("?nlo_cut_all_real_sqmes"), & .false., intrinsic = .true., & description=var_str ('Flag that decides whether in the case that ' // & 'the real component does not pass a cut, its subtraction term ' // & 'shall be discarded for that phase space point as well or not. ' // & '(cf. also \ttt{?nlo\_use\_born\_scale})')) call var_list%append_string (var_str ("$real_partition_mode"), var_str ("default"), & intrinsic=.true., & description=var_str ('String variable to choose which parts of the real cross ' // & 'section are to be integrated. With the default value (\ttt{"default"}) ' // & 'or \ttt{"off"} the real cross section is integrated as usual without partition. ' // & 'If set to \ttt{"on"} or \ttt{"all"}, the real cross section is split into singular ' // & 'and finite part using a partition function $F$, such that $\mathcal{R} ' // & '= [1-F(p_T^2)]\mathcal{R} + F(p_T^2)\mathcal{R} = \mathcal{R}_{\text{fin}} ' // & '+ \mathcal{R}_{\text{sing}}$. The emission generation is then performed ' // & 'using $\mathcal{R}_{\text{sing}}$, whereas $\mathcal{R}_{\text{fin}}$ ' // & 'is treated separately. If set to \ttt{"singular"} (\ttt{"finite"}), ' // & 'only the singular (finite) real component is integrated.' // & '(cf. also \ttt{real\_partition\_scale})')) call var_list%append_real (var_str ("real_partition_scale"), & 10._default, intrinsic = .true., & description=var_str ('This real variable sets the invariant mass ' // & 'of the FKS pair used as a separator between the singular and the ' // & 'finite part of the real subtraction terms in an NLO calculation, ' // & 'e.g. in $e^+e^- \to t\bar tj$. (cf. also \ttt{\$real\_partition\_mode})')) call var_list%append_log (var_str ("?nlo_reuse_amplitudes_fks"), & .false., intrinsic = .true., & description=var_str ('Only compute real and virtual amplitudes for ' // & 'subprocesses that give a different amplitude and reuse the result ' // & 'for equivalent subprocesses. ' // & 'Might give a speed-up for some processes. Might ' // & 'break others, especially in cases where resonance histories are needed. ' // & 'Experimental feature, use at your own risk!')) end subroutine var_list_set_nlo_defaults @ %def var_list_set_nlo_defaults @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Observables} In this module we define concrete variables and operators (observables) that we want to support in expressions. <<[[observables.f90]]>>= <> module observables <> <> - use io_units - use diagnostics - use lorentz use subevents use variables <> <> -contains - -<> + interface +<> + end interface end module observables @ %def observables @ -\subsection{Process-specific variables} -We allow the user to set a numeric process ID for each declared process. -<>= - public :: var_list_init_num_id -<>= - subroutine var_list_init_num_id (var_list, proc_id, num_id) - type(var_list_t), intent(inout) :: var_list - type(string_t), intent(in) :: proc_id - integer, intent(in), optional :: num_id - call var_list_set_procvar_int (var_list, proc_id, & - var_str ("num_id"), num_id) - end subroutine var_list_init_num_id - -@ %def var_list_init_num_id -@ -Integration results are stored in special variables. They are -initialized by this subroutine. The values may or may not already -known. - -Note: the values which are accessible are those that are unique for a -process with multiple MCI records. The rest has been discarded. -<>= - public :: var_list_init_process_results -<>= - subroutine var_list_init_process_results (var_list, proc_id, & - n_calls, integral, error, accuracy, chi2, efficiency) - type(var_list_t), intent(inout) :: var_list - type(string_t), intent(in) :: proc_id - integer, intent(in), optional :: n_calls - real(default), intent(in), optional :: integral, error, accuracy - real(default), intent(in), optional :: chi2, efficiency - call var_list_set_procvar_real (var_list, proc_id, & - var_str ("integral"), integral) - call var_list_set_procvar_real (var_list, proc_id, & - var_str ("error"), error) - end subroutine var_list_init_process_results - -@ %def var_list_init_process_results -@ -\subsection{Observables as Pseudo-Variables} -Unary and binary observables are different. Most unary observables -can be equally well evaluated for particle pairs. Binary observables -cannot be evaluated for single particles. -<>= - public :: var_list_set_observables_unary - public :: var_list_set_observables_binary - public :: var_list_set_observables_sev -<>= - subroutine var_list_set_observables_unary (var_list, prt1) - type(var_list_t), intent(inout) :: var_list - type(prt_t), intent(in), target :: prt1 - call var_list_append_obs1_iptr & - (var_list, var_str ("PDG"), obs_pdg1, prt1) - call var_list_append_obs1_iptr & - (var_list, var_str ("Hel"), obs_helicity1, prt1) - call var_list_append_obs1_iptr & - (var_list, var_str ("Ncol"), obs_n_col1, prt1) - call var_list_append_obs1_iptr & - (var_list, var_str ("Nacl"), obs_n_acl1, prt1) - call var_list_append_obs1_rptr & - (var_list, var_str ("M"), obs_signed_mass1, prt1) - call var_list_append_obs1_rptr & - (var_list, var_str ("M2"), obs_mass_squared1, prt1) - call var_list_append_obs1_rptr & - (var_list, var_str ("E"), obs_energy1, prt1) - call var_list_append_obs1_rptr & - (var_list, var_str ("Px"), obs_px1, prt1) - call var_list_append_obs1_rptr & - (var_list, var_str ("Py"), obs_py1, prt1) - call var_list_append_obs1_rptr & - (var_list, var_str ("Pz"), obs_pz1, prt1) - call var_list_append_obs1_rptr & - (var_list, var_str ("P"), obs_p1, prt1) - call var_list_append_obs1_rptr & - (var_list, var_str ("Pl"), obs_pl1, prt1) - call var_list_append_obs1_rptr & - (var_list, var_str ("Pt"), obs_pt1, prt1) - call var_list_append_obs1_rptr & - (var_list, var_str ("Theta"), obs_theta1, prt1) - call var_list_append_obs1_rptr & - (var_list, var_str ("Phi"), obs_phi1, prt1) - call var_list_append_obs1_rptr & - (var_list, var_str ("Rap"), obs_rap1, prt1) - call var_list_append_obs1_rptr & - (var_list, var_str ("Eta"), obs_eta1, prt1) - call var_list_append_obs1_rptr & - (var_list, var_str ("Theta_star"), obs_theta_star1, prt1) - call var_list_append_obs1_rptr & - (var_list, var_str ("Dist"), obs_dist1, prt1) - call var_list_append_uobs_real & - (var_list, var_str ("_User_obs_real"), prt1) - call var_list_append_uobs_int & - (var_list, var_str ("_User_obs_int"), prt1) - end subroutine var_list_set_observables_unary - - subroutine var_list_set_observables_binary (var_list, prt1, prt2) - type(var_list_t), intent(inout) :: var_list - type(prt_t), intent(in), target :: prt1 - type(prt_t), intent(in), optional, target :: prt2 - call var_list_append_obs2_iptr & - (var_list, var_str ("PDG"), obs_pdg2, prt1, prt2) - call var_list_append_obs2_iptr & - (var_list, var_str ("Hel"), obs_helicity2, prt1, prt2) - call var_list_append_obs2_iptr & - (var_list, var_str ("Ncol"), obs_n_col2, prt1, prt2) - call var_list_append_obs2_iptr & - (var_list, var_str ("Nacl"), obs_n_acl2, prt1, prt2) - call var_list_append_obs2_rptr & - (var_list, var_str ("M"), obs_signed_mass2, prt1, prt2) - call var_list_append_obs2_rptr & - (var_list, var_str ("M2"), obs_mass_squared2, prt1, prt2) - call var_list_append_obs2_rptr & - (var_list, var_str ("E"), obs_energy2, prt1, prt2) - call var_list_append_obs2_rptr & - (var_list, var_str ("Px"), obs_px2, prt1, prt2) - call var_list_append_obs2_rptr & - (var_list, var_str ("Py"), obs_py2, prt1, prt2) - call var_list_append_obs2_rptr & - (var_list, var_str ("Pz"), obs_pz2, prt1, prt2) - call var_list_append_obs2_rptr & - (var_list, var_str ("P"), obs_p2, prt1, prt2) - call var_list_append_obs2_rptr & - (var_list, var_str ("Pl"), obs_pl2, prt1, prt2) - call var_list_append_obs2_rptr & - (var_list, var_str ("Pt"), obs_pt2, prt1, prt2) - call var_list_append_obs2_rptr & - (var_list, var_str ("Theta"), obs_theta2, prt1, prt2) - call var_list_append_obs2_rptr & - (var_list, var_str ("Phi"), obs_phi2, prt1, prt2) - call var_list_append_obs2_rptr & - (var_list, var_str ("Rap"), obs_rap2, prt1, prt2) - call var_list_append_obs2_rptr & - (var_list, var_str ("Eta"), obs_eta2, prt1, prt2) - call var_list_append_obs2_rptr & - (var_list, var_str ("Theta_star"), obs_theta_star2, prt1, prt2) - call var_list_append_obs2_rptr & - (var_list, var_str ("Dist"), obs_dist2, prt1, prt2) - call var_list_append_obs2_rptr & - (var_list, var_str ("kT"), obs_ktmeasure, prt1, prt2) - call var_list_append_uobs_real & - (var_list, var_str ("_User_obs_real"), prt1, prt2) - call var_list_append_uobs_int & - (var_list, var_str ("_User_obs_int"), prt1, prt2) - end subroutine var_list_set_observables_binary +<<[[observables_sub.f90]]>>= +<> - subroutine var_list_set_observables_sev (var_list, pval) - type(var_list_t), intent(inout) :: var_list - type(subevt_t), intent(in), target:: pval - call var_list_append_obsev_rptr & - (var_list, var_str ("Ht"), obs_ht, pval) - end subroutine var_list_set_observables_sev +submodule (observables) observables_s -@ %def var_list_set_observables_unary var_list_set_observables_binary -@ %def var_list_set_observables_nary -\subsection{Checks} -<>= - public :: var_list_check_observable -<>= - subroutine var_list_check_observable (var_list, name, type) - class(var_list_t), intent(in), target :: var_list - type(string_t), intent(in) :: name - integer, intent(inout) :: type - if (string_is_observable_id (name)) then - call msg_fatal ("Variable name '" // char (name) & - // "' is reserved for an observable") - type = V_NONE - return - end if - end subroutine var_list_check_observable - -@ %def var_list_check_observable -@ -Check if a variable name is defined as an observable: -<>= - function string_is_observable_id (string) result (flag) - logical :: flag - type(string_t), intent(in) :: string - select case (char (string)) - case ("PDG", "Hel", "Ncol", "Nacl", & - "M", "M2", "E", "Px", "Py", "Pz", "P", "Pl", "Pt", & - "Theta", "Phi", "Rap", "Eta", "Theta_star", "Dist", "kT", & - "Ht") - flag = .true. - case default - flag = .false. - end select - end function string_is_observable_id + use io_units + use diagnostics + use lorentz -@ %def string_is_observable_id -@ Check for result and process variables. -<>= - public :: var_list_check_result_var -<>= - subroutine var_list_check_result_var (var_list, name, type) - class(var_list_t), intent(in), target :: var_list - type(string_t), intent(in) :: name - integer, intent(inout) :: type - if (string_is_integer_result_var (name)) type = V_INT - if (.not. var_list%contains (name)) then - if (string_is_result_var (name)) then - call msg_fatal ("Result variable '" // char (name) // "' " & - // "set without prior integration") - type = V_NONE - return - else if (string_is_num_id (name)) then - call msg_fatal ("Numeric process ID '" // char (name) // "' " & - // "set without process declaration") - type = V_NONE - return - end if - end if - end subroutine var_list_check_result_var + implicit none -@ %def var_list_check_result_var -@ -Check if a variable name is a result variable of integer type: -<>= - function string_is_integer_result_var (string) result (flag) - logical :: flag - type(string_t), intent(in) :: string - type(string_t) :: buffer, name, separator - buffer = string - call split (buffer, name, "(", separator=separator) ! ")" - if (separator == "(") then - select case (char (name)) - case ("num_id", "n_calls") - flag = .true. - case default - flag = .false. - end select - else - flag = .false. - end if - end function string_is_integer_result_var +contains -@ %def string_is_integer_result_var -@ -Check if a variable name is an integration-result variable: -<>= - function string_is_result_var (string) result (flag) - logical :: flag - type(string_t), intent(in) :: string - type(string_t) :: buffer, name, separator - buffer = string - call split (buffer, name, "(", separator=separator) ! ")" - if (separator == "(") then - select case (char (name)) - case ("integral", "error") - flag = .true. - case default - flag = .false. - end select - else - flag = .false. - end if - end function string_is_result_var +<> -@ %def string_is_result_var -@ -Check if a variable name is a numeric process ID: -<>= - function string_is_num_id (string) result (flag) - logical :: flag - type(string_t), intent(in) :: string - type(string_t) :: buffer, name, separator - buffer = string - call split (buffer, name, "(", separator=separator) ! ")" - if (separator == "(") then - select case (char (name)) - case ("num_id") - flag = .true. - case default - flag = .false. - end select - else - flag = .false. - end if - end function string_is_num_id +end submodule observables_s -@ %def string_is_num_id +@ %def observables_s @ \subsection{Observables} These are analogous to the unary and binary numeric functions listed above. An observable takes the [[pval]] component(s) of its one or two argument nodes and produces an integer or real value. \subsubsection{Integer-valued unary observables} The PDG code <>= integer function obs_pdg1 (prt1) result (pdg) type(prt_t), intent(in) :: prt1 pdg = prt_get_pdg (prt1) end function obs_pdg1 @ %def obs_pdg @ The helicity. The return value is meaningful only if the particle is polarized, otherwise an invalid value is returned (-9). <>= integer function obs_helicity1 (prt1) result (h) type(prt_t), intent(in) :: prt1 if (prt_is_polarized (prt1)) then h = prt_get_helicity (prt1) else h = -9 end if end function obs_helicity1 @ %def obs_helicity1 @ The number of open color (anticolor) lines. The return value is meaningful only if the particle is colorized (i.e., the subevent has been given color information), otherwise the function returns zero. <>= integer function obs_n_col1 (prt1) result (n) type(prt_t), intent(in) :: prt1 if (prt_is_colorized (prt1)) then n = prt_get_n_col (prt1) else n = 0 end if end function obs_n_col1 integer function obs_n_acl1 (prt1) result (n) type(prt_t), intent(in) :: prt1 if (prt_is_colorized (prt1)) then n = prt_get_n_acl (prt1) else n = 0 end if end function obs_n_acl1 @ %def obs_n_col1 @ %def obs_n_acl1 @ \subsubsection{Real-valued unary observables} The invariant mass squared, obtained from the separately stored value. <>= real(default) function obs_mass_squared1 (prt1) result (p2) type(prt_t), intent(in) :: prt1 p2 = prt_get_msq (prt1) end function obs_mass_squared1 @ %def obs_mass_squared1 @ The signed invariant mass, which is the signed square root of the previous observable. <>= real(default) function obs_signed_mass1 (prt1) result (m) type(prt_t), intent(in) :: prt1 real(default) :: msq msq = prt_get_msq (prt1) m = sign (sqrt (abs (msq)), msq) end function obs_signed_mass1 @ %def obs_signed_mass1 @ The particle energy <>= real(default) function obs_energy1 (prt1) result (e) type(prt_t), intent(in) :: prt1 e = energy (prt_get_momentum (prt1)) end function obs_energy1 @ %def obs_energy1 @ Particle momentum (components) <>= real(default) function obs_px1 (prt1) result (p) type(prt_t), intent(in) :: prt1 p = vector4_get_component (prt_get_momentum (prt1), 1) end function obs_px1 real(default) function obs_py1 (prt1) result (p) type(prt_t), intent(in) :: prt1 p = vector4_get_component (prt_get_momentum (prt1), 2) end function obs_py1 real(default) function obs_pz1 (prt1) result (p) type(prt_t), intent(in) :: prt1 p = vector4_get_component (prt_get_momentum (prt1), 3) end function obs_pz1 real(default) function obs_p1 (prt1) result (p) type(prt_t), intent(in) :: prt1 p = space_part_norm (prt_get_momentum (prt1)) end function obs_p1 real(default) function obs_pl1 (prt1) result (p) type(prt_t), intent(in) :: prt1 p = longitudinal_part (prt_get_momentum (prt1)) end function obs_pl1 real(default) function obs_pt1 (prt1) result (p) type(prt_t), intent(in) :: prt1 p = transverse_part (prt_get_momentum (prt1)) end function obs_pt1 @ %def obs_px1 obs_py1 obs_pz1 @ %def obs_p1 obs_pl1 obs_pt1 @ Polar and azimuthal angle (lab frame). <>= real(default) function obs_theta1 (prt1) result (p) type(prt_t), intent(in) :: prt1 p = polar_angle (prt_get_momentum (prt1)) end function obs_theta1 real(default) function obs_phi1 (prt1) result (p) type(prt_t), intent(in) :: prt1 p = azimuthal_angle (prt_get_momentum (prt1)) end function obs_phi1 @ %def obs_theta1 obs_phi1 @ Rapidity and pseudorapidity <>= real(default) function obs_rap1 (prt1) result (p) type(prt_t), intent(in) :: prt1 p = rapidity (prt_get_momentum (prt1)) end function obs_rap1 real(default) function obs_eta1 (prt1) result (p) type(prt_t), intent(in) :: prt1 p = pseudorapidity (prt_get_momentum (prt1)) end function obs_eta1 @ %def obs_rap1 obs_eta1 @ Meaningless: Polar angle in the rest frame of the two arguments combined. <>= real(default) function obs_theta_star1 (prt1) result (dist) type(prt_t), intent(in) :: prt1 call msg_fatal (" 'Theta_star' is undefined as unary observable") dist = 0 end function obs_theta_star1 @ %def obs_theta_star1 @ [Obsolete] Meaningless: Polar angle in the rest frame of the 2nd argument. <>= real(default) function obs_theta_rf1 (prt1) result (dist) type(prt_t), intent(in) :: prt1 call msg_fatal (" 'Theta_RF' is undefined as unary observable") dist = 0 end function obs_theta_rf1 @ %def obs_theta_rf1 @ Meaningless: Distance on the $\eta$-$\phi$ cylinder. <>= real(default) function obs_dist1 (prt1) result (dist) type(prt_t), intent(in) :: prt1 call msg_fatal (" 'Dist' is undefined as unary observable") dist = 0 end function obs_dist1 @ %def obs_dist1 @ \subsubsection{Integer-valued binary observables} These observables are meaningless as binary functions. <>= integer function obs_pdg2 (prt1, prt2) result (pdg) type(prt_t), intent(in) :: prt1, prt2 call msg_fatal (" PDG_Code is undefined as binary observable") pdg = 0 end function obs_pdg2 integer function obs_helicity2 (prt1, prt2) result (h) type(prt_t), intent(in) :: prt1, prt2 call msg_fatal (" Helicity is undefined as binary observable") h = 0 end function obs_helicity2 integer function obs_n_col2 (prt1, prt2) result (n) type(prt_t), intent(in) :: prt1, prt2 call msg_fatal (" Ncol is undefined as binary observable") n = 0 end function obs_n_col2 integer function obs_n_acl2 (prt1, prt2) result (n) type(prt_t), intent(in) :: prt1, prt2 call msg_fatal (" Nacl is undefined as binary observable") n = 0 end function obs_n_acl2 @ %def obs_pdg2 @ %def obs_helicity2 @ %def obs_n_col2 @ %def obs_n_acl2 @ \subsubsection{Real-valued binary observables} The invariant mass squared, obtained from the separately stored value. <>= real(default) function obs_mass_squared2 (prt1, prt2) result (p2) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt call prt_init_combine (prt, prt1, prt2) p2 = prt_get_msq (prt) end function obs_mass_squared2 @ %def obs_mass_squared2 @ The signed invariant mass, which is the signed square root of the previous observable. <>= real(default) function obs_signed_mass2 (prt1, prt2) result (m) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt real(default) :: msq call prt_init_combine (prt, prt1, prt2) msq = prt_get_msq (prt) m = sign (sqrt (abs (msq)), msq) end function obs_signed_mass2 @ %def obs_signed_mass2 @ The particle energy <>= real(default) function obs_energy2 (prt1, prt2) result (e) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt call prt_init_combine (prt, prt1, prt2) e = energy (prt_get_momentum (prt)) end function obs_energy2 @ %def obs_energy2 @ Particle momentum (components) <>= real(default) function obs_px2 (prt1, prt2) result (p) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt call prt_init_combine (prt, prt1, prt2) p = vector4_get_component (prt_get_momentum (prt), 1) end function obs_px2 real(default) function obs_py2 (prt1, prt2) result (p) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt call prt_init_combine (prt, prt1, prt2) p = vector4_get_component (prt_get_momentum (prt), 2) end function obs_py2 real(default) function obs_pz2 (prt1, prt2) result (p) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt call prt_init_combine (prt, prt1, prt2) p = vector4_get_component (prt_get_momentum (prt), 3) end function obs_pz2 real(default) function obs_p2 (prt1, prt2) result (p) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt call prt_init_combine (prt, prt1, prt2) p = space_part_norm (prt_get_momentum (prt)) end function obs_p2 real(default) function obs_pl2 (prt1, prt2) result (p) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt call prt_init_combine (prt, prt1, prt2) p = longitudinal_part (prt_get_momentum (prt)) end function obs_pl2 real(default) function obs_pt2 (prt1, prt2) result (p) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt call prt_init_combine (prt, prt1, prt2) p = transverse_part (prt_get_momentum (prt)) end function obs_pt2 @ %def obs_px2 obs_py2 obs_pz2 @ %def obs_p2 obs_pl2 obs_pt2 @ Enclosed angle and azimuthal distance (lab frame). <>= real(default) function obs_theta2 (prt1, prt2) result (p) type(prt_t), intent(in) :: prt1, prt2 p = enclosed_angle (prt_get_momentum (prt1), prt_get_momentum (prt2)) end function obs_theta2 real(default) function obs_phi2 (prt1, prt2) result (p) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt call prt_init_combine (prt, prt1, prt2) p = azimuthal_distance (prt_get_momentum (prt1), prt_get_momentum (prt2)) end function obs_phi2 @ %def obs_theta2 obs_phi2 @ Rapidity and pseudorapidity distance <>= real(default) function obs_rap2 (prt1, prt2) result (p) type(prt_t), intent(in) :: prt1, prt2 p = rapidity_distance & (prt_get_momentum (prt1), prt_get_momentum (prt2)) end function obs_rap2 real(default) function obs_eta2 (prt1, prt2) result (p) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt call prt_init_combine (prt, prt1, prt2) p = pseudorapidity_distance & (prt_get_momentum (prt1), prt_get_momentum (prt2)) end function obs_eta2 @ %def obs_rap2 obs_eta2 @ [This doesn't work! The principle of no common particle for momentum combination prohibits us from combining a decay particle with the momentum of its parent.] Polar angle in the rest frame of the 2nd argument. <>= real(default) function obs_theta_rf2 (prt1, prt2) result (theta) type(prt_t), intent(in) :: prt1, prt2 theta = enclosed_angle_rest_frame & (prt_get_momentum (prt1), prt_get_momentum (prt2)) end function obs_theta_rf2 @ %def obs_theta_rf2 @ Polar angle of the first particle in the rest frame of the two particles combined. <>= real(default) function obs_theta_star2 (prt1, prt2) result (theta) type(prt_t), intent(in) :: prt1, prt2 theta = enclosed_angle_rest_frame & (prt_get_momentum (prt1), & prt_get_momentum (prt1) + prt_get_momentum (prt2)) end function obs_theta_star2 @ %def obs_theta_star2 @ Distance on the $\eta$-$\phi$ cylinder. <>= real(default) function obs_dist2 (prt1, prt2) result (dist) type(prt_t), intent(in) :: prt1, prt2 dist = eta_phi_distance & (prt_get_momentum (prt1), prt_get_momentum (prt2)) end function obs_dist2 @ %def obs_dist2 @ Durham kT measure. <>= real(default) function obs_ktmeasure (prt1, prt2) result (kt) type(prt_t), intent(in) :: prt1, prt2 real (default) :: q2, e1, e2 ! Normalized scale to one for now! (#67) q2 = 1 e1 = energy (prt_get_momentum (prt1)) e2 = energy (prt_get_momentum (prt2)) kt = (2/q2) * min(e1**2,e2**2) * & (1 - enclosed_angle_ct(prt_get_momentum (prt1), & prt_get_momentum (prt2))) end function obs_ktmeasure @ %def obs_ktmeasure @ Subeventary observables, e.g. the transverse mass $H_T$. <>= real(default) function obs_ht (sev) result (ht) type(subevt_t), intent(in) :: sev integer :: i, n type(prt_t) :: prt n = sev%get_length () ht = 0 do i = 1, n prt = sev%get_prt (i) ht = ht + & sqrt (obs_pt1(prt)**2 + obs_mass_squared1(prt)) end do end function obs_ht @ %def obs_ht +\subsection{Process-specific variables} +We allow the user to set a numeric process ID for each declared process. +<>= + public :: var_list_init_num_id +<>= + module subroutine var_list_init_num_id (var_list, proc_id, num_id) + type(var_list_t), intent(inout) :: var_list + type(string_t), intent(in) :: proc_id + integer, intent(in), optional :: num_id + end subroutine var_list_init_num_id +<>= + module subroutine var_list_init_num_id (var_list, proc_id, num_id) + type(var_list_t), intent(inout) :: var_list + type(string_t), intent(in) :: proc_id + integer, intent(in), optional :: num_id + call var_list%set_procvar_int (proc_id, var_str ("num_id"), num_id) + end subroutine var_list_init_num_id + +@ %def var_list_init_num_id +@ +Integration results are stored in special variables. They are +initialized by this subroutine. The values may or may not already +known. + +Note: the values which are accessible are those that are unique for a +process with multiple MCI records. The rest has been discarded. +<>= + public :: var_list_init_process_results +<>= + module subroutine var_list_init_process_results (var_list, proc_id, & + n_calls, integral, error, accuracy, chi2, efficiency) + type(var_list_t), intent(inout) :: var_list + type(string_t), intent(in) :: proc_id + integer, intent(in), optional :: n_calls + real(default), intent(in), optional :: integral, error, accuracy + real(default), intent(in), optional :: chi2, efficiency + end subroutine var_list_init_process_results +<>= + module subroutine var_list_init_process_results (var_list, proc_id, & + n_calls, integral, error, accuracy, chi2, efficiency) + type(var_list_t), intent(inout) :: var_list + type(string_t), intent(in) :: proc_id + integer, intent(in), optional :: n_calls + real(default), intent(in), optional :: integral, error, accuracy + real(default), intent(in), optional :: chi2, efficiency + call var_list%set_procvar_real (proc_id, var_str ("integral"), integral) + call var_list%set_procvar_real (proc_id, var_str ("error"), error) + end subroutine var_list_init_process_results + +@ %def var_list_init_process_results +@ +\subsection{Observables as Pseudo-Variables} +Unary and binary observables are different. Most unary observables +can be equally well evaluated for particle pairs. Binary observables +cannot be evaluated for single particles. +<>= + public :: var_list_set_observables_unary + public :: var_list_set_observables_binary + public :: var_list_set_observables_sev +<>= + module subroutine var_list_set_observables_unary (var_list, prt1) + type(var_list_t), intent(inout) :: var_list + type(prt_t), intent(in), target :: prt1 + end subroutine var_list_set_observables_unary + module subroutine var_list_set_observables_binary (var_list, prt1, prt2) + type(var_list_t), intent(inout) :: var_list + type(prt_t), intent(in), target :: prt1 + type(prt_t), intent(in), optional, target :: prt2 + end subroutine var_list_set_observables_binary + module subroutine var_list_set_observables_sev (var_list, pval) + type(var_list_t), intent(inout) :: var_list + type(subevt_t), intent(in), target:: pval + end subroutine var_list_set_observables_sev +<>= + module subroutine var_list_set_observables_unary (var_list, prt1) + type(var_list_t), intent(inout) :: var_list + type(prt_t), intent(in), target :: prt1 + call var_list%append_obs1_iptr (var_str ("PDG"), obs_pdg1, prt1) + call var_list%append_obs1_iptr (var_str ("Hel"), obs_helicity1, prt1) + call var_list%append_obs1_iptr (var_str ("Ncol"), obs_n_col1, prt1) + call var_list%append_obs1_iptr (var_str ("Nacl"), obs_n_acl1, prt1) + call var_list%append_obs1_rptr & + (var_str ("M"), obs_signed_mass1, prt1) + call var_list%append_obs1_rptr & + (var_str ("M2"), obs_mass_squared1, prt1) + call var_list%append_obs1_rptr (var_str ("E"), obs_energy1, prt1) + call var_list%append_obs1_rptr (var_str ("Px"), obs_px1, prt1) + call var_list%append_obs1_rptr (var_str ("Py"), obs_py1, prt1) + call var_list%append_obs1_rptr (var_str ("Pz"), obs_pz1, prt1) + call var_list%append_obs1_rptr (var_str ("P"), obs_p1, prt1) + call var_list%append_obs1_rptr (var_str ("Pl"), obs_pl1, prt1) + call var_list%append_obs1_rptr (var_str ("Pt"), obs_pt1, prt1) + call var_list%append_obs1_rptr (var_str ("Theta"), obs_theta1, prt1) + call var_list%append_obs1_rptr (var_str ("Phi"), obs_phi1, prt1) + call var_list%append_obs1_rptr (var_str ("Rap"), obs_rap1, prt1) + call var_list%append_obs1_rptr (var_str ("Eta"), obs_eta1, prt1) + call var_list%append_obs1_rptr & + (var_str ("Theta_star"), obs_theta_star1, prt1) + call var_list%append_obs1_rptr (var_str ("Dist"), obs_dist1, prt1) + call var_list%append_uobs_real (var_str ("_User_obs_real"), prt1) + call var_list%append_uobs_int (var_str ("_User_obs_int"), prt1) + end subroutine var_list_set_observables_unary + + module subroutine var_list_set_observables_binary (var_list, prt1, prt2) + type(var_list_t), intent(inout) :: var_list + type(prt_t), intent(in), target :: prt1 + type(prt_t), intent(in), optional, target :: prt2 + call var_list%append_obs2_iptr (var_str ("PDG"), obs_pdg2, prt1, prt2) + call var_list%append_obs2_iptr (var_str ("Hel"), obs_helicity2, prt1, prt2) + call var_list%append_obs2_iptr (var_str ("Ncol"), obs_n_col2, prt1, prt2) + call var_list%append_obs2_iptr (var_str ("Nacl"), obs_n_acl2, prt1, prt2) + call var_list%append_obs2_rptr (var_str ("M"), obs_signed_mass2, prt1, prt2) + call var_list%append_obs2_rptr & + (var_str ("M2"), obs_mass_squared2, prt1, prt2) + call var_list%append_obs2_rptr (var_str ("E"), obs_energy2, prt1, prt2) + call var_list%append_obs2_rptr (var_str ("Px"), obs_px2, prt1, prt2) + call var_list%append_obs2_rptr (var_str ("Py"), obs_py2, prt1, prt2) + call var_list%append_obs2_rptr (var_str ("Pz"), obs_pz2, prt1, prt2) + call var_list%append_obs2_rptr (var_str ("P"), obs_p2, prt1, prt2) + call var_list%append_obs2_rptr (var_str ("Pl"), obs_pl2, prt1, prt2) + call var_list%append_obs2_rptr (var_str ("Pt"), obs_pt2, prt1, prt2) + call var_list%append_obs2_rptr (var_str ("Theta"), obs_theta2, prt1, prt2) + call var_list%append_obs2_rptr (var_str ("Phi"), obs_phi2, prt1, prt2) + call var_list%append_obs2_rptr (var_str ("Rap"), obs_rap2, prt1, prt2) + call var_list%append_obs2_rptr (var_str ("Eta"), obs_eta2, prt1, prt2) + call var_list%append_obs2_rptr & + (var_str ("Theta_star"), obs_theta_star2, prt1, prt2) + call var_list%append_obs2_rptr (var_str ("Dist"), obs_dist2, prt1, prt2) + call var_list%append_obs2_rptr (var_str ("kT"), obs_ktmeasure, prt1, prt2) + call var_list%append_uobs_real (var_str ("_User_obs_real"), prt1, prt2) + call var_list%append_uobs_int (var_str ("_User_obs_int"), prt1, prt2) + end subroutine var_list_set_observables_binary + + module subroutine var_list_set_observables_sev (var_list, pval) + type(var_list_t), intent(inout) :: var_list + type(subevt_t), intent(in), target:: pval + call var_list%append_obsev_rptr (var_str ("Ht"), obs_ht, pval) + end subroutine var_list_set_observables_sev + +@ %def var_list_set_observables_unary var_list_set_observables_binary +@ %def var_list_set_observables_nary +\subsection{Checks} +<>= + public :: var_list_check_observable +<>= + module subroutine var_list_check_observable (var_list, name, type) + class(var_list_t), intent(in), target :: var_list + type(string_t), intent(in) :: name + integer, intent(inout) :: type + end subroutine var_list_check_observable +<>= + module subroutine var_list_check_observable (var_list, name, type) + class(var_list_t), intent(in), target :: var_list + type(string_t), intent(in) :: name + integer, intent(inout) :: type + if (string_is_observable_id (name)) then + call msg_fatal ("Variable name '" // char (name) & + // "' is reserved for an observable") + type = V_NONE + return + end if + end subroutine var_list_check_observable + +@ %def var_list_check_observable +@ +Check if a variable name is defined as an observable: +<>= + function string_is_observable_id (string) result (flag) + logical :: flag + type(string_t), intent(in) :: string + select case (char (string)) + case ("PDG", "Hel", "Ncol", "Nacl", & + "M", "M2", "E", "Px", "Py", "Pz", "P", "Pl", "Pt", & + "Theta", "Phi", "Rap", "Eta", "Theta_star", "Dist", "kT", & + "Ht") + flag = .true. + case default + flag = .false. + end select + end function string_is_observable_id + +@ %def string_is_observable_id +@ Check for result and process variables. +<>= + public :: var_list_check_result_var +<>= + module subroutine var_list_check_result_var (var_list, name, type) + class(var_list_t), intent(in), target :: var_list + type(string_t), intent(in) :: name + integer, intent(inout) :: type + end subroutine var_list_check_result_var +<>= + module subroutine var_list_check_result_var (var_list, name, type) + class(var_list_t), intent(in), target :: var_list + type(string_t), intent(in) :: name + integer, intent(inout) :: type + if (string_is_integer_result_var (name)) type = V_INT + if (.not. var_list%contains (name)) then + if (string_is_result_var (name)) then + call msg_fatal ("Result variable '" // char (name) // "' " & + // "set without prior integration") + type = V_NONE + return + else if (string_is_num_id (name)) then + call msg_fatal ("Numeric process ID '" // char (name) // "' " & + // "set without process declaration") + type = V_NONE + return + end if + end if + end subroutine var_list_check_result_var + +@ %def var_list_check_result_var +@ +Check if a variable name is a result variable of integer type: +<>= + function string_is_integer_result_var (string) result (flag) + logical :: flag + type(string_t), intent(in) :: string + type(string_t) :: buffer, name, separator + buffer = string + call split (buffer, name, "(", separator=separator) ! ")" + if (separator == "(") then + select case (char (name)) + case ("num_id", "n_calls") + flag = .true. + case default + flag = .false. + end select + else + flag = .false. + end if + end function string_is_integer_result_var + +@ %def string_is_integer_result_var +@ +Check if a variable name is an integration-result variable: +<>= + function string_is_result_var (string) result (flag) + logical :: flag + type(string_t), intent(in) :: string + type(string_t) :: buffer, name, separator + buffer = string + call split (buffer, name, "(", separator=separator) ! ")" + if (separator == "(") then + select case (char (name)) + case ("integral", "error") + flag = .true. + case default + flag = .false. + end select + else + flag = .false. + end if + end function string_is_result_var + +@ %def string_is_result_var +@ +Check if a variable name is a numeric process ID: +<>= + function string_is_num_id (string) result (flag) + logical :: flag + type(string_t), intent(in) :: string + type(string_t) :: buffer, name, separator + buffer = string + call split (buffer, name, "(", separator=separator) ! ")" + if (separator == "(") then + select case (char (name)) + case ("num_id") + flag = .true. + case default + flag = .false. + end select + else + flag = .false. + end if + end function string_is_num_id + +@ %def string_is_num_id +@ Index: trunk/src/process_integration/process_integration.nw =================================================================== --- trunk/src/process_integration/process_integration.nw (revision 8782) +++ trunk/src/process_integration/process_integration.nw (revision 8783) @@ -1,19794 +1,19780 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: integration and process objects and such %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Integration and Process Objects} \includemodulegraph{process_integration} This is the central part of the \whizard\ package. It provides the functionality for evaluating structure functions, kinematics and matrix elements, integration and event generation. It combines the various parts that deal with those tasks individually and organizes the data transfer between them. \begin{description} \item[subevt\_expr] This enables process observables as (abstract) expressions, to be evaluated for each process call. \item[parton\_states] A [[parton_state_t]] object represents an elementary partonic interaction. There are two versions: one for the isolated elementary process, one for the elementary process convoluted with the structure-function chain. The parton state is an effective state. It needs not coincide with the seed-kinematics state which is used in evaluating phase space. \item[process] Here, all pieces are combined for the purpose of evaluating the elementary processes. The whole algorithm is coded in terms of abstract data types as defined in the appropriate modules: [[prc_core]] for matrix-element evaluation, [[prc_core_def]] for the associated configuration and driver, [[sf_base]] for beams and structure-functions, [[phs_base]] for phase space, and [[mci_base]] for integration and event generation. \item[process\_config] \item[process\_counter] Very simple object for statistics \item[process\_mci] \item[pcm] \item[kinematics] \item[instances] While the above modules set up all static information, the instances have the changing event data. There are term and process instances but no component instances. \item[process\_stacks] Process stacks collect process objects. \end{description} We combine here hard interactions, phase space, and (for scatterings) structure functions and interfaces them to the integration module. The process object implements the combination of a fixed beam and structure-function setup with a number of elementary processes. The latter are called process components. The process object represents an entity which is supposedly observable. It should be meaningful to talk about the cross section of a process. The individual components of a process are, technically, processes themselves, but they may have unphysical cross sections which have to be added for a physical result. Process components may be exclusive tree-level elementary processes, dipole subtraction term, loop corrections, etc. The beam and structure function setup is common to all process components. Thus, there is only one instance of this part. The process may be a scattering process or a decay process. In the latter case, there are no structure functions, and the beam setup consists of a single particle. Otherwise, the two classes are treated on the same footing. Once a sampling point has been chosen, a process determines a set of partons with a correlated density matrix of quantum numbers. In general, each sampling point will generate, for each process component, one or more distinct parton configurations. This is the [[computed]] state. The computed state is the subject of the multi-channel integration algorithm. For NLO computations, it is necessary to project the computed states onto another set of parton configurations (e.g., by recombining certain pairs). This is the [[observed]] state. When computing partonic observables, the information is taken from the observed state. For the purpose of event generation, we will later select one parton configuration from the observed state and collapse the correlated quantum state. This configuration is then dressed by applying parton shower, decays and hadronization. The decay chain, in particular, combines a scattering process with possible subsequent decay processes on the parton level, which are full-fledged process objects themselves. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Process observables} We define an abstract [[subevt_expr_t]] object as an extension of the [[subevt_t]] type. The object contains a local variable list, variable instances (as targets for pointers in the variable list), and evaluation trees. The evaluation trees reference both the variables and the [[subevt]]. There are two instances of the abstract type: one for process instances, one for physical events. Both have a common logical expression [[selection]] which determines whether the object passes user-defined cuts. The intention is that we fill the [[subevt_t]] base object and compute the variables once we have evaluated a kinematical phase space point (or a complete event). We then evaluate the expressions and can use the results in further calculations. The [[process_expr_t]] extension contains furthermore scale and weight expressions. The [[event_expr_t]] extension contains a reweighting-factor expression and a logical expression for event analysis. In practice, we will link the variable list of the [[event_obs]] object to the variable list of the currently active [[process_obs]] object, such that the process variables are available to both objects. Event variables are meaningful only for physical events. Note that there are unit tests, but they are deferred to the [[expr_tests]] module. <<[[subevt_expr.f90]]>>= <> module subevt_expr <> <> use constants, only: zero, one use io_units use format_utils, only: write_separator use diagnostics use lorentz use subevents use variables use flavors use quantum_numbers use interactions use particles use expr_base <> <> <> <> contains <> end module subevt_expr @ %def subevt_expr @ \subsection{Abstract base type} <>= type, extends (subevt_t), abstract :: subevt_expr_t logical :: subevt_filled = .false. type(var_list_t) :: var_list real(default) :: sqrts_hat = 0 integer :: n_in = 0 integer :: n_out = 0 integer :: n_tot = 0 logical :: has_selection = .false. class(expr_t), allocatable :: selection logical :: colorize_subevt = .false. contains <> end type subevt_expr_t @ %def subevt_expr_t @ Output: Base and extended version. We already have a [[write]] routine for the [[subevt_t]] parent type. <>= procedure :: base_write => subevt_expr_write <>= subroutine subevt_expr_write (object, unit, pacified) class(subevt_expr_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacified integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Local variables:" call write_separator (u) - call var_list_write (object%var_list, u, follow_link=.false., & + call object%var_list%write (u, follow_link=.false., & pacified = pacified) call write_separator (u) if (object%subevt_filled) then call object%subevt_t%write (u, pacified = pacified) if (object%has_selection) then call write_separator (u) write (u, "(1x,A)") "Selection expression:" call write_separator (u) call object%selection%write (u) end if else write (u, "(1x,A)") "subevt: [undefined]" end if end subroutine subevt_expr_write @ %def subevt_expr_write @ Finalizer. <>= procedure (subevt_expr_final), deferred :: final procedure :: base_final => subevt_expr_final <>= subroutine subevt_expr_final (object) class(subevt_expr_t), intent(inout) :: object call object%var_list%final () if (object%has_selection) then call object%selection%final () end if end subroutine subevt_expr_final @ %def subevt_expr_final @ \subsection{Initialization} Initialization: define local variables and establish pointers. The common variables are [[sqrts]] (the nominal beam energy, fixed), [[sqrts_hat]] (the actual energy), [[n_in]], [[n_out]], and [[n_tot]] for the [[subevt]]. With the exception of [[sqrts]], all are implemented as pointers to subobjects. <>= procedure (subevt_expr_setup_vars), deferred :: setup_vars procedure :: base_setup_vars => subevt_expr_setup_vars <>= subroutine subevt_expr_setup_vars (expr, sqrts) class(subevt_expr_t), intent(inout), target :: expr real(default), intent(in) :: sqrts call expr%var_list%final () - call var_list_append_real (expr%var_list, & - var_str ("sqrts"), sqrts, & + call expr%var_list%append_real (var_str ("sqrts"), sqrts, & locked = .true., verbose = .false., intrinsic = .true.) - call var_list_append_real_ptr (expr%var_list, & - var_str ("sqrts_hat"), expr%sqrts_hat, & - is_known = expr%subevt_filled, & + call expr%var_list%append_real_ptr (var_str ("sqrts_hat"), & + expr%sqrts_hat, is_known = expr%subevt_filled, & locked = .true., verbose = .false., intrinsic = .true.) - call var_list_append_int_ptr (expr%var_list, & - var_str ("n_in"), expr%n_in, & + call expr%var_list%append_int_ptr (var_str ("n_in"), expr%n_in, & is_known = expr%subevt_filled, & locked = .true., verbose = .false., intrinsic = .true.) - call var_list_append_int_ptr (expr%var_list, & - var_str ("n_out"), expr%n_out, & + call expr%var_list%append_int_ptr (var_str ("n_out"), expr%n_out, & is_known = expr%subevt_filled, & locked = .true., verbose = .false., intrinsic = .true.) - call var_list_append_int_ptr (expr%var_list, & - var_str ("n_tot"), expr%n_tot, & + call expr%var_list%append_int_ptr (var_str ("n_tot"), expr%n_tot, & is_known = expr%subevt_filled, & locked = .true., verbose = .false., intrinsic = .true.) end subroutine subevt_expr_setup_vars @ %def subevt_expr_setup_vars @ Append the subevent expr (its base-type core) itself to the variable list, if it is not yet present. <>= procedure :: setup_var_self => subevt_expr_setup_var_self <>= subroutine subevt_expr_setup_var_self (expr) class(subevt_expr_t), intent(inout), target :: expr if (.not. expr%var_list%contains (var_str ("@evt"))) then - call var_list_append_subevt_ptr & - (expr%var_list, & - var_str ("@evt"), expr%subevt_t, & + call expr%var_list%append_subevt_ptr & + (var_str ("@evt"), expr%subevt_t, & is_known = expr%subevt_filled, & locked = .true., verbose = .false., intrinsic=.true.) end if end subroutine subevt_expr_setup_var_self @ %def subevt_expr_setup_var_self @ Link a variable list to the local one. This could be done event by event, but before evaluating expressions. <>= procedure :: link_var_list => subevt_expr_link_var_list <>= subroutine subevt_expr_link_var_list (expr, var_list) class(subevt_expr_t), intent(inout) :: expr type(var_list_t), intent(in), target :: var_list call expr%var_list%link (var_list) end subroutine subevt_expr_link_var_list @ %def subevt_expr_link_var_list @ Compile the selection expression. If there is no expression, the build method will not allocate the expression object. <>= procedure :: setup_selection => subevt_expr_setup_selection <>= subroutine subevt_expr_setup_selection (expr, ef_cuts) class(subevt_expr_t), intent(inout), target :: expr class(expr_factory_t), intent(in) :: ef_cuts call ef_cuts%build (expr%selection) if (allocated (expr%selection)) then call expr%setup_var_self () call expr%selection%setup_lexpr (expr%var_list) expr%has_selection = .true. end if end subroutine subevt_expr_setup_selection @ %def subevt_expr_setup_selection @ (De)activate color storage and evaluation for the expression. The subevent particles will have color information. <>= procedure :: colorize => subevt_expr_colorize <>= subroutine subevt_expr_colorize (expr, colorize_subevt) class(subevt_expr_t), intent(inout), target :: expr logical, intent(in) :: colorize_subevt expr%colorize_subevt = colorize_subevt end subroutine subevt_expr_colorize @ %def subevt_expr_colorize @ \subsection{Evaluation} Reset to initial state, i.e., mark the [[subevt]] as invalid. <>= procedure :: reset_contents => subevt_expr_reset_contents procedure :: base_reset_contents => subevt_expr_reset_contents <>= subroutine subevt_expr_reset_contents (expr) class(subevt_expr_t), intent(inout) :: expr expr%subevt_filled = .false. end subroutine subevt_expr_reset_contents @ %def subevt_expr_reset_contents @ Evaluate the selection expression and return the result. There is also a deferred version: this should evaluate the remaining expressions if the event has passed. <>= procedure :: base_evaluate => subevt_expr_evaluate <>= subroutine subevt_expr_evaluate (expr, passed) class(subevt_expr_t), intent(inout) :: expr logical, intent(out) :: passed if (expr%has_selection) then call expr%selection%evaluate () if (expr%selection%is_known ()) then passed = expr%selection%get_log () else call msg_error ("Evaluate selection expression: result undefined") passed = .false. end if else passed = .true. end if end subroutine subevt_expr_evaluate @ %def subevt_expr_evaluate @ \subsection{Implementation for partonic events} This implementation contains the expressions that we can evaluate for the partonic process during integration. <>= public :: parton_expr_t <>= type, extends (subevt_expr_t) :: parton_expr_t integer, dimension(:), allocatable :: i_beam integer, dimension(:), allocatable :: i_in integer, dimension(:), allocatable :: i_out logical :: has_scale = .false. logical :: has_fac_scale = .false. logical :: has_ren_scale = .false. logical :: has_weight = .false. class(expr_t), allocatable :: scale class(expr_t), allocatable :: fac_scale class(expr_t), allocatable :: ren_scale class(expr_t), allocatable :: weight contains <> end type parton_expr_t @ %def parton_expr_t @ Finalizer. <>= procedure :: final => parton_expr_final <>= subroutine parton_expr_final (object) class(parton_expr_t), intent(inout) :: object call object%base_final () if (object%has_scale) then call object%scale%final () end if if (object%has_fac_scale) then call object%fac_scale%final () end if if (object%has_ren_scale) then call object%ren_scale%final () end if if (object%has_weight) then call object%weight%final () end if end subroutine parton_expr_final @ %def parton_expr_final @ Output: continue writing the active expressions, after the common selection expression. Note: the [[prefix]] argument is declared in the [[write]] method of the [[subevt_t]] base type. Here, it is unused. <>= procedure :: write => parton_expr_write <>= subroutine parton_expr_write (object, unit, prefix, pacified) class(parton_expr_t), intent(in) :: object integer, intent(in), optional :: unit character(*), intent(in), optional :: prefix logical, intent(in), optional :: pacified integer :: u u = given_output_unit (unit) call object%base_write (u, pacified = pacified) if (object%subevt_filled) then if (object%has_scale) then call write_separator (u) write (u, "(1x,A)") "Scale expression:" call write_separator (u) call object%scale%write (u) end if if (object%has_fac_scale) then call write_separator (u) write (u, "(1x,A)") "Factorization scale expression:" call write_separator (u) call object%fac_scale%write (u) end if if (object%has_ren_scale) then call write_separator (u) write (u, "(1x,A)") "Renormalization scale expression:" call write_separator (u) call object%ren_scale%write (u) end if if (object%has_weight) then call write_separator (u) write (u, "(1x,A)") "Weight expression:" call write_separator (u) call object%weight%write (u) end if end if end subroutine parton_expr_write @ %def parton_expr_write @ Define variables. <>= procedure :: setup_vars => parton_expr_setup_vars <>= subroutine parton_expr_setup_vars (expr, sqrts) class(parton_expr_t), intent(inout), target :: expr real(default), intent(in) :: sqrts call expr%base_setup_vars (sqrts) end subroutine parton_expr_setup_vars @ %def parton_expr_setup_vars @ Compile the scale expressions. If a pointer is disassociated, there is no expression. <>= procedure :: setup_scale => parton_expr_setup_scale procedure :: setup_fac_scale => parton_expr_setup_fac_scale procedure :: setup_ren_scale => parton_expr_setup_ren_scale <>= subroutine parton_expr_setup_scale (expr, ef_scale) class(parton_expr_t), intent(inout), target :: expr class(expr_factory_t), intent(in) :: ef_scale call ef_scale%build (expr%scale) if (allocated (expr%scale)) then call expr%setup_var_self () call expr%scale%setup_expr (expr%var_list) expr%has_scale = .true. end if end subroutine parton_expr_setup_scale subroutine parton_expr_setup_fac_scale (expr, ef_fac_scale) class(parton_expr_t), intent(inout), target :: expr class(expr_factory_t), intent(in) :: ef_fac_scale call ef_fac_scale%build (expr%fac_scale) if (allocated (expr%fac_scale)) then call expr%setup_var_self () call expr%fac_scale%setup_expr (expr%var_list) expr%has_fac_scale = .true. end if end subroutine parton_expr_setup_fac_scale subroutine parton_expr_setup_ren_scale (expr, ef_ren_scale) class(parton_expr_t), intent(inout), target :: expr class(expr_factory_t), intent(in) :: ef_ren_scale call ef_ren_scale%build (expr%ren_scale) if (allocated (expr%ren_scale)) then call expr%setup_var_self () call expr%ren_scale%setup_expr (expr%var_list) expr%has_ren_scale = .true. end if end subroutine parton_expr_setup_ren_scale @ %def parton_expr_setup_scale @ %def parton_expr_setup_fac_scale @ %def parton_expr_setup_ren_scale @ Compile the weight expression. <>= procedure :: setup_weight => parton_expr_setup_weight <>= subroutine parton_expr_setup_weight (expr, ef_weight) class(parton_expr_t), intent(inout), target :: expr class(expr_factory_t), intent(in) :: ef_weight call ef_weight%build (expr%weight) if (allocated (expr%weight)) then call expr%setup_var_self () call expr%weight%setup_expr (expr%var_list) expr%has_weight = .true. end if end subroutine parton_expr_setup_weight @ %def parton_expr_setup_weight @ Filling the partonic state consists of two parts. The first routine prepares the subevt without assigning momenta. It takes the particles from an [[interaction_t]]. It needs the indices and flavors for the beam, incoming, and outgoing particles. We can assume that the particle content of the subevt does not change. Therefore, we set the event variables [[n_in]], [[n_out]], [[n_tot]] already in this initialization step. <>= procedure :: setup_subevt => parton_expr_setup_subevt <>= subroutine parton_expr_setup_subevt (expr, int, & i_beam, i_in, i_out, f_beam, f_in, f_out) class(parton_expr_t), intent(inout) :: expr type(interaction_t), intent(in), target :: int integer, dimension(:), intent(in) :: i_beam, i_in, i_out type(flavor_t), dimension(:), intent(in) :: f_beam, f_in, f_out allocate (expr%i_beam (size (i_beam))) allocate (expr%i_in (size (i_in))) allocate (expr%i_out (size (i_out))) expr%i_beam = i_beam expr%i_in = i_in expr%i_out = i_out call interaction_to_subevt (int, & expr%i_beam, expr%i_in, expr%i_out, expr%subevt_t) call expr%set_pdg_beam (f_beam%get_pdg ()) call expr%set_pdg_incoming (f_in%get_pdg ()) call expr%set_pdg_outgoing (f_out%get_pdg ()) call expr%set_p2_beam (f_beam%get_mass () ** 2) call expr%set_p2_incoming (f_in%get_mass () ** 2) call expr%set_p2_outgoing (f_out%get_mass () ** 2) expr%n_in = size (i_in) expr%n_out = size (i_out) expr%n_tot = expr%n_in + expr%n_out end subroutine parton_expr_setup_subevt @ %def parton_expr_setup_subevt @ Transfer PDG codes, masses (initalization) and momenta to a predefined subevent. We use the flavor assignment of the first branch in the interaction state matrix. Only incoming and outgoing particles are transferred. Switch momentum sign for incoming particles. <>= interface interaction_momenta_to_subevt module procedure interaction_momenta_to_subevt_id module procedure interaction_momenta_to_subevt_tr end interface <>= subroutine interaction_to_subevt (int, j_beam, j_in, j_out, subevt) type(interaction_t), intent(in), target :: int integer, dimension(:), intent(in) :: j_beam, j_in, j_out type(subevt_t), intent(out) :: subevt type(flavor_t), dimension(:), allocatable :: flv integer :: n_beam, n_in, n_out, i, j allocate (flv (int%get_n_tot ())) flv = quantum_numbers_get_flavor (int%get_quantum_numbers (1)) n_beam = size (j_beam) n_in = size (j_in) n_out = size (j_out) call subevt_init (subevt, n_beam + n_in + n_out) do i = 1, n_beam j = j_beam(i) call subevt%set_beam (i, flv(j)%get_pdg (), & vector4_null, flv(j)%get_mass () ** 2) end do do i = 1, n_in j = j_in(i) call subevt%set_incoming (n_beam + i, flv(j)%get_pdg (), & vector4_null, flv(j)%get_mass () ** 2) end do do i = 1, n_out j = j_out(i) call subevt%set_outgoing (n_beam + n_in + i, & flv(j)%get_pdg (), vector4_null, & flv(j)%get_mass () ** 2) end do end subroutine interaction_to_subevt subroutine interaction_momenta_to_subevt_id (int, j_beam, j_in, j_out, subevt) type(interaction_t), intent(in) :: int integer, dimension(:), intent(in) :: j_beam, j_in, j_out type(subevt_t), intent(inout) :: subevt call subevt%set_p_beam (- int%get_momenta (j_beam)) call subevt%set_p_incoming (- int%get_momenta (j_in)) call subevt%set_p_outgoing (int%get_momenta (j_out)) end subroutine interaction_momenta_to_subevt_id subroutine interaction_momenta_to_subevt_tr & (int, j_beam, j_in, j_out, lt, subevt) type(interaction_t), intent(in) :: int integer, dimension(:), intent(in) :: j_beam, j_in, j_out type(subevt_t), intent(inout) :: subevt type(lorentz_transformation_t), intent(in) :: lt call subevt%set_p_beam (- lt * int%get_momenta (j_beam)) call subevt%set_p_incoming (- lt * int%get_momenta (j_in)) call subevt%set_p_outgoing (lt * int%get_momenta (j_out)) end subroutine interaction_momenta_to_subevt_tr @ %def interaction_momenta_to_subevt @ The second part takes the momenta from the interaction object and thus completes the subevt. The partonic energy can then be computed. <>= procedure :: fill_subevt => parton_expr_fill_subevt <>= subroutine parton_expr_fill_subevt (expr, int) class(parton_expr_t), intent(inout) :: expr type(interaction_t), intent(in), target :: int call interaction_momenta_to_subevt (int, & expr%i_beam, expr%i_in, expr%i_out, expr%subevt_t) expr%sqrts_hat = expr%get_sqrts_hat () expr%subevt_filled = .true. end subroutine parton_expr_fill_subevt @ %def parton_expr_fill_subevt @ Evaluate, if the event passes the selection. For absent expressions we take default values. <>= procedure :: evaluate => parton_expr_evaluate <>= subroutine parton_expr_evaluate & (expr, passed, scale, fac_scale, ren_scale, weight, scale_forced, force_evaluation) class(parton_expr_t), intent(inout) :: expr logical, intent(out) :: passed real(default), intent(out) :: scale real(default), allocatable, intent(out) :: fac_scale real(default), allocatable, intent(out) :: ren_scale real(default), intent(out) :: weight real(default), intent(in), allocatable, optional :: scale_forced logical, intent(in), optional :: force_evaluation logical :: force_scale, force_eval force_scale = .false.; force_eval = .false. if (present (scale_forced)) force_scale = allocated (scale_forced) if (present (force_evaluation)) force_eval = force_evaluation call expr%base_evaluate (passed) if (passed .or. force_eval) then if (force_scale) then scale = scale_forced else if (expr%has_scale) then call expr%scale%evaluate () if (expr%scale%is_known ()) then scale = expr%scale%get_real () else call msg_error ("Evaluate scale expression: result undefined") scale = zero end if else scale = expr%sqrts_hat end if if (expr%has_fac_scale) then call expr%fac_scale%evaluate () if (expr%fac_scale%is_known ()) then if (.not. allocated (fac_scale)) then allocate (fac_scale, source = expr%fac_scale%get_real ()) else fac_scale = expr%fac_scale%get_real () end if else call msg_error ("Evaluate factorization scale expression: & &result undefined") end if end if if (expr%has_ren_scale) then call expr%ren_scale%evaluate () if (expr%ren_scale%is_known ()) then if (.not. allocated (ren_scale)) then allocate (ren_scale, source = expr%ren_scale%get_real ()) else ren_scale = expr%ren_scale%get_real () end if else call msg_error ("Evaluate renormalization scale expression: & &result undefined") end if end if if (expr%has_weight) then call expr%weight%evaluate () if (expr%weight%is_known ()) then weight = expr%weight%get_real () else call msg_error ("Evaluate weight expression: result undefined") weight = zero end if else weight = one end if else weight = zero end if end subroutine parton_expr_evaluate @ %def parton_expr_evaluate @ Return the beam/incoming parton indices. <>= procedure :: get_beam_index => parton_expr_get_beam_index procedure :: get_in_index => parton_expr_get_in_index <>= subroutine parton_expr_get_beam_index (expr, i_beam) class(parton_expr_t), intent(in) :: expr integer, dimension(:), intent(out) :: i_beam i_beam = expr%i_beam end subroutine parton_expr_get_beam_index subroutine parton_expr_get_in_index (expr, i_in) class(parton_expr_t), intent(in) :: expr integer, dimension(:), intent(out) :: i_in i_in = expr%i_in end subroutine parton_expr_get_in_index @ %def parton_expr_get_beam_index @ %def parton_expr_get_in_index @ \subsection{Implementation for full events} This implementation contains the expressions that we can evaluate for the full event. It also contains data that pertain to the event, suitable for communication with external event formats. These data simultaneously serve as pointer targets for the variable lists hidden in the expressions (eval trees). Squared matrix element and weight values: when reading events from file, the [[ref]] value is the number in the file, while the [[prc]] value is the number that we calculate from the momenta in the file, possibly with different parameters. When generating events the first time, or if we do not recalculate, the numbers should coincide. Furthermore, the array of [[alt]] values is copied from an array of alternative event records. These values should represent calculated values. <>= public :: event_expr_t <>= type, extends (subevt_expr_t) :: event_expr_t logical :: has_reweight = .false. logical :: has_analysis = .false. class(expr_t), allocatable :: reweight class(expr_t), allocatable :: analysis logical :: has_id = .false. type(string_t) :: id logical :: has_num_id = .false. integer :: num_id = 0 logical :: has_index = .false. integer :: index = 0 logical :: has_sqme_ref = .false. real(default) :: sqme_ref = 0 logical :: has_sqme_prc = .false. real(default) :: sqme_prc = 0 logical :: has_weight_ref = .false. real(default) :: weight_ref = 0 logical :: has_weight_prc = .false. real(default) :: weight_prc = 0 logical :: has_excess_prc = .false. real(default) :: excess_prc = 0 integer :: n_alt = 0 logical :: has_sqme_alt = .false. real(default), dimension(:), allocatable :: sqme_alt logical :: has_weight_alt = .false. real(default), dimension(:), allocatable :: weight_alt contains <> end type event_expr_t @ %def event_expr_t @ Finalizer for the expressions. <>= procedure :: final => event_expr_final <>= subroutine event_expr_final (object) class(event_expr_t), intent(inout) :: object call object%base_final () if (object%has_reweight) then call object%reweight%final () end if if (object%has_analysis) then call object%analysis%final () end if end subroutine event_expr_final @ %def event_expr_final @ Output: continue writing the active expressions, after the common selection expression. Note: the [[prefix]] argument is declared in the [[write]] method of the [[subevt_t]] base type. Here, it is unused. <>= procedure :: write => event_expr_write <>= subroutine event_expr_write (object, unit, prefix, pacified) class(event_expr_t), intent(in) :: object integer, intent(in), optional :: unit character(*), intent(in), optional :: prefix logical, intent(in), optional :: pacified integer :: u u = given_output_unit (unit) call object%base_write (u, pacified = pacified) if (object%subevt_filled) then if (object%has_reweight) then call write_separator (u) write (u, "(1x,A)") "Reweighting expression:" call write_separator (u) call object%reweight%write (u) end if if (object%has_analysis) then call write_separator (u) write (u, "(1x,A)") "Analysis expression:" call write_separator (u) call object%analysis%write (u) end if end if end subroutine event_expr_write @ %def event_expr_write @ Initializer. This is required only for the [[sqme_alt]] and [[weight_alt]] arrays. <>= procedure :: init => event_expr_init <>= subroutine event_expr_init (expr, n_alt) class(event_expr_t), intent(out) :: expr integer, intent(in), optional :: n_alt if (present (n_alt)) then expr%n_alt = n_alt allocate (expr%sqme_alt (n_alt), source = 0._default) allocate (expr%weight_alt (n_alt), source = 0._default) end if end subroutine event_expr_init @ %def event_expr_init @ Define variables. We have the variables of the base type plus specific variables for full events. There is the event index. <>= procedure :: setup_vars => event_expr_setup_vars <>= subroutine event_expr_setup_vars (expr, sqrts) class(event_expr_t), intent(inout), target :: expr real(default), intent(in) :: sqrts call expr%base_setup_vars (sqrts) - call var_list_append_string_ptr (expr%var_list, & - var_str ("$process_id"), expr%id, & - is_known = expr%has_id, & + call expr%var_list%append_string_ptr (var_str ("$process_id"), & + expr%id, is_known = expr%has_id, & locked = .true., verbose = .false., intrinsic = .true.) - call var_list_append_int_ptr (expr%var_list, & - var_str ("process_num_id"), expr%num_id, & - is_known = expr%has_num_id, & + call expr%var_list%append_int_ptr (var_str ("process_num_id"), & + expr%num_id, is_known = expr%has_num_id, & locked = .true., verbose = .false., intrinsic = .true.) - call var_list_append_real_ptr (expr%var_list, & - var_str ("sqme"), expr%sqme_prc, & - is_known = expr%has_sqme_prc, & + call expr%var_list%append_real_ptr (var_str ("sqme"), & + expr%sqme_prc, is_known = expr%has_sqme_prc, & locked = .true., verbose = .false., intrinsic = .true.) - call var_list_append_real_ptr (expr%var_list, & - var_str ("sqme_ref"), expr%sqme_ref, & - is_known = expr%has_sqme_ref, & + call expr%var_list%append_real_ptr (var_str ("sqme_ref"), & + expr%sqme_ref, is_known = expr%has_sqme_ref, & locked = .true., verbose = .false., intrinsic = .true.) - call var_list_append_int_ptr (expr%var_list, & - var_str ("event_index"), expr%index, & - is_known = expr%has_index, & + call expr%var_list%append_int_ptr (var_str ("event_index"), & + expr%index, is_known = expr%has_index, & locked = .true., verbose = .false., intrinsic = .true.) - call var_list_append_real_ptr (expr%var_list, & - var_str ("event_weight"), expr%weight_prc, & - is_known = expr%has_weight_prc, & + call expr%var_list%append_real_ptr (var_str ("event_weight"), & + expr%weight_prc, is_known = expr%has_weight_prc, & locked = .true., verbose = .false., intrinsic = .true.) - call var_list_append_real_ptr (expr%var_list, & - var_str ("event_weight_ref"), expr%weight_ref, & - is_known = expr%has_weight_ref, & + call expr%var_list%append_real_ptr (var_str ("event_weight_ref"), & + expr%weight_ref, is_known = expr%has_weight_ref, & locked = .true., verbose = .false., intrinsic = .true.) - call var_list_append_real_ptr (expr%var_list, & - var_str ("event_excess"), expr%excess_prc, & - is_known = expr%has_excess_prc, & + call expr%var_list%append_real_ptr (var_str ("event_excess"), & + expr%excess_prc, is_known = expr%has_excess_prc, & locked = .true., verbose = .false., intrinsic = .true.) end subroutine event_expr_setup_vars @ %def event_expr_setup_vars @ Compile the analysis expression. If the pointer is disassociated, there is no expression. <>= procedure :: setup_analysis => event_expr_setup_analysis <>= subroutine event_expr_setup_analysis (expr, ef_analysis) class(event_expr_t), intent(inout), target :: expr class(expr_factory_t), intent(in) :: ef_analysis call ef_analysis%build (expr%analysis) if (allocated (expr%analysis)) then call expr%setup_var_self () call expr%analysis%setup_lexpr (expr%var_list) expr%has_analysis = .true. end if end subroutine event_expr_setup_analysis @ %def event_expr_setup_analysis @ Compile the reweight expression. <>= procedure :: setup_reweight => event_expr_setup_reweight <>= subroutine event_expr_setup_reweight (expr, ef_reweight) class(event_expr_t), intent(inout), target :: expr class(expr_factory_t), intent(in) :: ef_reweight call ef_reweight%build (expr%reweight) if (allocated (expr%reweight)) then call expr%setup_var_self () call expr%reweight%setup_expr (expr%var_list) expr%has_reweight = .true. end if end subroutine event_expr_setup_reweight @ %def event_expr_setup_reweight @ Store the string or numeric process ID. This should be done during initialization. <>= procedure :: set_process_id => event_expr_set_process_id procedure :: set_process_num_id => event_expr_set_process_num_id <>= subroutine event_expr_set_process_id (expr, id) class(event_expr_t), intent(inout) :: expr type(string_t), intent(in) :: id expr%id = id expr%has_id = .true. end subroutine event_expr_set_process_id subroutine event_expr_set_process_num_id (expr, num_id) class(event_expr_t), intent(inout) :: expr integer, intent(in) :: num_id expr%num_id = num_id expr%has_num_id = .true. end subroutine event_expr_set_process_num_id @ %def event_expr_set_process_id @ %def event_expr_set_process_num_id @ Reset / set the data that pertain to a particular event. The event index is reset unless explicitly told to keep it. <>= procedure :: reset_contents => event_expr_reset_contents procedure :: set => event_expr_set <>= subroutine event_expr_reset_contents (expr) class(event_expr_t), intent(inout) :: expr call expr%base_reset_contents () expr%has_sqme_ref = .false. expr%has_sqme_prc = .false. expr%has_sqme_alt = .false. expr%has_weight_ref = .false. expr%has_weight_prc = .false. expr%has_weight_alt = .false. expr%has_excess_prc = .false. end subroutine event_expr_reset_contents subroutine event_expr_set (expr, & weight_ref, weight_prc, weight_alt, & excess_prc, & sqme_ref, sqme_prc, sqme_alt) class(event_expr_t), intent(inout) :: expr real(default), intent(in), optional :: weight_ref, weight_prc real(default), intent(in), optional :: excess_prc real(default), intent(in), optional :: sqme_ref, sqme_prc real(default), dimension(:), intent(in), optional :: sqme_alt, weight_alt if (present (sqme_ref)) then expr%has_sqme_ref = .true. expr%sqme_ref = sqme_ref end if if (present (sqme_prc)) then expr%has_sqme_prc = .true. expr%sqme_prc = sqme_prc end if if (present (sqme_alt)) then expr%has_sqme_alt = .true. expr%sqme_alt = sqme_alt end if if (present (weight_ref)) then expr%has_weight_ref = .true. expr%weight_ref = weight_ref end if if (present (weight_prc)) then expr%has_weight_prc = .true. expr%weight_prc = weight_prc end if if (present (weight_alt)) then expr%has_weight_alt = .true. expr%weight_alt = weight_alt end if if (present (excess_prc)) then expr%has_excess_prc = .true. expr%excess_prc = excess_prc end if end subroutine event_expr_set @ %def event_expr_reset_contents event_expr_set @ Access the subevent index. <>= procedure :: has_event_index => event_expr_has_event_index procedure :: get_event_index => event_expr_get_event_index <>= function event_expr_has_event_index (expr) result (flag) class(event_expr_t), intent(in) :: expr logical :: flag flag = expr%has_index end function event_expr_has_event_index function event_expr_get_event_index (expr) result (index) class(event_expr_t), intent(in) :: expr integer :: index if (expr%has_index) then index = expr%index else index = 0 end if end function event_expr_get_event_index @ %def event_expr_has_event_index @ %def event_expr_get_event_index @ Set/increment the subevent index. Initialize it if necessary. <>= procedure :: set_event_index => event_expr_set_event_index procedure :: reset_event_index => event_expr_reset_event_index procedure :: increment_event_index => event_expr_increment_event_index <>= subroutine event_expr_set_event_index (expr, index) class(event_expr_t), intent(inout) :: expr integer, intent(in) :: index expr%index = index expr%has_index = .true. end subroutine event_expr_set_event_index subroutine event_expr_reset_event_index (expr) class(event_expr_t), intent(inout) :: expr expr%has_index = .false. end subroutine event_expr_reset_event_index subroutine event_expr_increment_event_index (expr, offset) class(event_expr_t), intent(inout) :: expr integer, intent(in), optional :: offset if (expr%has_index) then expr%index = expr%index + 1 else if (present (offset)) then call expr%set_event_index (offset + 1) else call expr%set_event_index (1) end if end subroutine event_expr_increment_event_index @ %def event_expr_set_event_index @ %def event_expr_increment_event_index @ Fill the event expression: take the particle data and kinematics from a [[particle_set]] object. We allow the particle content to change for each event. Therefore, we set the event variables each time. Also increment the event index; initialize it if necessary. <>= procedure :: fill_subevt => event_expr_fill_subevt <>= subroutine event_expr_fill_subevt (expr, particle_set) class(event_expr_t), intent(inout) :: expr type(particle_set_t), intent(in) :: particle_set call particle_set%to_subevt (expr%subevt_t, expr%colorize_subevt) expr%sqrts_hat = expr%get_sqrts_hat () expr%n_in = expr%get_n_in () expr%n_out = expr%get_n_out () expr%n_tot = expr%n_in + expr%n_out expr%subevt_filled = .true. end subroutine event_expr_fill_subevt @ %def event_expr_fill_subevt @ Evaluate, if the event passes the selection. For absent expressions we take default values. <>= procedure :: evaluate => event_expr_evaluate <>= subroutine event_expr_evaluate (expr, passed, reweight, analysis_flag) class(event_expr_t), intent(inout) :: expr logical, intent(out) :: passed real(default), intent(out) :: reweight logical, intent(out) :: analysis_flag call expr%base_evaluate (passed) if (passed) then if (expr%has_reweight) then call expr%reweight%evaluate () if (expr%reweight%is_known ()) then reweight = expr%reweight%get_real () else call msg_error ("Evaluate reweight expression: & &result undefined") reweight = 0 end if else reweight = 1 end if if (expr%has_analysis) then call expr%analysis%evaluate () if (expr%analysis%is_known ()) then analysis_flag = expr%analysis%get_log () else call msg_error ("Evaluate analysis expression: & &result undefined") analysis_flag = .false. end if else analysis_flag = .true. end if end if end subroutine event_expr_evaluate @ %def event_expr_evaluate @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Parton states} A [[parton_state_t]] object contains the effective kinematics and dynamics of an elementary partonic interaction, with or without the beam/structure function state included. The type is abstract and has two distinct extensions. The [[isolated_state_t]] extension describes the isolated elementary interaction where the [[int_eff]] subobject contains the complex transition amplitude, exclusive in all quantum numbers. The particle content and kinematics describe the effective partonic state. The [[connected_state_t]] extension contains the partonic [[subevt]] and the expressions for cuts and scales which use it. In the isolated state, the effective partonic interaction may either be identical to the hard interaction, in which case it is just a pointer to the latter. Or it may involve a rearrangement of partons, in which case we allocate it explicitly and flag this by [[int_is_allocated]]. The [[trace]] evaluator contains the absolute square of the effective transition amplitude matrix, summed over final states. It is also summed over initial states, depending on the the beam setup allows. The result is used for integration. The [[matrix]] evaluator is the counterpart of [[trace]] which is kept exclusive in all observable quantum numbers. The [[flows]] evaluator is furthermore exclusive in colors, but neglecting all color interference. The [[matrix]] and [[flows]] evaluators are filled only for sampling points that become part of physical events. Note: It would be natural to make the evaluators allocatable. The extra [[has_XXX]] flags indicate whether evaluators are active, instead. This module contains no unit tests. The tests are covered by the [[processes]] module below. <<[[parton_states.f90]]>>= <> module parton_states <> <> use io_units use format_utils, only: write_separator use diagnostics use lorentz use subevents use variables use expr_base use model_data use flavors use helicities use colors use quantum_numbers use state_matrices use polarizations use interactions use evaluators use beams use sf_base use process_constants use prc_core use subevt_expr <> <> <> contains <> end module parton_states @ %def parton_states @ \subsection{Abstract base type} The common part are the evaluators, one for the trace (summed over all quantum numbers), one for the transition matrix (summed only over unobservable quantum numbers), and one for the flow distribution (transition matrix without interferences, exclusive in color flow). <>= type, abstract :: parton_state_t logical :: has_trace = .false. logical :: has_matrix = .false. logical :: has_flows = .false. type(evaluator_t) :: trace type(evaluator_t) :: matrix type(evaluator_t) :: flows contains <> end type parton_state_t @ %def parton_state_t @ The [[isolated_state_t]] extension contains the [[sf_chain_eff]] object and the (hard) effective interaction [[int_eff]], separately, both are implemented as a pointer. The evaluators (trace, matrix, flows) apply to the hard interaction only. If the effective interaction differs from the hard interaction, the pointer is allocated explicitly. Analogously for [[sf_chain_eff]]. <>= public :: isolated_state_t <>= type, extends (parton_state_t) :: isolated_state_t logical :: sf_chain_is_allocated = .false. type(sf_chain_instance_t), pointer :: sf_chain_eff => null () logical :: int_is_allocated = .false. type(interaction_t), pointer :: int_eff => null () contains <> end type isolated_state_t @ %def isolated_state_t @ The [[connected_state_t]] extension contains all data that enable the evaluation of observables for the effective connected state. The evaluators connect the (effective) structure-function chain and hard interaction that were kept separate in the [[isolated_state_t]]. The [[flows_sf]] evaluator is an extended copy of the structure-function The [[expr]] subobject consists of the [[subevt]], a simple event record, expressions for cuts etc.\ which refer to this record, and a [[var_list]] which contains event-specific variables, linked to the process variable list. Variables used within the expressions are looked up in [[var_list]]. <>= public :: connected_state_t <>= type, extends (parton_state_t) :: connected_state_t type(state_flv_content_t) :: state_flv logical :: has_flows_sf = .false. type(evaluator_t) :: flows_sf logical :: has_expr = .false. type(parton_expr_t) :: expr contains <> end type connected_state_t @ %def connected_state_t @ Output: each evaluator is written only when it is active. The [[sf_chain]] is only written if it is explicitly allocated. <>= procedure :: write => parton_state_write <>= subroutine parton_state_write (state, unit, testflag) class(parton_state_t), intent(in) :: state integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) select type (state) class is (isolated_state_t) if (state%sf_chain_is_allocated) then call write_separator (u) call state%sf_chain_eff%write (u) end if if (state%int_is_allocated) then call write_separator (u) write (u, "(1x,A)") & "Effective interaction:" call write_separator (u) call state%int_eff%basic_write (u, testflag = testflag) end if class is (connected_state_t) if (state%has_flows_sf) then call write_separator (u) write (u, "(1x,A)") & "Evaluator (extension of the beam evaluator & &with color contractions):" call write_separator (u) call state%flows_sf%write (u, testflag = testflag) end if end select if (state%has_trace) then call write_separator (u) write (u, "(1x,A)") & "Evaluator (trace of the squared transition matrix):" call write_separator (u) call state%trace%write (u, testflag = testflag) end if if (state%has_matrix) then call write_separator (u) write (u, "(1x,A)") & "Evaluator (squared transition matrix):" call write_separator (u) call state%matrix%write (u, testflag = testflag) end if if (state%has_flows) then call write_separator (u) write (u, "(1x,A)") & "Evaluator (squared color-flow matrix):" call write_separator (u) call state%flows%write (u, testflag = testflag) end if select type (state) class is (connected_state_t) if (state%has_expr) then call write_separator (u) call state%expr%write (u) end if end select end subroutine parton_state_write @ %def parton_state_write @ Finalize interaction and evaluators, but only if allocated. <>= procedure :: final => parton_state_final <>= subroutine parton_state_final (state) class(parton_state_t), intent(inout) :: state if (state%has_flows) then call state%flows%final () state%has_flows = .false. end if if (state%has_matrix) then call state%matrix%final () state%has_matrix = .false. end if if (state%has_trace) then call state%trace%final () state%has_trace = .false. end if select type (state) class is (connected_state_t) if (state%has_flows_sf) then call state%flows_sf%final () state%has_flows_sf = .false. end if call state%expr%final () class is (isolated_state_t) if (state%int_is_allocated) then call state%int_eff%final () deallocate (state%int_eff) state%int_is_allocated = .false. end if if (state%sf_chain_is_allocated) then call state%sf_chain_eff%final () end if end select end subroutine parton_state_final @ %def parton_state_final @ \subsection{Common Initialization} Initialize the isolated parton state. In this version, the effective structure-function chain [[sf_chain_eff]] and the effective interaction [[int_eff]] both are trivial pointers to the seed structure-function chain and to the hard interaction, respectively. <>= procedure :: init => isolated_state_init <>= subroutine isolated_state_init (state, sf_chain, int) class(isolated_state_t), intent(out) :: state type(sf_chain_instance_t), intent(in), target :: sf_chain type(interaction_t), intent(in), target :: int state%sf_chain_eff => sf_chain state%int_eff => int end subroutine isolated_state_init @ %def isolated_state_init @ \subsection{Evaluator initialization: isolated state} Create an evaluator for the trace of the squared transition matrix. The trace goes over all outgoing quantum numbers. Whether we trace over incoming quantum numbers other than color, depends on the given [[qn_mask_in]]. There are two options: explicitly computing the color factor table ([[use_cf]] false; [[nc]] defined), or taking the color factor table from the hard matrix element data. <>= procedure :: setup_square_trace => isolated_state_setup_square_trace <>= subroutine isolated_state_setup_square_trace (state, core, & qn_mask_in, col, keep_fs_flavor) class(isolated_state_t), intent(inout), target :: state class(prc_core_t), intent(in) :: core type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask_in !!! Actually need allocatable attribute here for once because col might !!! enter the subroutine non-allocated. integer, intent(in), dimension(:), allocatable :: col logical, intent(in) :: keep_fs_flavor type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask associate (data => core%data) allocate (qn_mask (data%n_in + data%n_out)) qn_mask( : data%n_in) = & quantum_numbers_mask (.false., .true., .false.) & .or. qn_mask_in qn_mask(data%n_in + 1 : ) = & quantum_numbers_mask (.not. keep_fs_flavor, .true., .true.) if (core%use_color_factors) then call state%trace%init_square (state%int_eff, qn_mask, & col_flow_index = data%cf_index, & col_factor = data%color_factors, & col_index_hi = col, & nc = core%nc) else call state%trace%init_square (state%int_eff, qn_mask, nc = core%nc) end if end associate state%has_trace = .true. end subroutine isolated_state_setup_square_trace @ %def isolated_state_setup_square_trace @ Set up an identity-evaluator for the trace. This implies that [[me]] is considered to be a squared amplitude, as for example for BLHA matrix elements. <>= procedure :: setup_identity_trace => isolated_state_setup_identity_trace <>= subroutine isolated_state_setup_identity_trace (state, core, qn_mask_in, & keep_fs_flavors, keep_colors) class(isolated_state_t), intent(inout), target :: state class(prc_core_t), intent(in) :: core type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask_in logical, intent(in), optional :: keep_fs_flavors, keep_colors type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask logical :: fs_flv_flag, col_flag fs_flv_flag = .true.; col_flag = .true. if (present(keep_fs_flavors)) fs_flv_flag = .not. keep_fs_flavors if (present(keep_colors)) col_flag = .not. keep_colors associate (data => core%data) allocate (qn_mask (data%n_in + data%n_out)) qn_mask( : data%n_in) = & quantum_numbers_mask (.false., col_flag, .false.) .or. qn_mask_in qn_mask(data%n_in + 1 : ) = & quantum_numbers_mask (fs_flv_flag, col_flag, .true.) end associate call state%int_eff%set_mask (qn_mask) call state%trace%init_identity (state%int_eff) state%has_trace = .true. end subroutine isolated_state_setup_identity_trace @ %def isolated_state_setup_identity_trace @ Set up the evaluator for the transition matrix, exclusive in helicities where this is requested. For all unstable final-state particles we keep polarization according to the applicable decay options. If the process is a decay itself, this applies also to the initial state. For all polarized final-state particles, we keep polarization including off-diagonal entries. We drop helicity completely for unpolarized final-state particles. For the initial state, if the particle has not been handled yet, we apply the provided [[qn_mask_in]] which communicates the beam properties. <>= procedure :: setup_square_matrix => isolated_state_setup_square_matrix <>= subroutine isolated_state_setup_square_matrix & (state, core, model, qn_mask_in, col) class(isolated_state_t), intent(inout), target :: state class(prc_core_t), intent(in) :: core class(model_data_t), intent(in), target :: model type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in integer, dimension(:), intent(in) :: col type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask type(flavor_t), dimension(:), allocatable :: flv integer :: i logical :: helmask, helmask_hd associate (data => core%data) allocate (qn_mask (data%n_in + data%n_out)) allocate (flv (data%n_flv)) do i = 1, data%n_in + data%n_out call flv%init (data%flv_state(i,:), model) if ((data%n_in == 1 .or. i > data%n_in) & .and. any (.not. flv%is_stable ())) then helmask = all (flv%decays_isotropically ()) helmask_hd = all (flv%decays_diagonal ()) qn_mask(i) = quantum_numbers_mask (.false., .true., helmask, & mask_hd = helmask_hd) else if (i > data%n_in) then helmask = all (.not. flv%is_polarized ()) qn_mask(i) = quantum_numbers_mask (.false., .true., helmask) else qn_mask(i) = quantum_numbers_mask (.false., .true., .false.) & .or. qn_mask_in(i) end if end do if (core%use_color_factors) then call state%matrix%init_square (state%int_eff, qn_mask, & col_flow_index = data%cf_index, & col_factor = data%color_factors, & col_index_hi = col, & nc = core%nc) else call state%matrix%init_square (state%int_eff, & qn_mask, & nc = core%nc) end if end associate state%has_matrix = .true. end subroutine isolated_state_setup_square_matrix @ %def isolated_state_setup_square_matrix @ This procedure initializes the evaluator that computes the contributions to color flows, neglecting color interference. The incoming-particle mask can be used to sum over incoming flavor. Helicity handling: see above. <>= procedure :: setup_square_flows => isolated_state_setup_square_flows <>= subroutine isolated_state_setup_square_flows (state, core, model, qn_mask_in) class(isolated_state_t), intent(inout), target :: state class(prc_core_t), intent(in) :: core class(model_data_t), intent(in), target :: model type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask type(flavor_t), dimension(:), allocatable :: flv integer :: i logical :: helmask, helmask_hd associate (data => core%data) allocate (qn_mask (data%n_in + data%n_out)) allocate (flv (data%n_flv)) do i = 1, data%n_in + data%n_out call flv%init (data%flv_state(i,:), model) if ((data%n_in == 1 .or. i > data%n_in) & .and. any (.not. flv%is_stable ())) then helmask = all (flv%decays_isotropically ()) helmask_hd = all (flv%decays_diagonal ()) qn_mask(i) = quantum_numbers_mask (.false., .false., helmask, & mask_hd = helmask_hd) else if (i > data%n_in) then helmask = all (.not. flv%is_polarized ()) qn_mask(i) = quantum_numbers_mask (.false., .false., helmask) else qn_mask(i) = quantum_numbers_mask (.false., .false., .false.) & .or. qn_mask_in(i) end if end do call state%flows%init_square (state%int_eff, qn_mask, & expand_color_flows = .true.) end associate state%has_flows = .true. end subroutine isolated_state_setup_square_flows @ %def isolated_state_setup_square_flows @ \subsection{Evaluator initialization: connected state} Set up a trace evaluator as a product of two evaluators (incoming state, effective interaction). In the result, all quantum numbers are summed over. If the optional [[int]] interaction is provided, use this for the first factor in the convolution. Otherwise, use the final interaction of the stored [[sf_chain]]. The [[resonant]] flag applies if we want to construct a decay chain. The resonance property can propagate to the final event output. If an extended structure function is required [[requires_extended_sf]], we have to not consider [[sub]] as a quantum number. <>= procedure :: setup_connected_trace => connected_state_setup_connected_trace <>= subroutine connected_state_setup_connected_trace & (state, isolated, int, resonant, undo_helicities, & keep_fs_flavors, requires_extended_sf) class(connected_state_t), intent(inout), target :: state type(isolated_state_t), intent(in), target :: isolated type(interaction_t), intent(in), optional, target :: int logical, intent(in), optional :: resonant logical, intent(in), optional :: undo_helicities logical, intent(in), optional :: keep_fs_flavors logical, intent(in), optional :: requires_extended_sf type(quantum_numbers_mask_t) :: mask type(interaction_t), pointer :: src_int, beam_int logical :: reduce, fs_flv_flag if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, & "connected_state_setup_connected_trace") reduce = .false.; fs_flv_flag = .true. if (present (undo_helicities)) reduce = undo_helicities if (present (keep_fs_flavors)) fs_flv_flag = .not. keep_fs_flavors mask = quantum_numbers_mask (fs_flv_flag, .true., .true.) if (present (int)) then src_int => int else src_int => isolated%sf_chain_eff%get_out_int_ptr () end if if (debug2_active (D_PROCESS_INTEGRATION)) then call src_int%basic_write () end if call state%trace%init_product (src_int, isolated%trace, & qn_mask_conn = mask, & qn_mask_rest = mask, & connections_are_resonant = resonant, & ignore_sub_for_qn = requires_extended_sf) if (reduce) then beam_int => isolated%sf_chain_eff%get_beam_int_ptr () call undo_qn_hel (beam_int, mask, beam_int%get_n_tot ()) call undo_qn_hel (src_int, mask, src_int%get_n_tot ()) call beam_int%set_matrix_element (cmplx (1, 0, default)) call src_int%set_matrix_element (cmplx (1, 0, default)) end if state%has_trace = .true. contains subroutine undo_qn_hel (int_in, mask, n_tot) type(interaction_t), intent(inout) :: int_in type(quantum_numbers_mask_t), intent(in) :: mask integer, intent(in) :: n_tot type(quantum_numbers_mask_t), dimension(n_tot) :: mask_in mask_in = mask call int_in%set_mask (mask_in) end subroutine undo_qn_hel end subroutine connected_state_setup_connected_trace @ %def connected_state_setup_connected_trace @ Set up a matrix evaluator as a product of two evaluators (incoming state, effective interation). In the intermediate state, color and helicity is summed over. In the final state, we keep the quantum numbers which are present in the original evaluators. <>= procedure :: setup_connected_matrix => connected_state_setup_connected_matrix <>= subroutine connected_state_setup_connected_matrix & (state, isolated, int, resonant, qn_filter_conn) class(connected_state_t), intent(inout), target :: state type(isolated_state_t), intent(in), target :: isolated type(interaction_t), intent(in), optional, target :: int logical, intent(in), optional :: resonant type(quantum_numbers_t), intent(in), optional :: qn_filter_conn type(quantum_numbers_mask_t) :: mask type(interaction_t), pointer :: src_int mask = quantum_numbers_mask (.false., .true., .true.) if (present (int)) then src_int => int else src_int => isolated%sf_chain_eff%get_out_int_ptr () end if call state%matrix%init_product & (src_int, isolated%matrix, mask, & qn_filter_conn = qn_filter_conn, & connections_are_resonant = resonant) state%has_matrix = .true. end subroutine connected_state_setup_connected_matrix @ %def connected_state_setup_connected_matrix @ Set up a matrix evaluator as a product of two evaluators (incoming state, effective interation). In the intermediate state, only helicity is summed over. In the final state, we keep the quantum numbers which are present in the original evaluators. If the optional [[int]] interaction is provided, use this for the first factor in the convolution. Otherwise, use the final interaction of the stored [[sf_chain]], after creating an intermediate interaction that includes a correlated color state. We assume that for a caller-provided [[int]], this is not necessary. For fixed-order NLO differential distribution, we are interested at the partonic level, no parton showering takes place as this would demand for a proper matching. So, the flows in the [[connected_state]] are not needed, and the color part will be masked for the interaction coming from the [[sf_chain]]. The squared matrix elements coming from the OLP provider at the moment do not come with flows anyhow. This needs to be revised once the matching to the shower is completed. <>= procedure :: setup_connected_flows => connected_state_setup_connected_flows <>= subroutine connected_state_setup_connected_flows & (state, isolated, int, resonant, qn_filter_conn, mask_color) class(connected_state_t), intent(inout), target :: state type(isolated_state_t), intent(in), target :: isolated type(interaction_t), intent(in), optional, target :: int logical, intent(in), optional :: resonant, mask_color type(quantum_numbers_t), intent(in), optional :: qn_filter_conn type(quantum_numbers_mask_t) :: mask type(quantum_numbers_mask_t), dimension(:), allocatable :: mask_sf type(interaction_t), pointer :: src_int logical :: mask_c mask_c = .false. if (present (mask_color)) mask_c = mask_color mask = quantum_numbers_mask (.false., .false., .true.) if (present (int)) then src_int => int else src_int => isolated%sf_chain_eff%get_out_int_ptr () call state%flows_sf%init_color_contractions (src_int) state%has_flows_sf = .true. src_int => state%flows_sf%interaction_t if (mask_c) then allocate (mask_sf (src_int%get_n_tot ())) mask_sf = quantum_numbers_mask (.false., .true., .false.) call src_int%reduce_state_matrix (mask_sf, keep_order = .true.) end if end if call state%flows%init_product (src_int, isolated%flows, mask, & qn_filter_conn = qn_filter_conn, & connections_are_resonant = resonant) state%has_flows = .true. end subroutine connected_state_setup_connected_flows @ %def connected_state_setup_connected_flows @ Determine and store the flavor content for the connected state. This queries the [[matrix]] evaluator component, which should hold the requested flavor information. <>= procedure :: setup_state_flv => connected_state_setup_state_flv <>= subroutine connected_state_setup_state_flv (state, n_out_hard) class(connected_state_t), intent(inout), target :: state integer, intent(in) :: n_out_hard call state%matrix%get_flv_content (state%state_flv, n_out_hard) end subroutine connected_state_setup_state_flv @ %def connected_state_setup_state_flv @ Return the current flavor state object. <>= procedure :: get_state_flv => connected_state_get_state_flv <>= function connected_state_get_state_flv (state) result (state_flv) class(connected_state_t), intent(in) :: state type(state_flv_content_t) :: state_flv state_flv = state%state_flv end function connected_state_get_state_flv @ %def connected_state_get_state_flv @ \subsection{Cuts and expressions} Set up the [[subevt]] that corresponds to the connected interaction. The index arrays refer to the interaction. We assign the particles as follows: the beam particles are the first two (decay process: one) entries in the trace evaluator. The incoming partons are identified by their link to the outgoing partons of the structure-function chain. The outgoing partons are those of the trace evaluator, which include radiated partons during the structure-function chain. <>= procedure :: setup_subevt => connected_state_setup_subevt <>= subroutine connected_state_setup_subevt (state, sf_chain, f_beam, f_in, f_out) class(connected_state_t), intent(inout), target :: state type(sf_chain_instance_t), intent(in), target :: sf_chain type(flavor_t), dimension(:), intent(in) :: f_beam, f_in, f_out integer :: n_beam, n_in, n_out, n_vir, n_tot, i, j integer, dimension(:), allocatable :: i_beam, i_in, i_out integer :: sf_out_i type(interaction_t), pointer :: sf_int sf_int => sf_chain%get_out_int_ptr () n_beam = size (f_beam) n_in = size (f_in) n_out = size (f_out) n_vir = state%trace%get_n_vir () n_tot = state%trace%get_n_tot () allocate (i_beam (n_beam), i_in (n_in), i_out (n_out)) i_beam = [(i, i = 1, n_beam)] do j = 1, n_in sf_out_i = sf_chain%get_out_i (j) i_in(j) = interaction_find_link & (state%trace%interaction_t, sf_int, sf_out_i) end do i_out = [(i, i = n_vir + 1, n_tot)] call state%expr%setup_subevt (state%trace%interaction_t, & i_beam, i_in, i_out, f_beam, f_in, f_out) state%has_expr = .true. end subroutine connected_state_setup_subevt @ %def connected_state_setup_subevt @ Initialize the variable list specific for this state/term. We insert event variables ([[sqrts_hat]]) and link the process variable list. The variable list acquires pointers to subobjects of [[state]], which must therefore have a [[target]] attribute. <>= procedure :: setup_var_list => connected_state_setup_var_list <>= subroutine connected_state_setup_var_list (state, process_var_list, beam_data) class(connected_state_t), intent(inout), target :: state type(var_list_t), intent(in), target :: process_var_list type(beam_data_t), intent(in) :: beam_data call state%expr%setup_vars (beam_data%get_sqrts ()) call state%expr%link_var_list (process_var_list) end subroutine connected_state_setup_var_list @ %def connected_state_setup_var_list @ Allocate the cut expression etc. <>= procedure :: setup_cuts => connected_state_setup_cuts procedure :: setup_scale => connected_state_setup_scale procedure :: setup_fac_scale => connected_state_setup_fac_scale procedure :: setup_ren_scale => connected_state_setup_ren_scale procedure :: setup_weight => connected_state_setup_weight <>= subroutine connected_state_setup_cuts (state, ef_cuts) class(connected_state_t), intent(inout), target :: state class(expr_factory_t), intent(in) :: ef_cuts call state%expr%setup_selection (ef_cuts) end subroutine connected_state_setup_cuts subroutine connected_state_setup_scale (state, ef_scale) class(connected_state_t), intent(inout), target :: state class(expr_factory_t), intent(in) :: ef_scale call state%expr%setup_scale (ef_scale) end subroutine connected_state_setup_scale subroutine connected_state_setup_fac_scale (state, ef_fac_scale) class(connected_state_t), intent(inout), target :: state class(expr_factory_t), intent(in) :: ef_fac_scale call state%expr%setup_fac_scale (ef_fac_scale) end subroutine connected_state_setup_fac_scale subroutine connected_state_setup_ren_scale (state, ef_ren_scale) class(connected_state_t), intent(inout), target :: state class(expr_factory_t), intent(in) :: ef_ren_scale call state%expr%setup_ren_scale (ef_ren_scale) end subroutine connected_state_setup_ren_scale subroutine connected_state_setup_weight (state, ef_weight) class(connected_state_t), intent(inout), target :: state class(expr_factory_t), intent(in) :: ef_weight call state%expr%setup_weight (ef_weight) end subroutine connected_state_setup_weight @ %def connected_state_setup_expressions @ Reset the expression object: invalidate the subevt. <>= procedure :: reset_expressions => connected_state_reset_expressions <>= subroutine connected_state_reset_expressions (state) class(connected_state_t), intent(inout) :: state if (state%has_expr) call state%expr%reset_contents () end subroutine connected_state_reset_expressions @ %def connected_state_reset_expressions @ \subsection{Evaluation} Transfer momenta to the trace evaluator and fill the [[subevt]] with this effective kinematics, if applicable. Note: we may want to apply a boost for the [[subevt]]. <>= procedure :: receive_kinematics => parton_state_receive_kinematics <>= subroutine parton_state_receive_kinematics (state) class(parton_state_t), intent(inout), target :: state if (state%has_trace) then call state%trace%receive_momenta () select type (state) class is (connected_state_t) if (state%has_expr) then call state%expr%fill_subevt (state%trace%interaction_t) end if end select end if end subroutine parton_state_receive_kinematics @ %def parton_state_receive_kinematics @ Recover kinematics: We assume that the trace evaluator is filled with momenta. Send those momenta back to the sources, then fill the variables and subevent as above. The incoming momenta of the connected state are not connected to the isolated state but to the beam interaction. Therefore, the incoming momenta within the isolated state do not become defined, yet. Instead, we reconstruct the beam (and ISR) momentum configuration. <>= procedure :: send_kinematics => parton_state_send_kinematics <>= subroutine parton_state_send_kinematics (state) class(parton_state_t), intent(inout), target :: state if (state%has_trace) then call state%trace%send_momenta () select type (state) class is (connected_state_t) call state%expr%fill_subevt (state%trace%interaction_t) end select end if end subroutine parton_state_send_kinematics @ %def parton_state_send_kinematics @ Evaluate the expressions. The routine evaluates first the cut expression. If the event passes, it evaluates the other expressions. Where no expressions are defined, default values are inserted. <>= procedure :: evaluate_expressions => connected_state_evaluate_expressions <>= subroutine connected_state_evaluate_expressions (state, passed, & scale, fac_scale, ren_scale, weight, scale_forced, force_evaluation) class(connected_state_t), intent(inout) :: state logical, intent(out) :: passed real(default), intent(out) :: scale, weight real(default), intent(out), allocatable :: fac_scale, ren_scale real(default), intent(in), allocatable, optional :: scale_forced logical, intent(in), optional :: force_evaluation if (state%has_expr) then call state%expr%evaluate (passed, scale, fac_scale, ren_scale, weight, & scale_forced, force_evaluation) end if end subroutine connected_state_evaluate_expressions @ %def connected_state_evaluate_expressions @ Evaluate the structure-function chain, if it is allocated explicitly. The argument is the factorization scale. If the chain is merely a pointer, the chain should already be evaluated at this point. <>= procedure :: evaluate_sf_chain => isolated_state_evaluate_sf_chain <>= subroutine isolated_state_evaluate_sf_chain (state, fac_scale) class(isolated_state_t), intent(inout) :: state real(default), intent(in) :: fac_scale if (state%sf_chain_is_allocated) call state%sf_chain_eff%evaluate (fac_scale) end subroutine isolated_state_evaluate_sf_chain @ %def isolated_state_evaluate_sf_chain @ Evaluate the trace. <>= procedure :: evaluate_trace => parton_state_evaluate_trace <>= subroutine parton_state_evaluate_trace (state) class(parton_state_t), intent(inout) :: state if (state%has_trace) call state%trace%evaluate () end subroutine parton_state_evaluate_trace @ %def parton_state_evaluate_trace <>= procedure :: evaluate_matrix => parton_state_evaluate_matrix <>= subroutine parton_state_evaluate_matrix (state) class(parton_state_t), intent(inout) :: state if (state%has_matrix) call state%matrix%evaluate () end subroutine parton_state_evaluate_matrix @ %def parton_state_evaluate_matrix @ Evaluate the extra evaluators that we need for physical events. <>= procedure :: evaluate_event_data => parton_state_evaluate_event_data <>= subroutine parton_state_evaluate_event_data (state, only_momenta) class(parton_state_t), intent(inout) :: state logical, intent(in), optional :: only_momenta logical :: only_mom only_mom = .false.; if (present (only_momenta)) only_mom = only_momenta select type (state) type is (connected_state_t) if (state%has_flows_sf) then call state%flows_sf%receive_momenta () if (.not. only_mom) call state%flows_sf%evaluate () end if end select if (state%has_matrix) then call state%matrix%receive_momenta () if (.not. only_mom) call state%matrix%evaluate () end if if (state%has_flows) then call state%flows%receive_momenta () if (.not. only_mom) call state%flows%evaluate () end if end subroutine parton_state_evaluate_event_data @ %def parton_state_evaluate_event_data @ Normalize the helicity density matrix by its trace, i.e., factor out the trace and put it into an overall normalization factor. The trace and flow evaluators are unchanged. <>= procedure :: normalize_matrix_by_trace => & parton_state_normalize_matrix_by_trace <>= subroutine parton_state_normalize_matrix_by_trace (state) class(parton_state_t), intent(inout) :: state if (state%has_matrix) call state%matrix%normalize_by_trace () end subroutine parton_state_normalize_matrix_by_trace @ %def parton_state_normalize_matrix_by_trace @ \subsection{Accessing the state} Three functions return a pointer to the event-relevant interactions. <>= procedure :: get_trace_int_ptr => parton_state_get_trace_int_ptr procedure :: get_matrix_int_ptr => parton_state_get_matrix_int_ptr procedure :: get_flows_int_ptr => parton_state_get_flows_int_ptr <>= function parton_state_get_trace_int_ptr (state) result (ptr) class(parton_state_t), intent(in), target :: state type(interaction_t), pointer :: ptr if (state%has_trace) then ptr => state%trace%interaction_t else ptr => null () end if end function parton_state_get_trace_int_ptr function parton_state_get_matrix_int_ptr (state) result (ptr) class(parton_state_t), intent(in), target :: state type(interaction_t), pointer :: ptr if (state%has_matrix) then ptr => state%matrix%interaction_t else ptr => null () end if end function parton_state_get_matrix_int_ptr function parton_state_get_flows_int_ptr (state) result (ptr) class(parton_state_t), intent(in), target :: state type(interaction_t), pointer :: ptr if (state%has_flows) then ptr => state%flows%interaction_t else ptr => null () end if end function parton_state_get_flows_int_ptr @ %def parton_state_get_trace_int_ptr @ %def parton_state_get_matrix_int_ptr @ %def parton_state_get_flows_int_ptr @ Return the indices of the beam particles and the outgoing particles within the trace (and thus, matrix and flows) evaluator, respectively. <>= procedure :: get_beam_index => connected_state_get_beam_index procedure :: get_in_index => connected_state_get_in_index <>= subroutine connected_state_get_beam_index (state, i_beam) class(connected_state_t), intent(in) :: state integer, dimension(:), intent(out) :: i_beam call state%expr%get_beam_index (i_beam) end subroutine connected_state_get_beam_index subroutine connected_state_get_in_index (state, i_in) class(connected_state_t), intent(in) :: state integer, dimension(:), intent(out) :: i_in call state%expr%get_in_index (i_in) end subroutine connected_state_get_in_index @ %def connected_state_get_beam_index @ %def connected_state_get_in_index @ <>= public :: refill_evaluator <>= subroutine refill_evaluator (sqme, qn, flv_index, evaluator) complex(default), intent(in), dimension(:) :: sqme type(quantum_numbers_t), intent(in), dimension(:,:) :: qn integer, intent(in), dimension(:), optional :: flv_index type(evaluator_t), intent(inout) :: evaluator integer :: i, i_flv do i = 1, size (sqme) if (present (flv_index)) then i_flv = flv_index(i) else i_flv = i end if call evaluator%add_to_matrix_element (qn(:,i_flv), sqme(i), & match_only_flavor = .true.) end do end subroutine refill_evaluator @ %def refill_evaluator @ Return the number of outgoing (hard) particles for the state. <>= procedure :: get_n_out => parton_state_get_n_out <>= function parton_state_get_n_out (state) result (n) class(parton_state_t), intent(in), target :: state integer :: n n = state%trace%get_n_out () end function parton_state_get_n_out @ %def parton_state_get_n_out @ \subsection{Unit tests} <<[[parton_states_ut.f90]]>>= <> module parton_states_ut use unit_tests use parton_states_uti <> <> contains <> end module parton_states_ut @ %def parton_states_ut <<[[parton_states_uti.f90]]>>= <> module parton_states_uti <> <> use constants, only: zero use numeric_utils use flavors use colors use helicities use quantum_numbers use sf_base, only: sf_chain_instance_t use state_matrices, only: state_matrix_t use prc_template_me, only: prc_template_me_t use interactions, only: interaction_t use models, only: model_t, create_test_model use parton_states <> <> contains <> end module parton_states_uti @ %def parton_states_uti @ <>= public :: parton_states_test <>= subroutine parton_states_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine parton_states_test @ %def parton_states_test @ \subsubsection{Test a simple isolated state} <>= call test (parton_states_1, "parton_states_1", & "Create a 2 -> 2 isolated state and compute trace", & u, results) <>= public :: parton_states_1 <>= subroutine parton_states_1 (u) integer, intent(in) :: u type(state_matrix_t), allocatable :: state type(flavor_t), dimension(2) :: flv_in type(flavor_t), dimension(2) :: flv_out1, flv_out2 type(flavor_t), dimension(4) :: flv_tot type(helicity_t), dimension(4) :: hel type(color_t), dimension(4) :: col integer :: h1, h2, h3, h4 integer :: f integer :: i type(quantum_numbers_t), dimension(4) :: qn type(prc_template_me_t) :: core type(sf_chain_instance_t), target :: sf_chain type(interaction_t), target :: int type(isolated_state_t) :: isolated_state integer :: n_states = 0 integer, dimension(:), allocatable :: col_flow_index type(quantum_numbers_mask_t), dimension(2) :: qn_mask integer, dimension(8) :: i_allowed_states complex(default), dimension(8) :: me complex(default) :: me_check_tot, me_check_1, me_check_2, me2 logical :: tmp1, tmp2 type(model_t), pointer :: test_model => null () write (u, "(A)") "* Test output: parton_states_1" write (u, "(A)") "* Purpose: Test the standard parton states" write (u, "(A)") call flv_in%init ([11, -11]) call flv_out1%init ([1, -1]) call flv_out2%init ([2, -2]) write (u, "(A)") "* Using incoming flavors: " call flavor_write_array (flv_in, u) write (u, "(A)") "* Two outgoing flavor structures: " call flavor_write_array (flv_out1, u) call flavor_write_array (flv_out2, u) write (u, "(A)") "* Initialize state matrix" allocate (state) call state%init () write (u, "(A)") "* Fill state matrix" call col(3)%init ([1]) call col(4)%init ([-1]) do f = 1, 2 do h1 = -1, 1, 2 do h2 = -1, 1, 2 do h3 = -1, 1, 2 do h4 = -1, 1, 2 n_states = n_states + 1 call hel%init ([h1, h2, h3, h4], [h1, h2, h3, h4]) if (f == 1) then flv_tot = [flv_in, flv_out1] else flv_tot = [flv_in, flv_out2] end if call qn%init (flv_tot, col, hel) call state%add_state (qn) end do end do end do end do end do !!! Two flavors, one color flow, 2 x 2 x 2 x 2 helicity configurations !!! -> 32 states. write (u, "(A)") write (u, "(A,I2)") "* Generated number of states: ", n_states call state%freeze () !!! Indices of the helicity configurations which are non-zero i_allowed_states = [6, 7, 10, 11, 22, 23, 26, 27] me = [cmplx (-1.89448E-5_default, 9.94456E-7_default, default), & cmplx (-8.37887E-2_default, 4.30842E-3_default, default), & cmplx (-1.99997E-1_default, -1.01985E-2_default, default), & cmplx ( 1.79717E-5_default, 9.27038E-7_default, default), & cmplx (-1.74859E-5_default, 8.78819E-7_default, default), & cmplx ( 1.67577E-1_default, -8.61683E-3_default, default), & cmplx ( 2.41331E-1_default, 1.23306E-2_default, default), & cmplx (-3.59435E-5_default, -1.85407E-6_default, default)] me_check_tot = cmplx (zero, zero, default) me_check_1 = cmplx (zero, zero, default) me_check_2 = cmplx (zero, zero, default) do i = 1, 8 me2 = me(i) * conjg (me(i)) me_check_tot = me_check_tot + me2 if (i < 5) then me_check_1 = me_check_1 + me2 else me_check_2 = me_check_2 + me2 end if call state%set_matrix_element (i_allowed_states(i), me(i)) end do !!! Do not forget the color factor me_check_tot = 3._default * me_check_tot me_check_1 = 3._default * me_check_1 me_check_2 = 3._default * me_check_2 write (u, "(A)") write (u, "(A)") "* Setup interaction" call int%basic_init (2, 0, 2, set_relations = .true.) call int%set_state_matrix (state) core%data%n_in = 2; core%data%n_out = 2 core%data%n_flv = 2 allocate (core%data%flv_state (4, 2)) core%data%flv_state (1, :) = [11, 11] core%data%flv_state (2, :) = [-11, -11] core%data%flv_state (3, :) = [1, 2] core%data%flv_state (4, :) = [-1, -2] core%use_color_factors = .false. core%nc = 3 write (u, "(A)") "* Init isolated state" call isolated_state%init (sf_chain, int) !!! There is only one color flow. allocate (col_flow_index (n_states)); col_flow_index = 1 call qn_mask%init (.false., .false., .true., mask_cg = .false.) write (u, "(A)") "* Give a trace to the isolated state" call isolated_state%setup_square_trace (core, qn_mask, col_flow_index, .false.) call isolated_state%evaluate_trace () write (u, "(A)") write (u, "(A)", advance = "no") "* Squared matrix element correct: " write (u, "(L1)") nearly_equal (me_check_tot, & isolated_state%trace%get_matrix_element (1), rel_smallness = 0.00001_default) write (u, "(A)") "* Give a matrix to the isolated state" call create_test_model (var_str ("SM"), test_model) call isolated_state%setup_square_matrix (core, test_model, qn_mask, col_flow_index) call isolated_state%evaluate_matrix () write (u, "(A)") "* Sub-matrixelements correct: " tmp1 = nearly_equal (me_check_1, & isolated_state%matrix%get_matrix_element (1), rel_smallness = 0.00001_default) tmp2 = nearly_equal (me_check_2, & isolated_state%matrix%get_matrix_element (2), rel_smallness = 0.00001_default) write (u, "(A,L1,A,L1)") "* 1: ", tmp1, ", 2: ", tmp2 write (u, "(A)") "* Test output end: parton_states_1" end subroutine parton_states_1 @ %def parton_states_1 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Process component management} This module contains tools for managing and combining process components and matrix-element code and values, acting at a level below the actual process definition. \subsection{Abstract base type} The types introduced here are abstract base types. <<[[pcm_base.f90]]>>= <> module pcm_base <> use io_units use diagnostics use format_utils, only: write_integer_array use format_utils, only: write_separator use physics_defs, only: BORN, NLO_REAL <> use os_interface, only: os_data_t use process_libraries, only: process_component_def_t use process_libraries, only: process_library_t use prc_core_def use prc_core use variables, only: var_list_t use mappings, only: mapping_defaults_t use phs_base, only: phs_config_t use phs_forests, only: phs_parameters_t use mci_base, only: mci_t use model_data, only: model_data_t use models, only: model_t use blha_config, only: blha_master_t use blha_olp_interfaces, only: blha_template_t use process_config use process_mci, only: process_mci_entry_t <> <> <> <> <> contains <> end module pcm_base @ %def pcm_base @ \subsection{Core management} This object holds information about the cores used by the components and allocates the corresponding manager instance. [[i_component]] is the index of the process component which this core belongs to. The pointer to the core definition is a convenient help in configuring the core itself. We allow for a [[blha_config]] configuration object that covers BLHA cores. The BLHA standard is suitable generic to warrant support outside of specific type extension (i.e., applies to LO and NLO if requested). The BLHA configuration is allocated only if the core requires it. <>= public :: core_entry_t <>= type :: core_entry_t integer :: i_component = 0 logical :: active = .false. class(prc_core_def_t), pointer :: core_def => null () type(blha_template_t), allocatable :: blha_config class(prc_core_t), allocatable :: core contains <> end type core_entry_t @ %def core_entry_t @ <>= procedure :: get_core_ptr => core_entry_get_core_ptr <>= function core_entry_get_core_ptr (core_entry) result (core) class(core_entry_t), intent(in), target :: core_entry class(prc_core_t), pointer :: core if (allocated (core_entry%core)) then core => core_entry%core else core => null () end if end function core_entry_get_core_ptr @ %def core_entry_get_core_ptr @ Configure the core object after allocation with correct type. The [[core_def]] object pointer and the index [[i_component]] of the associated process component are already there. <>= procedure :: configure => core_entry_configure <>= subroutine core_entry_configure (core_entry, lib, id) class(core_entry_t), intent(inout) :: core_entry type(process_library_t), intent(in), target :: lib type(string_t), intent(in) :: id call core_entry%core%init & (core_entry%core_def, lib, id, core_entry%i_component) end subroutine core_entry_configure @ %def core_entry_configure @ \subsection{Process component manager} The process-component manager [[pcm]] is the master component of the [[process_t]] object. It serves two purposes: \begin{enumerate} \item It holds configuration data which allow us to centrally manage the components, terms, etc.\ of the process object. \item It implements the methods that realize the algorithm for constructing the process object and computing an integral. This algorithm makes use of the data stored within [[pcm]]. \end{enumerate} To this end, the object is abstract and polymorphic. The two extensions that we support, implement (a) default tree-level calculation, optionally including a sum over sub-processes with different particle content, or (b) the FKS-NLO subtraction algorithm for QCD-corrected processes. In both cases, the type extensions may hold suitable further data. Data included in the base type: The number of components determines the [[component_selected]] array. [[i_phs_config]] is a lookup table that holds the PHS configuration index for a given component index. [[i_core]] is a lookup table that holds the core-entry index for a given component index. [[i_mci]] is a lookup table that holds the integrator (MCI) index for a given component index. <>= public :: pcm_t <>= type, abstract :: pcm_t logical :: initialized = .false. logical :: has_pdfs = .false. integer :: n_components = 0 integer :: n_cores = 0 integer :: n_mci = 0 logical, dimension(:), allocatable :: component_selected logical, dimension(:), allocatable :: component_active integer, dimension(:), allocatable :: i_phs_config integer, dimension(:), allocatable :: i_core integer, dimension(:), allocatable :: i_mci type(blha_template_t) :: blha_defaults logical :: uses_blha = .false. type(os_data_t) :: os_data contains <> end type pcm_t @ %def pcm_t @ The factory method. We use the [[inout]] intent, so calling this again is an error. <>= procedure(pcm_allocate_workspace), deferred :: allocate_workspace <>= abstract interface subroutine pcm_allocate_workspace (pcm, work) import class(pcm_t), intent(in) :: pcm class(pcm_workspace_t), intent(inout), allocatable :: work end subroutine pcm_allocate_workspace end interface @ %def pcm_allocate_workspace @ <>= procedure(pcm_is_nlo), deferred :: is_nlo <>= abstract interface function pcm_is_nlo (pcm) result (is_nlo) import logical :: is_nlo class(pcm_t), intent(in) :: pcm end function pcm_is_nlo end interface @ %def pcm_is_nlo @ <>= procedure(pcm_final), deferred :: final <>= abstract interface subroutine pcm_final (pcm) import class(pcm_t), intent(inout) :: pcm end subroutine pcm_final end interface @ %def pcm_final @ \subsection{Initialization methods} The PCM has the duty to coordinate and configure the process-object components. Initialize the PCM configuration itself, using environment data. <>= procedure(pcm_init), deferred :: init <>= abstract interface subroutine pcm_init (pcm, env, meta) import class(pcm_t), intent(out) :: pcm type(process_environment_t), intent(in) :: env type(process_metadata_t), intent(in) :: meta end subroutine pcm_init end interface @ %def pcm_init @ Initialize the BLHA configuration block, the component-independent default settings. This is to be called by [[pcm_init]]. We use the provided variable list. This block is filled regardless of whether BLHA is actually used, because why not? We use a default value for the scheme (not set in unit tests). <>= procedure :: set_blha_defaults => pcm_set_blha_defaults <>= subroutine pcm_set_blha_defaults (pcm, polarized_beams, var_list) class(pcm_t), intent(inout) :: pcm type(var_list_t), intent(in) :: var_list logical, intent(in) :: polarized_beams logical :: muon_yukawa_off real(default) :: top_yukawa type(string_t) :: ew_scheme muon_yukawa_off = & var_list%get_lval (var_str ("?openloops_switch_off_muon_yukawa")) top_yukawa = & var_list%get_rval (var_str ("blha_top_yukawa")) ew_scheme = & var_list%get_sval (var_str ("$blha_ew_scheme")) if (ew_scheme == "") ew_scheme = "Gmu" call pcm%blha_defaults%init & (polarized_beams, muon_yukawa_off, top_yukawa, ew_scheme) end subroutine pcm_set_blha_defaults @ %def pcm_set_blha_defaults @ Read the method settings from the variable list and store them in the BLHA master. The details depend on the [[pcm]] concrete type. <>= procedure(pcm_set_blha_methods), deferred :: set_blha_methods <>= abstract interface subroutine pcm_set_blha_methods (pcm, blha_master, var_list) import class(pcm_t), intent(inout) :: pcm type(blha_master_t), intent(inout) :: blha_master type(var_list_t), intent(in) :: var_list end subroutine pcm_set_blha_methods end interface @ %def pcm_set_blha_methods @ Produce the LO and NLO flavor-state tables (as far as available), as appropriate for BLHA configuration. We may inspect either the PCM itself or the array of process cores. <>= procedure(pcm_get_blha_flv_states), deferred :: get_blha_flv_states <>= abstract interface subroutine pcm_get_blha_flv_states (pcm, core_entry, flv_born, flv_real) import class(pcm_t), intent(in) :: pcm type(core_entry_t), dimension(:), intent(in) :: core_entry integer, dimension(:,:), allocatable, intent(out) :: flv_born integer, dimension(:,:), allocatable, intent(out) :: flv_real end subroutine pcm_get_blha_flv_states end interface @ %def pcm_get_blha_flv_states @ Allocate the right number of process components. The number is also stored in the process meta. Initially, all components are active but none are selected. <>= procedure :: allocate_components => pcm_allocate_components <>= subroutine pcm_allocate_components (pcm, comp, meta) class(pcm_t), intent(inout) :: pcm type(process_component_t), dimension(:), allocatable, intent(out) :: comp type(process_metadata_t), intent(in) :: meta pcm%n_components = meta%n_components allocate (comp (pcm%n_components)) allocate (pcm%component_selected (pcm%n_components), source = .false.) allocate (pcm%component_active (pcm%n_components), source = .true.) end subroutine pcm_allocate_components @ %def pcm_allocate_components @ Each process component belongs to a category/type, which we identify by a universal integer constant. The categories can be taken from the process definition. For easy lookup, we store the categories in an array. <>= procedure(pcm_categorize_components), deferred :: categorize_components <>= abstract interface subroutine pcm_categorize_components (pcm, config) import class(pcm_t), intent(inout) :: pcm type(process_config_data_t), intent(in) :: config end subroutine pcm_categorize_components end interface @ %def pcm_categorize_components @ Allocate the right number and type(s) of process-core objects, i.e., the interface object between the process and matrix-element code. Within the [[pcm]] block, also associate cores with components and store relevant configuration data, including the [[i_core]] lookup table. <>= procedure(pcm_allocate_cores), deferred :: allocate_cores <>= abstract interface subroutine pcm_allocate_cores (pcm, config, core_entry) import class(pcm_t), intent(inout) :: pcm type(process_config_data_t), intent(in) :: config type(core_entry_t), dimension(:), allocatable, intent(out) :: core_entry end subroutine pcm_allocate_cores end interface @ %def pcm_allocate_cores @ Generate and interface external code for a single core, if this is required. <>= procedure(pcm_prepare_any_external_code), deferred :: & prepare_any_external_code <>= abstract interface subroutine pcm_prepare_any_external_code & (pcm, core_entry, i_core, libname, model, var_list) import class(pcm_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry integer, intent(in) :: i_core type(string_t), intent(in) :: libname type(model_data_t), intent(in), target :: model type(var_list_t), intent(in) :: var_list end subroutine pcm_prepare_any_external_code end interface @ %def pcm_prepare_any_external_code @ Prepare the BLHA configuration for a core object that requires it. This does not affect the core object, which may not yet be allocated. <>= procedure(pcm_setup_blha), deferred :: setup_blha <>= abstract interface subroutine pcm_setup_blha (pcm, core_entry) import class(pcm_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry end subroutine pcm_setup_blha end interface @ %def pcm_setup_blha @ Configure the BLHA interface for a core object that requires it. This is separate from the previous method, assuming that the [[pcm]] has to allocate the actual cores and acquire some data in-between. <>= procedure(pcm_prepare_blha_core), deferred :: prepare_blha_core <>= abstract interface subroutine pcm_prepare_blha_core (pcm, core_entry, model) import class(pcm_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry class(model_data_t), intent(in), target :: model end subroutine pcm_prepare_blha_core end interface @ %def pcm_prepare_blha_core @ Allocate and configure the MCI (multi-channel integrator) records and their relation to process components, appropriate for the algorithm implemented by [[pcm]]. Create a [[mci_t]] template: the procedure [[dispatch_mci]] is called as a factory method for allocating the [[mci_t]] object with a specific concrete type. The call may depend on the concrete [[pcm]] type. <>= public :: dispatch_mci_proc <>= abstract interface subroutine dispatch_mci_proc (mci, var_list, process_id, is_nlo) import class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo end subroutine dispatch_mci_proc end interface @ %def dispatch_mci_proc <>= procedure(pcm_setup_mci), deferred :: setup_mci procedure(pcm_call_dispatch_mci), deferred :: call_dispatch_mci <>= abstract interface subroutine pcm_setup_mci (pcm, mci_entry) import class(pcm_t), intent(inout) :: pcm type(process_mci_entry_t), & dimension(:), allocatable, intent(out) :: mci_entry end subroutine pcm_setup_mci end interface abstract interface subroutine pcm_call_dispatch_mci (pcm, & dispatch_mci, var_list, process_id, mci_template) import class(pcm_t), intent(inout) :: pcm procedure(dispatch_mci_proc) :: dispatch_mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id class(mci_t), intent(out), allocatable :: mci_template end subroutine pcm_call_dispatch_mci end interface @ %def pcm_setup_mci @ %def pcm_call_dispatch_mci @ Proceed with PCM configuration based on the core and component configuration data. Base version is empty. <>= procedure(pcm_complete_setup), deferred :: complete_setup <>= abstract interface subroutine pcm_complete_setup (pcm, core_entry, component, model) import class(pcm_t), intent(inout) :: pcm type(core_entry_t), dimension(:), intent(in) :: core_entry type(process_component_t), dimension(:), intent(inout) :: component type(model_t), intent(in), target :: model end subroutine pcm_complete_setup end interface @ %def pcm_complete_setup @ \subsubsection{Retrieve information} Return the core index that belongs to a particular component. <>= procedure :: get_i_core => pcm_get_i_core <>= function pcm_get_i_core (pcm, i_component) result (i_core) class(pcm_t), intent(in) :: pcm integer, intent(in) :: i_component integer :: i_core if (allocated (pcm%i_core)) then i_core = pcm%i_core(i_component) else i_core = 0 end if end function pcm_get_i_core @ %def pcm_get_i_core @ \subsubsection{Phase-space configuration} Allocate and initialize the right number and type(s) of phase-space configuration entries. The [[i_phs_config]] lookup table must be set accordingly. <>= procedure(pcm_init_phs_config), deferred :: init_phs_config <>= abstract interface subroutine pcm_init_phs_config & (pcm, phs_entry, meta, env, phs_par, mapping_defs) import class(pcm_t), intent(inout) :: pcm type(process_phs_config_t), & dimension(:), allocatable, intent(out) :: phs_entry type(process_metadata_t), intent(in) :: meta type(process_environment_t), intent(in) :: env type(mapping_defaults_t), intent(in) :: mapping_defs type(phs_parameters_t), intent(in) :: phs_par end subroutine pcm_init_phs_config end interface @ %def pcm_init_phs_config @ Initialize a single component. We require all process-configuration blocks, and specific templates for the phase-space and integrator configuration. We also provide the current component index [[i]] and the [[active]] flag. <>= procedure(pcm_init_component), deferred :: init_component <>= abstract interface subroutine pcm_init_component & (pcm, component, i, active, phs_config, env, meta, config) import class(pcm_t), intent(in) :: pcm type(process_component_t), intent(out) :: component integer, intent(in) :: i logical, intent(in) :: active class(phs_config_t), allocatable, intent(in) :: phs_config type(process_environment_t), intent(in) :: env type(process_metadata_t), intent(in) :: meta type(process_config_data_t), intent(in) :: config end subroutine pcm_init_component end interface @ %def pcm_init_component @ Record components in the process [[meta]] data if they have turned out to be inactive. <>= procedure :: record_inactive_components => pcm_record_inactive_components <>= subroutine pcm_record_inactive_components (pcm, component, meta) class(pcm_t), intent(inout) :: pcm type(process_component_t), dimension(:), intent(in) :: component type(process_metadata_t), intent(inout) :: meta integer :: i pcm%component_active = component%active do i = 1, pcm%n_components if (.not. component(i)%active) call meta%deactivate_component (i) end do end subroutine pcm_record_inactive_components @ %def pcm_record_inactive_components @ \subsection{Manager workspace} This object deals with the actual (squared) matrix element values. It holds any central data that are generated and/or used when calculating a particular phase-space point. Since phase-space points are associated with an integrator, we expect the instances of this type to correspond to MCI instances. <>= public :: pcm_workspace_t <>= type, abstract :: pcm_workspace_t ! class(pcm_t), pointer :: config => null () logical :: bad_point = .false. contains <> end type pcm_workspace_t @ %def pcm_workspace_t @ <>= procedure(pcm_work_final), deferred :: final <>= abstract interface subroutine pcm_work_final (pcm_work) import class(pcm_workspace_t), intent(inout) :: pcm_work end subroutine pcm_work_final end interface @ %def pcm_work_final @ <>= procedure(pcm_work_is_nlo), deferred :: is_nlo <>= abstract interface function pcm_work_is_nlo (pcm_work) result (is_nlo) import logical :: is_nlo class(pcm_workspace_t), intent(inout) :: pcm_work end function pcm_work_is_nlo end interface @ %def pcm_work_is_nlo @ <>= procedure :: link_config => pcm_work_link_config <>= subroutine pcm_work_link_config (pcm_work, config) class(pcm_workspace_t), intent(inout) :: pcm_work class(pcm_t), intent(in), target :: config pcm_work%config => config end subroutine pcm_work_link_config @ %def pcm_work_link_config @ <>= procedure :: is_valid => pcm_work_is_valid <>= function pcm_work_is_valid (pcm_work) result (valid) logical :: valid class(pcm_workspace_t), intent(in) :: pcm_work valid = .not. pcm_work%bad_point end function pcm_work_is_valid @ %def pcm_work_is_valid @ <>= procedure :: set_bad_point => pcm_work_set_bad_point <>= pure subroutine pcm_work_set_bad_point (pcm_work, bad_point) class(pcm_workspace_t), intent(inout) :: pcm_work logical, intent(in) :: bad_point pcm_work%bad_point = pcm_work%bad_point .or. bad_point end subroutine pcm_work_set_bad_point @ %def pcm_work_set_bad_point @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{The process object} <<[[process.f90]]>>= <> module process <> <> <> use io_units use format_utils, only: write_separator use constants use diagnostics use numeric_utils use lorentz use cputime use md5 use rng_base use dispatch_rng, only: dispatch_rng_factory use dispatch_rng, only: update_rng_seed_in_var_list use os_interface use sm_qcd use integration_results use mci_base use flavors use model_data use models use physics_defs use process_libraries use process_constants use particles use variables use beam_structures use beams use interactions use pdg_arrays use expr_base use sf_base use sf_mappings use resonances, only: resonance_history_t, resonance_history_set_t use prc_test_core, only: test_t use prc_core_def, only: prc_core_def_t use prc_core, only: prc_core_t, helicity_selection_t use prc_external, only: prc_external_t use prc_recola, only: prc_recola_t use blha_olp_interfaces, only: prc_blha_t, blha_template_t use prc_threshold, only: prc_threshold_t use phs_fks, only: phs_fks_config_t use phs_base use mappings, only: mapping_defaults_t use phs_forests, only: phs_parameters_t use phs_wood, only: phs_wood_config_t use dispatch_phase_space, only: dispatch_phs use blha_config, only: blha_master_t use nlo_data, only: FKS_DEFAULT, FKS_RESONANCES use parton_states, only: connected_state_t use pcm_base use pcm use process_counter use process_config use process_mci <> <> <> <> <> contains <> end module process @ %def process @ \subsection{Process status} Store counter and status information in a process object. <>= type :: process_status_t private end type process_status_t @ %def process_status_t @ \subsection{Process status} Store integration results in a process object. <>= type :: process_results_t private end type process_results_t @ %def process_results_t @ \subsection{The process type} NOTE: The description below represents the intended structure after refactoring and disentangling the FKS-NLO vs. LO algorithm dependencies. A [[process]] object is the internal representation of integration-run methods and data, as they are controlled by the user via a Sindarin script. The process object provides access to matrix elements (the actual ``process'' definitions that the user has provided before), it defines the separation into individually integrable components, and it manages phase-space construction, the actual integration over phase space, and the accumulation of results. As a workspace for individual sampling calls, we introduce an associated [[process_instance]] object type elsewhere. The [[process]] object contains data that either define the configuration or accumulate results from a complete integration pass. After successful phase-space integration, subsequent event generation is not actually represented by the [[process]] object. However, any event generation refers to an existing [[process]] object which represents a specific integration pass, and it uses a fresh [[process_instance]] workspace for calculations. The process object consists of several subobjects with their specific purposes. The corresponding types are defined below. (Technically, the subobject type definitions have to come before the process type definition, but with NOWEB magic we reverse this order here.) The [[meta]] object describes the process globally. All contents become fixed when the object is initialized. Similarly, the [[env]] component captures the (Sindarin) environment at the point where the process object is initialized. The [[config]] object holds physical and technical configuration data that are collected and derived from the environment during process initialization, and which are common to all process components. The [[pcm]] object (process-component manager) is polymorphic. This is an object which holds data which represent the process-object structure and breakdown, and it contains the methods that implement the algorithm of managing this structure, accumulating partial results, and finally collecting the pieces. Depending on the generic process type, the contents of [[pcm]] do vary. In particular, there is some base-type data content and a simple (default) extension which is designed for traditional \oMega\ matrix elements and tree-level integration, possibly with several sub-processes to sum over. The second extension is designed for the FKS phase-space and subtraction algorithm for NLO QCD, which interfaces external one-loop providers. The [[component]] subobjects are, first of all, interfaces to the original process-component definitions that have been provided by the user, which the program has already taken to produce matrix-element code and interfaces. The management of those components is deferred by [[pcm]], which contains the information that defines the role of each component. In particular, in the default (LO) version, process components correspond to distinct particle combinations which have been included in the original process definition. In the FKS-NLO version, the breakdown of a NLO process into Born, real, virtual, etc.\ components determines the setup. The [[phs_config]] subobjects hold data that allow and implement the construction of phase-space configurations. The type [[process_phs_config_t]] is a wrapper type around the concrete polymorphic [[phs_config_t]] object type, which manages phase-space construction, including some bookkeeping required for setting up multi-channel integration. In the LO case, we expect a separate entry for each independent sub-process. For the FKS-NLO algorithm, we expect several entries: a default-type entry which implements the underlying Born phase space, and additional entries which enable the construction of various real-radiation and subtraction kinematics configurations. A [[core_entry]] is the interface to existing matrix-element and interaction code. Depending on the process and its components, there may be various distinct matrix elements to compute. The [[mci_entry]] objects configure distinct MC input parameter sets and their associated (multi-channel) integrators. The [[rng_factory]] object is a single objects which constructs individual random-number generators for various tasks, in a uniform and well-defined way. The [[beam_config]] object describes the incoming particles, either the decay mother or the scattering beams. It also contains the spectrum- and structure-function setup, which has to interact with the phase-space and integrator facilities. The [[term]] subobjects break down the process in its smallest parts which appear in the calculation. For LO processes, the correspondence between terms and components is one-to-one. The FKS-NLO algorithm requires not just separation of Born, real, and virtual components but also subtraction terms, and a decomposition of the real phase space into singular regions. The general idea is that the integration results of distinct sets of terms are summed over to provide the results of individual components. This is also controlled by the [[pcm]] subobject. The [[process_status]] object is a bookkeeping device that allows us to query the status of an ongoing calculation. The [[process_results]] object collects the integration results for external use, including integration history information. <>= public :: process_t <>= type :: process_t private type(process_metadata_t) :: & meta type(process_environment_t) :: & env type(process_config_data_t) :: & config class(pcm_t), allocatable :: & pcm type(process_component_t), dimension(:), allocatable :: & component type(process_phs_config_t), dimension(:), allocatable :: & phs_entry type(core_entry_t), dimension(:), allocatable :: & core_entry type(process_mci_entry_t), dimension(:), allocatable :: & mci_entry class(rng_factory_t), allocatable :: & rng_factory type(process_beam_config_t) :: & beam_config type(process_term_t), dimension(:), allocatable :: & term type(process_status_t) :: & status type(process_results_t) :: & result contains <> end type process_t @ %def process_t @ \subsection{Process pointer} Wrapper type for storing pointers to process objects in arrays. <>= public :: process_ptr_t <>= type :: process_ptr_t type(process_t), pointer :: p => null () end type process_ptr_t @ %def process_ptr_t @ \subsection{Output} This procedure is an important debugging and inspection tool; it is not used during normal operation. The process object is written to a file (identified by unit, which may also be standard output). Optional flags determine whether we show everything or just the interesting parts. The shorthand as a traditional TBP. <>= procedure :: write => process_write <>= subroutine process_write (process, screen, unit, & show_os_data, show_var_list, show_rng, show_expressions, pacify) class(process_t), intent(in) :: process logical, intent(in) :: screen integer, intent(in), optional :: unit logical, intent(in), optional :: show_os_data logical, intent(in), optional :: show_var_list logical, intent(in), optional :: show_rng logical, intent(in), optional :: show_expressions logical, intent(in), optional :: pacify integer :: u, iostat character(0) :: iomsg integer, dimension(:), allocatable :: v_list u = given_output_unit (unit) allocate (v_list (0)) call set_flag (v_list, F_SHOW_OS_DATA, show_os_data) call set_flag (v_list, F_SHOW_VAR_LIST, show_var_list) call set_flag (v_list, F_SHOW_RNG, show_rng) call set_flag (v_list, F_SHOW_EXPRESSIONS, show_expressions) call set_flag (v_list, F_PACIFY, pacify) if (screen) then call process%write_formatted (u, "LISTDIRECTED", v_list, iostat, iomsg) else call process%write_formatted (u, "DT", v_list, iostat, iomsg) end if end subroutine process_write @ %def process_write @ Standard DTIO procedure with binding. For the particular application, the screen format is triggered by the [[LISTDIRECTED]] option for the [[iotype]] format editor string. The other options activate when the particular parameter value is found in [[v_list]]. NOTE: The DTIO [[generic]] binding is supported by gfortran since 7.0. TODO wk 2018: The default could be to show everything, and we should have separate switches for all major parts. Currently, there are only a few. <>= ! generic :: write (formatted) => write_formatted procedure :: write_formatted => process_write_formatted <>= subroutine process_write_formatted (dtv, unit, iotype, v_list, iostat, iomsg) class(process_t), intent(in) :: dtv integer, intent(in) :: unit character(*), intent(in) :: iotype integer, dimension(:), intent(in) :: v_list integer, intent(out) :: iostat character(*), intent(inout) :: iomsg integer :: u logical :: screen logical :: var_list logical :: rng_factory logical :: expressions logical :: counters logical :: os_data logical :: model logical :: pacify integer :: i u = unit select case (iotype) case ("LISTDIRECTED") screen = .true. case default screen = .false. end select var_list = flagged (v_list, F_SHOW_VAR_LIST) rng_factory = flagged (v_list, F_SHOW_RNG, .true.) expressions = flagged (v_list, F_SHOW_EXPRESSIONS) counters = .true. os_data = flagged (v_list, F_SHOW_OS_DATA) model = .false. pacify = flagged (v_list, F_PACIFY) associate (process => dtv) if (screen) then write (msg_buffer, "(A)") repeat ("-", 72) call msg_message () else call write_separator (u, 2) end if call process%meta%write (u, screen) if (var_list) then call process%env%write (u, show_var_list=var_list, & show_model=.false., show_lib=.false., & show_os_data=os_data) else if (.not. screen) then write (u, "(1x,A)") "Variable list: [not shown]" end if if (process%meta%type == PRC_UNKNOWN) then call write_separator (u, 2) return else if (screen) then return end if call write_separator (u) call process%config%write (u, counters, model, expressions) if (rng_factory) then if (allocated (process%rng_factory)) then call write_separator (u) call process%rng_factory%write (u) end if end if call write_separator (u, 2) if (allocated (process%component)) then write (u, "(1x,A)") "Process component configuration:" do i = 1, size (process%component) call write_separator (u) call process%component(i)%write (u) end do else write (u, "(1x,A)") "Process component configuration: [undefined]" end if call write_separator (u, 2) if (allocated (process%term)) then write (u, "(1x,A)") "Process term configuration:" do i = 1, size (process%term) call write_separator (u) call process%term(i)%write (u) end do else write (u, "(1x,A)") "Process term configuration: [undefined]" end if call write_separator (u, 2) call process%beam_config%write (u) call write_separator (u, 2) if (allocated (process%mci_entry)) then write (u, "(1x,A)") "Multi-channel integrator configurations:" do i = 1, size (process%mci_entry) call write_separator (u) write (u, "(1x,A,I0,A)") "MCI #", i, ":" call process%mci_entry(i)%write (u, pacify) end do end if call write_separator (u, 2) end associate iostat = 0 iomsg = "" end subroutine process_write_formatted @ %def process_write_formatted @ <>= procedure :: write_meta => process_write_meta <>= subroutine process_write_meta (process, unit, testflag) class(process_t), intent(in) :: process integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u, i u = given_output_unit (unit) select case (process%meta%type) case (PRC_UNKNOWN) write (u, "(1x,A)") "Process instance [undefined]" return case (PRC_DECAY) write (u, "(1x,A)", advance="no") "Process instance [decay]:" case (PRC_SCATTERING) write (u, "(1x,A)", advance="no") "Process instance [scattering]:" case default call msg_bug ("process_instance_write: undefined process type") end select write (u, "(1x,A,A,A)") "'", char (process%meta%id), "'" write (u, "(3x,A,A,A)") "Run ID = '", char (process%meta%run_id), "'" if (allocated (process%meta%component_id)) then write (u, "(3x,A)") "Process components:" do i = 1, size (process%meta%component_id) if (process%pcm%component_selected(i)) then write (u, "(3x,'*')", advance="no") else write (u, "(4x)", advance="no") end if write (u, "(1x,I0,9A)") i, ": '", & char (process%meta%component_id (i)), "': ", & char (process%meta%component_description (i)) end do end if end subroutine process_write_meta @ %def process_write_meta @ Screen output. Write a short account of the process configuration and the current results. The verbose version lists the components, the short version just the results. <>= procedure :: show => process_show <>= subroutine process_show (object, unit, verbose) class(process_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u logical :: verb real(default) :: err_percent u = given_output_unit (unit) verb = .true.; if (present (verbose)) verb = verbose if (verb) then call object%meta%show (u, object%config%model%get_name ()) select case (object%meta%type) case (PRC_DECAY) write (u, "(2x,A)", advance="no") "Computed width =" case (PRC_SCATTERING) write (u, "(2x,A)", advance="no") "Computed cross section =" case default; return end select else if (object%meta%run_id /= "") then write (u, "('Run',1x,A,':',1x)", advance="no") & char (object%meta%run_id) end if write (u, "(A)", advance="no") char (object%meta%id) select case (object%meta%num_id) case (0) write (u, "(':')") case default write (u, "(1x,'(',I0,')',':')") object%meta%num_id end select write (u, "(2x)", advance="no") end if if (object%has_integral_tot ()) then write (u, "(ES14.7,1x,'+-',ES9.2)", advance="no") & object%get_integral_tot (), object%get_error_tot () select case (object%meta%type) case (PRC_DECAY) write (u, "(1x,A)", advance="no") "GeV" case (PRC_SCATTERING) write (u, "(1x,A)", advance="no") "fb " case default write (u, "(1x,A)", advance="no") " " end select if (object%get_integral_tot () /= 0) then err_percent = abs (100 & * object%get_error_tot () / object%get_integral_tot ()) else err_percent = 0 end if if (err_percent == 0) then write (u, "(1x,'(',F4.0,4x,'%)')") err_percent else if (err_percent < 0.1) then write (u, "(1x,'(',F7.3,1x,'%)')") err_percent else if (err_percent < 1) then write (u, "(1x,'(',F6.2,2x,'%)')") err_percent else if (err_percent < 10) then write (u, "(1x,'(',F5.1,3x,'%)')") err_percent else write (u, "(1x,'(',F4.0,4x,'%)')") err_percent end if else write (u, "(A)") "[integral undefined]" end if end subroutine process_show @ %def process_show @ Finalizer. Explicitly iterate over all subobjects that may contain allocated pointers. TODO wk 2018 (workaround): The finalizer for the [[config_data]] component is not called. The reason is that this deletes model data local to the process, but these could be referenced by pointers (flavor objects) from some persistent event record. Obviously, such side effects should be avoided, but this requires refactoring the event-handling procedures. <>= procedure :: final => process_final <>= subroutine process_final (process) class(process_t), intent(inout) :: process integer :: i ! call process%meta%final () call process%env%final () ! call process%config%final () if (allocated (process%component)) then do i = 1, size (process%component) call process%component(i)%final () end do end if if (allocated (process%term)) then do i = 1, size (process%term) call process%term(i)%final () end do end if call process%beam_config%final () if (allocated (process%mci_entry)) then do i = 1, size (process%mci_entry) call process%mci_entry(i)%final () end do end if if (allocated (process%pcm)) then call process%pcm%final () deallocate (process%pcm) end if end subroutine process_final @ %def process_final @ \subsubsection{Process setup} Initialize a process. We need a process library [[lib]] and the process identifier [[proc_id]] (string). We will fetch the current run ID from the variable list [[var_list]]. We collect all important data from the environment and store them in the appropriate places. OS data, model, and variable list are copied into [[env]] (true snapshot), also the process library (pointer only). The [[meta]] subobject is initialized with process ID and attributes taken from the process library. We initialize the [[config]] subobject with all data that are relevant for this run, using the settings from [[env]]. These data determine the MD5 sum for this run, which allows us to identify the setup and possibly skips in a later re-run. We also allocate and initialize the embedded RNG factory. We take the seed from the [[var_list]], and we should return the [[var_list]] to the caller with a new seed. Finally, we allocate the process component manager [[pcm]], which implements the chosen algorithm for process integration. The first task of the manager is to allocate the component array and to determine the component categories (e.g., Born/Virtual etc.). TODO wk 2018: The [[pcm]] dispatcher should be provided by the caller, if we eventually want to eliminate dependencies on concrete [[pcm_t]] extensions. <>= procedure :: init => process_init <>= subroutine process_init & (process, proc_id, lib, os_data, model, var_list, beam_structure) class(process_t), intent(out) :: process type(string_t), intent(in) :: proc_id type(process_library_t), intent(in), target :: lib type(os_data_t), intent(in) :: os_data class(model_t), intent(in), target :: model type(var_list_t), intent(inout), target, optional :: var_list type(beam_structure_t), intent(in), optional :: beam_structure integer :: next_rng_seed if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "process_init") associate & (meta => process%meta, env => process%env, config => process%config) call env%init & (model, lib, os_data, var_list, beam_structure) call meta%init & (proc_id, lib, env%get_var_list_ptr ()) call config%init & (meta, env) call dispatch_rng_factory & (process%rng_factory, env%get_var_list_ptr (), next_rng_seed) call update_rng_seed_in_var_list (var_list, next_rng_seed) call dispatch_pcm & (process%pcm, config%process_def%is_nlo ()) associate (pcm => process%pcm) call pcm%init (env, meta) call pcm%allocate_components (process%component, meta) call pcm%categorize_components (config) end associate end associate end subroutine process_init @ %def process_init @ \subsection{Process component manager} The [[pcm]] (read: process-component manager) takes the responsibility of steering the actual algorithm of configuration and integration. Depending on the concrete type, different algorithms can be implemented. The first version of this supports just two implementations: leading-order (tree-level) integration and event generation, and NLO (QCD/FKS subtraction). We thus can start with a single logical for steering the dispatcher. TODO wk 2018: Eventually, we may eliminate all references to the extensions of [[pcm_t]] from this module and therefore move this outside the module as well. <>= subroutine dispatch_pcm (pcm, is_nlo) class(pcm_t), allocatable, intent(out) :: pcm logical, intent(in) :: is_nlo if (.not. is_nlo) then allocate (pcm_default_t :: pcm) else allocate (pcm_nlo_t :: pcm) end if end subroutine dispatch_pcm @ %def dispatch_pcm @ This step is performed after phase-space and core objects are done: collect all missing information and prepare the process component manager for the appropriate integration algorithm. <>= procedure :: complete_pcm_setup => process_complete_pcm_setup <>= subroutine process_complete_pcm_setup (process) class(process_t), intent(inout) :: process call process%pcm%complete_setup & (process%core_entry, process%component, process%env%get_model_ptr ()) end subroutine process_complete_pcm_setup @ %def process_complete_pcm_setup @ \subsection{Core management} Allocate cores (interface objects to matrix-element code). The [[dispatch_core]] procedure is taken as an argument, so we do not depend on the implementation, and thus on the specific core types. The [[helicity_selection]] object collects data that the matrix-element code needs for configuring the appropriate behavior. After the cores have been allocated, and assuming the phs initial configuration has been done before, we proceed with computing the [[pcm]] internal data. <>= procedure :: setup_cores => process_setup_cores <>= subroutine process_setup_cores (process, dispatch_core, & helicity_selection, use_color_factors, has_beam_pol) class(process_t), intent(inout) :: process procedure(dispatch_core_proc) :: dispatch_core type(helicity_selection_t), intent(in), optional :: helicity_selection logical, intent(in), optional :: use_color_factors logical, intent(in), optional :: has_beam_pol integer :: i associate (pcm => process%pcm) call pcm%allocate_cores (process%config, process%core_entry) do i = 1, size (process%core_entry) call dispatch_core (process%core_entry(i)%core, & process%core_entry(i)%core_def, & process%config%model, & helicity_selection, & process%config%qcd, & use_color_factors, & has_beam_pol) call process%core_entry(i)%configure & (process%env%get_lib_ptr (), process%meta%id) if (process%core_entry(i)%core%uses_blha ()) then call pcm%setup_blha (process%core_entry(i)) end if end do end associate end subroutine process_setup_cores @ %def process_setup_cores <>= abstract interface subroutine dispatch_core_proc (core, core_def, model, & helicity_selection, qcd, use_color_factors, has_beam_pol) import class(prc_core_t), allocatable, intent(inout) :: core class(prc_core_def_t), intent(in) :: core_def class(model_data_t), intent(in), target, optional :: model type(helicity_selection_t), intent(in), optional :: helicity_selection type(qcd_t), intent(in), optional :: qcd logical, intent(in), optional :: use_color_factors logical, intent(in), optional :: has_beam_pol end subroutine dispatch_core_proc end interface @ %def dispatch_core_proc @ Use the [[pcm]] to initialize the BLHA interface for each core which requires it. <>= procedure :: prepare_blha_cores => process_prepare_blha_cores <>= subroutine process_prepare_blha_cores (process) class(process_t), intent(inout), target :: process integer :: i associate (pcm => process%pcm) do i = 1, size (process%core_entry) associate (core_entry => process%core_entry(i)) if (core_entry%core%uses_blha ()) then pcm%uses_blha = .true. call pcm%prepare_blha_core (core_entry, process%config%model) end if end associate end do end associate end subroutine process_prepare_blha_cores @ %def process_prepare_blha_cores @ Create the BLHA interface data, using PCM for specific data, and write the BLHA contract file(s). We take various configuration data and copy them to the [[blha_master]] record, which then creates and writes the contracts. For assigning the QCD/EW coupling powers, we inspect the first process component only. The other parameters are taken as-is from the process environment variables. <>= procedure :: create_blha_interface => process_create_blha_interface <>= subroutine process_create_blha_interface (process) class(process_t), intent(inout) :: process integer :: alpha_power, alphas_power integer :: openloops_phs_tolerance, openloops_stability_log logical :: use_cms type(string_t) :: ew_scheme, correction_type type(string_t) :: openloops_extra_cmd type(blha_master_t) :: blha_master integer, dimension(:,:), allocatable :: flv_born, flv_real if (process%pcm%uses_blha) then call collect_configuration_parameters (process%get_var_list_ptr ()) call process%component(1)%config%get_coupling_powers & (alpha_power, alphas_power) associate (pcm => process%pcm) call pcm%set_blha_methods (blha_master, process%get_var_list_ptr ()) call blha_master%set_ew_scheme (ew_scheme) call blha_master%allocate_config_files () call blha_master%set_correction_type (correction_type) call blha_master%setup_additional_features ( & openloops_phs_tolerance, & use_cms, & openloops_stability_log, & extra_cmd = openloops_extra_cmd, & beam_structure = process%env%get_beam_structure ()) call pcm%get_blha_flv_states (process%core_entry, flv_born, flv_real) call blha_master%set_photon_characteristics (flv_born, process%config%n_in) call blha_master%generate (process%meta%id, & process%config%model, process%config%n_in, & alpha_power, alphas_power, & flv_born, flv_real) call blha_master%write_olp (process%meta%id) end associate end if contains subroutine collect_configuration_parameters (var_list) type(var_list_t), intent(in) :: var_list openloops_phs_tolerance = & var_list%get_ival (var_str ("openloops_phs_tolerance")) openloops_stability_log = & var_list%get_ival (var_str ("openloops_stability_log")) use_cms = & var_list%get_lval (var_str ("?openloops_use_cms")) ew_scheme = & var_list%get_sval (var_str ("$blha_ew_scheme")) correction_type = & var_list%get_sval (var_str ("$nlo_correction_type")) openloops_extra_cmd = & var_list%get_sval (var_str ("$openloops_extra_cmd")) end subroutine collect_configuration_parameters end subroutine process_create_blha_interface @ %def process_create_blha_interface @ Initialize the process components, one by one. We require templates for the [[mci]] (integrator) and [[phs_config]] (phase-space) configuration data. The [[active]] flag is set if the component has an associated matrix element, so we can compute it. The case of no core is a unit-test case. The specifics depend on the algorithm and are delegated to the [[pcm]] process-component manager. The optional [[phs_config]] overrides a pre-generated config array (for unit test). <>= procedure :: init_components => process_init_components <>= subroutine process_init_components (process, phs_config) class(process_t), intent(inout), target :: process class(phs_config_t), allocatable, intent(in), optional :: phs_config integer :: i, i_core class(prc_core_t), pointer :: core logical :: active associate (pcm => process%pcm) do i = 1, pcm%n_components i_core = pcm%get_i_core(i) if (i_core > 0) then core => process%get_core_ptr (i_core) active = core%has_matrix_element () else active = .true. end if select type (pcm => process%pcm) type is (pcm_nlo_t) if (pcm%use_real_partition .and. .not. pcm%use_real_singular) then if (pcm%component_type(i) == COMP_REAL_SING) then active = .false. end if end if end select if (present (phs_config)) then call pcm%init_component (process%component(i), & i, & active, & phs_config, & process%env, process%meta, process%config) else call pcm%init_component (process%component(i), & i, & active, & process%phs_entry(pcm%i_phs_config(i))%phs_config, & process%env, process%meta, process%config) end if end do end associate end subroutine process_init_components @ %def process_init_components @ If process components have turned out to be inactive, this has to be recorded in the [[meta]] block. Delegate to the [[pcm]]. <>= procedure :: record_inactive_components => process_record_inactive_components <>= subroutine process_record_inactive_components (process) class(process_t), intent(inout) :: process associate (pcm => process%pcm) call pcm%record_inactive_components (process%component, process%meta) end associate end subroutine process_record_inactive_components @ %def process_record_inactive_components @ Determine the process terms for each process component. <>= procedure :: setup_terms => process_setup_terms <>= subroutine process_setup_terms (process, with_beams) class(process_t), intent(inout), target :: process logical, intent(in), optional :: with_beams class(model_data_t), pointer :: model integer :: i, j, k, i_term integer, dimension(:), allocatable :: n_entry integer :: n_components, n_tot integer :: i_sub type(string_t) :: subtraction_method class(prc_core_t), pointer :: core => null () logical :: setup_subtraction_component, singular_real logical :: requires_spin_correlations integer :: nlo_type_to_fetch, n_emitters i_sub = 0 model => process%config%model n_components = process%meta%n_components allocate (n_entry (n_components), source = 0) do i = 1, n_components associate (component => process%component(i)) if (component%active) then n_entry(i) = 1 if (component%get_nlo_type () == NLO_REAL) then select type (pcm => process%pcm) type is (pcm_nlo_t) if (component%component_type /= COMP_REAL_FIN) & n_entry(i) = n_entry(i) + pcm%region_data%get_n_phs () end select end if end if end associate end do n_tot = sum (n_entry) allocate (process%term (n_tot)) k = 0 if (process%is_nlo_calculation ()) then i_sub = process%component(1)%config%get_associated_subtraction () subtraction_method = process%component(i_sub)%config%get_me_method () if (debug_on) call msg_debug2 & (D_PROCESS_INTEGRATION, "process_setup_terms: ", subtraction_method) end if do i = 1, n_components associate (component => process%component(i)) if (.not. component%active) cycle allocate (component%i_term (n_entry(i))) do j = 1, n_entry(i) singular_real = component%get_nlo_type () == NLO_REAL & .and. component%component_type /= COMP_REAL_FIN setup_subtraction_component = singular_real .and. j == n_entry(i) i_term = k + j component%i_term(j) = i_term if (singular_real) then process%term(i_term)%i_sub = k + n_entry(i) else process%term(i_term)%i_sub = 0 end if if (setup_subtraction_component) then select type (pcm => process%pcm) class is (pcm_nlo_t) process%term(i_term)%i_core = pcm%i_core(pcm%i_sub) end select else process%term(i_term)%i_core = process%pcm%get_i_core(i) end if if (process%term(i_term)%i_core == 0) then call msg_bug ("Process '" // char (process%get_id ()) & // "': core not found!") end if core => process%get_core_term (i_term) if (i_sub > 0) then select type (pcm => process%pcm) type is (pcm_nlo_t) requires_spin_correlations = & pcm%region_data%requires_spin_correlations () n_emitters = pcm%region_data%get_n_emitters_sc () class default requires_spin_correlations = .false. n_emitters = 0 end select if (requires_spin_correlations) then call process%term(i_term)%init ( & i_term, i, j, core, model, & nlo_type = component%config%get_nlo_type (), & use_beam_pol = with_beams, & subtraction_method = subtraction_method, & has_pdfs = process%pcm%has_pdfs, & n_emitters = n_emitters) else call process%term(i_term)%init ( & i_term, i, j, core, model, & nlo_type = component%config%get_nlo_type (), & use_beam_pol = with_beams, & subtraction_method = subtraction_method, & has_pdfs = process%pcm%has_pdfs) end if else call process%term(i_term)%init ( & i_term, i, j, core, model, & nlo_type = component%config%get_nlo_type (), & use_beam_pol = with_beams, & has_pdfs = process%pcm%has_pdfs) end if end do end associate k = k + n_entry(i) end do process%config%n_terms = n_tot end subroutine process_setup_terms @ %def process_setup_terms @ Initialize the beam setup. This is the trivial version where the incoming state of the matrix element coincides with the initial state of the process. For a scattering process, we need the c.m. energy, all other variables are set to their default values (no polarization, lab frame and c.m.\ frame coincide, etc.) We assume that all components consistently describe a scattering process, i.e., two incoming particles. Note: The current layout of the [[beam_data_t]] record requires that the flavor for each beam is unique. For processes with multiple flavors in the initial state, one has to set up beams explicitly. This restriction could be removed by extending the code in the [[beams]] module. <>= procedure :: setup_beams_sqrts => process_setup_beams_sqrts <>= subroutine process_setup_beams_sqrts (process, sqrts, beam_structure, i_core) class(process_t), intent(inout) :: process real(default), intent(in) :: sqrts type(beam_structure_t), intent(in), optional :: beam_structure integer, intent(in), optional :: i_core type(pdg_array_t), dimension(:,:), allocatable :: pdg_in integer, dimension(2) :: pdg_scattering type(flavor_t), dimension(2) :: flv_in integer :: i, i0, ic allocate (pdg_in (2, process%meta%n_components)) i0 = 0 do i = 1, process%meta%n_components if (process%component(i)%active) then if (present (i_core)) then ic = i_core else ic = process%pcm%get_i_core (i) end if associate (core => process%core_entry(ic)%core) pdg_in(:,i) = core%data%get_pdg_in () end associate if (i0 == 0) i0 = i end if end do do i = 1, process%meta%n_components if (.not. process%component(i)%active) then pdg_in(:,i) = pdg_in(:,i0) end if end do if (all (pdg_in%get_length () == 1) .and. & all (pdg_in(1,:) == pdg_in(1,i0)) .and. & all (pdg_in(2,:) == pdg_in(2,i0))) then pdg_scattering(:) = pdg_in(:,i0)%get (1) call flv_in%init (pdg_scattering, process%config%model) call process%beam_config%init_scattering (flv_in, sqrts, beam_structure) else call msg_fatal ("Setting up process '" // char (process%meta%id) // "':", & [var_str (" --------------------------------------------"), & var_str ("Inconsistent initial state. This happens if either "), & var_str ("several processes with non-matching initial states "), & var_str ("have been added, or for a single process with an "), & var_str ("initial state flavor sum. In that case, please set beams "), & var_str ("explicitly [singling out a flavor / structure function.]")]) end if end subroutine process_setup_beams_sqrts @ %def process_setup_beams_sqrts @ This is the version that applies to decay processes. The energy is the particle mass, hence no extra argument. <>= procedure :: setup_beams_decay => process_setup_beams_decay <>= subroutine process_setup_beams_decay (process, rest_frame, beam_structure, i_core) class(process_t), intent(inout), target :: process logical, intent(in), optional :: rest_frame type(beam_structure_t), intent(in), optional :: beam_structure integer, intent(in), optional :: i_core type(pdg_array_t), dimension(:,:), allocatable :: pdg_in integer, dimension(1) :: pdg_decay type(flavor_t), dimension(1) :: flv_in integer :: i, i0, ic allocate (pdg_in (1, process%meta%n_components)) i0 = 0 do i = 1, process%meta%n_components if (process%component(i)%active) then if (present (i_core)) then ic = i_core else ic = process%pcm%get_i_core (i) end if associate (core => process%core_entry(ic)%core) pdg_in(:,i) = core%data%get_pdg_in () end associate if (i0 == 0) i0 = i end if end do do i = 1, process%meta%n_components if (.not. process%component(i)%active) then pdg_in(:,i) = pdg_in(:,i0) end if end do if (all (pdg_in%get_length () == 1) & .and. all (pdg_in(1,:) == pdg_in(1,i0))) then pdg_decay(:) = pdg_in(:,i0)%get (1) call flv_in%init (pdg_decay, process%config%model) call process%beam_config%init_decay (flv_in, rest_frame, beam_structure) else call msg_fatal ("Setting up decay '" & // char (process%meta%id) // "': decaying particle not unique") end if end subroutine process_setup_beams_decay @ %def process_setup_beams_decay @ We have to make sure that the masses of the various flavors in a given position in the particle string coincide. <>= procedure :: check_masses => process_check_masses <>= subroutine process_check_masses (process) class(process_t), intent(in) :: process type(flavor_t), dimension(:), allocatable :: flv real(default), dimension(:), allocatable :: mass integer :: i, j integer :: i_component class(prc_core_t), pointer :: core do i = 1, process%get_n_terms () i_component = process%term(i)%i_component if (.not. process%component(i_component)%active) cycle core => process%get_core_term (i) associate (data => core%data) allocate (flv (data%n_flv), mass (data%n_flv)) do j = 1, data%n_in + data%n_out call flv%init (data%flv_state(j,:), process%config%model) mass = flv%get_mass () if (any (.not. nearly_equal(mass, mass(1)))) then call msg_fatal ("Process '" // char (process%meta%id) // "': " & // "mass values in flavor combination do not coincide. ") end if end do deallocate (flv, mass) end associate end do end subroutine process_check_masses @ %def process_check_masses @ Set up index mapping for [[region_data]] for singular regions equivalent w.r.t. their amplitudes. Has to be called after [[region_data]] AND the [[core]] are fully set up. For processes with structure function, subprocesses which lead to the same amplitude for the hard interaction can differ if structure functions are applied. In this case we remap flavor structures to themselves if the eqvivalent hard interaction flavor structure has no identical initial state. <>= procedure :: optimize_nlo_singular_regions => process_optimize_nlo_singular_regions <>= subroutine process_optimize_nlo_singular_regions (process) class(process_t), intent(inout) :: process class(prc_core_t), pointer :: core, core_sub integer, dimension(:), allocatable :: eqv_flv_index_born integer, dimension(:), allocatable :: eqv_flv_index_real integer, dimension(:,:), allocatable :: flv_born, flv_real integer :: i_flv, i_flv2, n_in, i integer :: i_component, i_core, i_core_sub logical :: fetched_born, fetched_real logical :: optimize fetched_born = .false.; fetched_real = .false. select type (pcm => process%pcm) type is (pcm_nlo_t) optimize = pcm%settings%reuse_amplitudes_fks if (optimize) then do i_component = 1, pcm%n_components i_core = pcm%get_i_core(i_component) core => process%get_core_ptr (i_core) if (.not. core%data_known) cycle associate (data => core%data) if (pcm%nlo_type_core(i_core) == NLO_REAL .and. & .not. pcm%component_type(i_component) == COMP_SUB) then if (allocated (core%data%eqv_flv_index)) then eqv_flv_index_real = core%get_equivalent_flv_index () fetched_real = .true. end if i_core_sub = pcm%get_i_core (pcm%i_sub) core_sub => process%get_core_ptr (i_core_sub) if (allocated (core_sub%data%eqv_flv_index)) then eqv_flv_index_born = core_sub%get_equivalent_flv_index () fetched_born = .true. end if if (fetched_born .and. fetched_real) exit end if end associate end do if (.not. fetched_born .or. .not. fetched_real) then call msg_warning('Failed to fetch flavor equivalence indices. & &Disabling singular region optimization') optimize = .false. eqv_flv_index_born = [(i, i = 1, pcm%region_data%n_flv_born)] eqv_flv_index_real = [(i, i = 1, pcm%region_data%n_flv_real)] end if if (optimize .and. pcm%has_pdfs) then flv_born = pcm%region_data%get_flv_states_born () flv_real = pcm%region_data%get_flv_states_real () n_in = pcm%region_data%n_in do i_flv = 1, size (eqv_flv_index_born) do i_flv2 = 1, i_flv if (any (flv_born(1:n_in, eqv_flv_index_born(i_flv)) /= & flv_born(1:n_in, i_flv))) then eqv_flv_index_born(i_flv) = i_flv exit end if end do end do do i_flv = 1, size (eqv_flv_index_real) do i_flv2 = 1, i_flv if (any (flv_real(1:n_in, eqv_flv_index_real(i_flv)) /= & flv_real(1:n_in, i_flv))) then eqv_flv_index_real(i_flv) = i_flv exit end if end do end do end if else eqv_flv_index_born = [(i, i = 1, pcm%region_data%n_flv_born)] eqv_flv_index_real = [(i, i = 1, pcm%region_data%n_flv_real)] end if pcm%region_data%eqv_flv_index_born = eqv_flv_index_born pcm%region_data%eqv_flv_index_real = eqv_flv_index_real call pcm%region_data%find_eqv_regions (optimize) end select end subroutine process_optimize_nlo_singular_regions @ %def process_optimize_nlo_singular_regions @ For some structure functions we need to get the list of initial state flavors. This is a two-dimensional array. The first index is the beam index, the second index is the component index. Each array element is itself a PDG array object, which consists of the list of incoming PDG values for this beam and component. <>= procedure :: get_pdg_in => process_get_pdg_in <>= subroutine process_get_pdg_in (process, pdg_in) class(process_t), intent(in), target :: process type(pdg_array_t), dimension(:,:), allocatable, intent(out) :: pdg_in integer :: i, i_core allocate (pdg_in (process%config%n_in, process%meta%n_components)) do i = 1, process%meta%n_components if (process%component(i)%active) then i_core = process%pcm%get_i_core (i) associate (core => process%core_entry(i_core)%core) pdg_in(:,i) = core%data%get_pdg_in () end associate end if end do end subroutine process_get_pdg_in @ %def process_get_pdg_in @ The phase-space configuration object, in case we need it separately. <>= procedure :: get_phs_config => process_get_phs_config <>= function process_get_phs_config (process, i_component) result (phs_config) class(phs_config_t), pointer :: phs_config class(process_t), intent(in), target :: process integer, intent(in) :: i_component if (allocated (process%component)) then phs_config => process%component(i_component)%phs_config else phs_config => null () end if end function process_get_phs_config @ %def process_get_phs_config @ The resonance history set can be extracted from the phase-space configuration. However, this is only possible if the default phase-space method (wood) has been chosen. If [[include_trivial]] is set, we include the resonance history with no resonances in the set. <>= procedure :: extract_resonance_history_set & => process_extract_resonance_history_set <>= subroutine process_extract_resonance_history_set & (process, res_set, include_trivial, i_component) class(process_t), intent(in), target :: process type(resonance_history_set_t), intent(out) :: res_set logical, intent(in), optional :: include_trivial integer, intent(in), optional :: i_component integer :: i i = 1; if (present (i_component)) i = i_component select type (phs_config => process%get_phs_config (i)) class is (phs_wood_config_t) call phs_config%extract_resonance_history_set (res_set, include_trivial) class default call msg_error ("process '" // char (process%get_id ()) & // "': extract resonance histories: phase-space method must be & &'wood'. No resonances can be determined.") end select end subroutine process_extract_resonance_history_set @ %def process_extract_resonance_history_set @ Initialize from a complete beam setup. If the beam setup does not apply directly to the process, choose a fallback option as a straight scattering or decay process. <>= procedure :: setup_beams_beam_structure => process_setup_beams_beam_structure <>= subroutine process_setup_beams_beam_structure & (process, beam_structure, sqrts, decay_rest_frame) class(process_t), intent(inout) :: process type(beam_structure_t), intent(in) :: beam_structure real(default), intent(in) :: sqrts logical, intent(in), optional :: decay_rest_frame integer :: n_in logical :: applies n_in = process%get_n_in () call beam_structure%check_against_n_in (process%get_n_in (), applies) if (applies) then call process%beam_config%init_beam_structure & (beam_structure, sqrts, process%get_model_ptr (), decay_rest_frame) else if (n_in == 2) then call process%setup_beams_sqrts (sqrts, beam_structure) else call process%setup_beams_decay (decay_rest_frame, beam_structure) end if end subroutine process_setup_beams_beam_structure @ %def process_setup_beams_beam_structure @ Notify the user about beam setup. <>= procedure :: beams_startup_message => process_beams_startup_message <>= subroutine process_beams_startup_message (process, unit, beam_structure) class(process_t), intent(in) :: process integer, intent(in), optional :: unit type(beam_structure_t), intent(in), optional :: beam_structure call process%beam_config%startup_message (unit, beam_structure) end subroutine process_beams_startup_message @ %def process_beams_startup_message @ Initialize phase-space configuration by reading out the environment variables. We return the rebuild flags and store parameters in the blocks [[phs_par]] and [[mapping_defs]]. The phase-space configuration object(s) are allocated by [[pcm]]. <>= procedure :: init_phs_config => process_init_phs_config <>= subroutine process_init_phs_config (process) class(process_t), intent(inout) :: process type(var_list_t), pointer :: var_list type(phs_parameters_t) :: phs_par type(mapping_defaults_t) :: mapping_defs var_list => process%env%get_var_list_ptr () phs_par%m_threshold_s = & var_list%get_rval (var_str ("phs_threshold_s")) phs_par%m_threshold_t = & var_list%get_rval (var_str ("phs_threshold_t")) phs_par%off_shell = & var_list%get_ival (var_str ("phs_off_shell")) phs_par%keep_nonresonant = & var_list%get_lval (var_str ("?phs_keep_nonresonant")) phs_par%t_channel = & var_list%get_ival (var_str ("phs_t_channel")) mapping_defs%energy_scale = & var_list%get_rval (var_str ("phs_e_scale")) mapping_defs%invariant_mass_scale = & var_list%get_rval (var_str ("phs_m_scale")) mapping_defs%momentum_transfer_scale = & var_list%get_rval (var_str ("phs_q_scale")) mapping_defs%step_mapping = & var_list%get_lval (var_str ("?phs_step_mapping")) mapping_defs%step_mapping_exp = & var_list%get_lval (var_str ("?phs_step_mapping_exp")) mapping_defs%enable_s_mapping = & var_list%get_lval (var_str ("?phs_s_mapping")) associate (pcm => process%pcm) call pcm%init_phs_config (process%phs_entry, & process%meta, process%env, phs_par, mapping_defs) end associate end subroutine process_init_phs_config @ %def process_init_phs_config @ We complete the kinematics configuration after the beam setup, but before we configure the chain of structure functions. The reason is that we need the total energy [[sqrts]] for the kinematics, but the structure-function setup requires the number of channels, which depends on the kinematics configuration. For instance, the kinematics module may return the need for parameterizing an s-channel resonance. <>= procedure :: configure_phs => process_configure_phs <>= subroutine process_configure_phs (process, rebuild, ignore_mismatch, & combined_integration, subdir) class(process_t), intent(inout) :: process logical, intent(in), optional :: rebuild logical, intent(in), optional :: ignore_mismatch logical, intent(in), optional :: combined_integration type(string_t), intent(in), optional :: subdir real(default) :: sqrts integer :: i, i_born, nlo_type class(phs_config_t), pointer :: phs_config_born sqrts = process%get_sqrts () do i = 1, process%meta%n_components associate (component => process%component(i)) if (component%active) then select type (pcm => process%pcm) type is (pcm_default_t) call component%configure_phs (sqrts, process%beam_config, & rebuild, ignore_mismatch, subdir) class is (pcm_nlo_t) nlo_type = component%config%get_nlo_type () select case (nlo_type) case (BORN, NLO_VIRTUAL, NLO_SUBTRACTION) call component%configure_phs (sqrts, process%beam_config, & rebuild, ignore_mismatch, subdir) call check_and_extend_phs (component) case (NLO_REAL, NLO_MISMATCH, NLO_DGLAP) i_born = component%config%get_associated_born () if (component%component_type /= COMP_REAL_FIN) & call check_and_extend_phs (component) call process%component(i_born)%get_phs_config & (phs_config_born) select type (config => component%phs_config) type is (phs_fks_config_t) select type (phs_config_born) type is (phs_wood_config_t) config%md5sum_born_config = & phs_config_born%md5sum_phs_config call config%set_born_config (phs_config_born) call config%set_mode (component%config%get_nlo_type ()) end select end select call component%configure_phs (sqrts, & process%beam_config, rebuild, ignore_mismatch, subdir) end select class default call msg_bug ("process_configure_phs: unsupported PCM type") end select end if end associate end do contains subroutine check_and_extend_phs (component) type(process_component_t), intent(inout) :: component if (combined_integration) then select type (phs_config => component%phs_config) class is (phs_wood_config_t) phs_config%is_combined_integration = .true. call phs_config%increase_n_par () end select end if end subroutine check_and_extend_phs end subroutine process_configure_phs @ %def process_configure_phs @ <>= procedure :: print_phs_startup_message => process_print_phs_startup_message <>= subroutine process_print_phs_startup_message (process) class(process_t), intent(in) :: process integer :: i_component do i_component = 1, process%meta%n_components associate (component => process%component(i_component)) if (component%active) then call component%phs_config%startup_message () end if end associate end do end subroutine process_print_phs_startup_message @ %def process_print_phs_startup_message @ Insert the structure-function configuration data. First allocate the storage, then insert data one by one. The third procedure declares a mapping (of the MC input parameters) for a specific channel and structure-function combination. We take the number of channels from the corresponding entry in the [[config_data]] section. Otherwise, these a simple wrapper routines. The extra level in the call tree may allow for simple addressing of multiple concurrent beam configurations, not implemented currently. If we do not want structure functions, we simply do not call those procedures. <>= procedure :: init_sf_chain => process_init_sf_chain generic :: set_sf_channel => set_sf_channel_single procedure :: set_sf_channel_single => process_set_sf_channel generic :: set_sf_channel => set_sf_channel_array procedure :: set_sf_channel_array => process_set_sf_channel_array <>= subroutine process_init_sf_chain (process, sf_config, sf_trace_file) class(process_t), intent(inout) :: process type(sf_config_t), dimension(:), intent(in) :: sf_config type(string_t), intent(in), optional :: sf_trace_file type(string_t) :: file if (present (sf_trace_file)) then if (sf_trace_file /= "") then file = sf_trace_file else file = process%get_id () // "_sftrace.dat" end if call process%beam_config%init_sf_chain (sf_config, file) else call process%beam_config%init_sf_chain (sf_config) end if end subroutine process_init_sf_chain subroutine process_set_sf_channel (process, c, sf_channel) class(process_t), intent(inout) :: process integer, intent(in) :: c type(sf_channel_t), intent(in) :: sf_channel call process%beam_config%set_sf_channel (c, sf_channel) end subroutine process_set_sf_channel subroutine process_set_sf_channel_array (process, sf_channel) class(process_t), intent(inout) :: process type(sf_channel_t), dimension(:), intent(in) :: sf_channel integer :: c call process%beam_config%allocate_sf_channels (size (sf_channel)) do c = 1, size (sf_channel) call process%beam_config%set_sf_channel (c, sf_channel(c)) end do end subroutine process_set_sf_channel_array @ %def process_init_sf_chain @ %def process_set_sf_channel @ Notify about the structure-function setup. <>= procedure :: sf_startup_message => process_sf_startup_message <>= subroutine process_sf_startup_message (process, sf_string, unit) class(process_t), intent(in) :: process type(string_t), intent(in) :: sf_string integer, intent(in), optional :: unit call process%beam_config%sf_startup_message (sf_string, unit) end subroutine process_sf_startup_message @ %def process_sf_startup_message @ As soon as both the kinematics configuration and the structure-function setup are complete, we match parameterizations (channels) for both. The matching entries are (re)set in the [[component]] phase-space configuration, while the structure-function configuration is left intact. <>= procedure :: collect_channels => process_collect_channels <>= subroutine process_collect_channels (process, coll) class(process_t), intent(inout) :: process type(phs_channel_collection_t), intent(inout) :: coll integer :: i do i = 1, process%meta%n_components associate (component => process%component(i)) if (component%active) & call component%collect_channels (coll) end associate end do end subroutine process_collect_channels @ %def process_collect_channels @ Independently, we should be able to check if any component does not contain phase-space parameters. Such a process can only be integrated if there are structure functions. <>= procedure :: contains_trivial_component => process_contains_trivial_component <>= function process_contains_trivial_component (process) result (flag) class(process_t), intent(in) :: process logical :: flag integer :: i flag = .true. do i = 1, process%meta%n_components associate (component => process%component(i)) if (component%active) then if (component%get_n_phs_par () == 0) return end if end associate end do flag = .false. end function process_contains_trivial_component @ %def process_contains_trivial_component @ <>= procedure :: get_master_component => process_get_master_component <>= function process_get_master_component (process, i_mci) result (i_component) integer :: i_component class(process_t), intent(in) :: process integer, intent(in) :: i_mci integer :: i i_component = 0 do i = 1, size (process%component) if (process%component(i)%i_mci == i_mci) then i_component = i return end if end do end function process_get_master_component @ %def process_get_master_component @ Determine the MC parameter set structure and the MCI configuration for each process component. We need data from the structure-function and phase-space setup, so those should be complete before this is called. We also make a random-number generator instance for each MCI group. <>= procedure :: setup_mci => process_setup_mci <>= subroutine process_setup_mci (process, dispatch_mci) class(process_t), intent(inout) :: process procedure(dispatch_mci_proc) :: dispatch_mci class(mci_t), allocatable :: mci_template integer :: i, i_mci if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "process_setup_mci") associate (pcm => process%pcm) call pcm%call_dispatch_mci (dispatch_mci, & process%get_var_list_ptr (), process%meta%id, mci_template) call pcm%setup_mci (process%mci_entry) process%config%n_mci = pcm%n_mci process%component(:)%i_mci = pcm%i_mci(:) do i = 1, pcm%n_components i_mci = process%pcm%i_mci(i) if (i_mci > 0) then associate (component => process%component(i), & mci_entry => process%mci_entry(i_mci)) call mci_entry%configure (mci_template, & process%meta%type, & i_mci, i, component, process%beam_config%n_sfpar, & process%rng_factory) call mci_entry%set_parameters (process%get_var_list_ptr ()) end associate end if end do end associate end subroutine process_setup_mci @ %def process_setup_mci @ Set cuts. This is a parse node, namely the right-hand side of the [[cut]] assignment. When creating an instance, we compile this into an evaluation tree. The parse node may be null. <>= procedure :: set_cuts => process_set_cuts <>= subroutine process_set_cuts (process, ef_cuts) class(process_t), intent(inout) :: process class(expr_factory_t), intent(in) :: ef_cuts allocate (process%config%ef_cuts, source = ef_cuts) end subroutine process_set_cuts @ %def process_set_cuts @ Analogously for the other expressions. <>= procedure :: set_scale => process_set_scale procedure :: set_fac_scale => process_set_fac_scale procedure :: set_ren_scale => process_set_ren_scale procedure :: set_weight => process_set_weight <>= subroutine process_set_scale (process, ef_scale) class(process_t), intent(inout) :: process class(expr_factory_t), intent(in) :: ef_scale allocate (process%config%ef_scale, source = ef_scale) end subroutine process_set_scale subroutine process_set_fac_scale (process, ef_fac_scale) class(process_t), intent(inout) :: process class(expr_factory_t), intent(in) :: ef_fac_scale allocate (process%config%ef_fac_scale, source = ef_fac_scale) end subroutine process_set_fac_scale subroutine process_set_ren_scale (process, ef_ren_scale) class(process_t), intent(inout) :: process class(expr_factory_t), intent(in) :: ef_ren_scale allocate (process%config%ef_ren_scale, source = ef_ren_scale) end subroutine process_set_ren_scale subroutine process_set_weight (process, ef_weight) class(process_t), intent(inout) :: process class(expr_factory_t), intent(in) :: ef_weight allocate (process%config%ef_weight, source = ef_weight) end subroutine process_set_weight @ %def process_set_scale @ %def process_set_fac_scale @ %def process_set_ren_scale @ %def process_set_weight @ \subsubsection{MD5 sum} The MD5 sum of the process object should reflect the state completely, including integration results. It is used for checking the integrity of event files. This global checksum includes checksums for the various parts. In particular, the MCI object receives a checksum that includes the configuration of all configuration parts relevant for an individual integration. This checksum is used for checking the integrity of integration grids. We do not need MD5 sums for the process terms, since these are generated from the component definitions. <>= procedure :: compute_md5sum => process_compute_md5sum <>= subroutine process_compute_md5sum (process) class(process_t), intent(inout) :: process integer :: i call process%config%compute_md5sum () do i = 1, process%config%n_components associate (component => process%component(i)) if (component%active) then call component%compute_md5sum () end if end associate end do call process%beam_config%compute_md5sum () do i = 1, process%config%n_mci call process%mci_entry(i)%compute_md5sum & (process%config, process%component, process%beam_config) end do end subroutine process_compute_md5sum @ %def process_compute_md5sum @ <>= procedure :: sampler_test => process_sampler_test <>= subroutine process_sampler_test (process, sampler, n_calls, i_mci) class(process_t), intent(inout) :: process class(mci_sampler_t), intent(inout) :: sampler integer, intent(in) :: n_calls, i_mci call process%mci_entry(i_mci)%sampler_test (sampler, n_calls) end subroutine process_sampler_test @ %def process_sampler_test @ The finalizer should be called after all integration passes have been completed. It will, for instance, write a summary of the integration results. [[integrate_dummy]] does a ``dummy'' integration in the sense that nothing is done but just empty integration results appended. <>= procedure :: final_integration => process_final_integration procedure :: integrate_dummy => process_integrate_dummy <>= subroutine process_final_integration (process, i_mci) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci call process%mci_entry(i_mci)%final_integration () end subroutine process_final_integration subroutine process_integrate_dummy (process) class(process_t), intent(inout) :: process type(integration_results_t) :: results integer :: u_log u_log = logfile_unit () call results%init (process%meta%type) call results%display_init (screen = .true., unit = u_log) call results%new_pass () call results%record (1, 0, 0._default, 0._default, 0._default) call results%display_final () end subroutine process_integrate_dummy @ %def process_final_integration @ %def process_integrate_dummy @ <>= procedure :: integrate => process_integrate <>= subroutine process_integrate (process, i_mci, mci_work, & mci_sampler, n_it, n_calls, adapt_grids, adapt_weights, final, & pacify, nlo_type) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci type(mci_work_t), intent(inout) :: mci_work class(mci_sampler_t), intent(inout) :: mci_sampler integer, intent(in) :: n_it, n_calls logical, intent(in), optional :: adapt_grids, adapt_weights logical, intent(in), optional :: final logical, intent(in), optional :: pacify integer, intent(in), optional :: nlo_type associate (mci_entry => process%mci_entry(i_mci)) call mci_entry%integrate (mci_work%mci, mci_sampler, n_it, n_calls, & adapt_grids, adapt_weights, final, pacify, & nlo_type = nlo_type) call mci_entry%results%display_pass (pacify) end associate end subroutine process_integrate @ %def process_integrate @ <>= procedure :: generate_weighted_event => process_generate_weighted_event <>= subroutine process_generate_weighted_event (process, i_mci, mci_work, & mci_sampler, keep_failed_events) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci type(mci_work_t), intent(inout) :: mci_work class(mci_sampler_t), intent(inout) :: mci_sampler logical, intent(in) :: keep_failed_events associate (mci_entry => process%mci_entry(i_mci)) call mci_entry%generate_weighted_event (mci_work%mci, & mci_sampler, keep_failed_events) end associate end subroutine process_generate_weighted_event @ %def process_generate_weighted_event <>= procedure :: generate_unweighted_event => process_generate_unweighted_event <>= subroutine process_generate_unweighted_event (process, i_mci, & mci_work, mci_sampler) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci type(mci_work_t), intent(inout) :: mci_work class(mci_sampler_t), intent(inout) :: mci_sampler associate (mci_entry => process%mci_entry(i_mci)) call mci_entry%generate_unweighted_event & (mci_work%mci, mci_sampler) end associate end subroutine process_generate_unweighted_event @ %def process_generate_unweighted_event @ Display the final results for the sum of all components. This is useful, obviously, only if there is more than one component and not if a combined integration of all components together has been performed. <>= procedure :: display_summed_results => process_display_summed_results <>= subroutine process_display_summed_results (process, pacify) class(process_t), intent(inout) :: process logical, intent(in) :: pacify type(integration_results_t) :: results integer :: u_log u_log = logfile_unit () call results%init (process%meta%type) call results%display_init (screen = .true., unit = u_log) call results%new_pass () call results%record (1, 0, & process%get_integral (), & process%get_error (), & process%get_efficiency (), suppress = pacify) select type (pcm => process%pcm) class is (pcm_nlo_t) !!! Check that Born integral is there if (.not. pcm%settings%combined_integration .and. & process%component_can_be_integrated (1)) then call results%record_correction (process%get_correction (), & process%get_correction_error ()) end if end select call results%display_final () end subroutine process_display_summed_results @ %def process_display_summed_results @ Run LaTeX/Metapost to generate a ps/pdf file for the integration history. We (re)write the driver file -- just in case it has been missed before -- then we compile it. <>= procedure :: display_integration_history => & process_display_integration_history <>= subroutine process_display_integration_history & (process, i_mci, filename, os_data, eff_reset) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci type(string_t), intent(in) :: filename type(os_data_t), intent(in) :: os_data logical, intent(in), optional :: eff_reset call integration_results_write_driver & (process%mci_entry(i_mci)%results, filename, eff_reset) call integration_results_compile_driver & (process%mci_entry(i_mci)%results, filename, os_data) end subroutine process_display_integration_history @ %def subroutine process_display_integration_history @ Write a complete logfile (with hardcoded name based on the process ID). We do not write internal data. <>= procedure :: write_logfile => process_write_logfile <>= subroutine process_write_logfile (process, i_mci, filename) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci type(string_t), intent(in) :: filename type(time_t) :: time integer :: unit, u unit = free_unit () open (unit = unit, file = char (filename), action = "write", & status = "replace") u = given_output_unit (unit) write (u, "(A)") repeat ("#", 79) call process%meta%write (u, .false.) write (u, "(A)") repeat ("#", 79) write (u, "(3x,A,ES17.10)") "Integral = ", & process%mci_entry(i_mci)%get_integral () write (u, "(3x,A,ES17.10)") "Error = ", & process%mci_entry(i_mci)%get_error () write (u, "(3x,A,ES17.10)") "Accuracy = ", & process%mci_entry(i_mci)%get_accuracy () write (u, "(3x,A,ES17.10)") "Chi2 = ", & process%mci_entry(i_mci)%get_chi2 () write (u, "(3x,A,ES17.10)") "Efficiency = ", & process%mci_entry(i_mci)%get_efficiency () call process%mci_entry(i_mci)%get_time (time, 10000) if (time%is_known ()) then write (u, "(3x,A,1x,A)") "T(10k evt) = ", char (time%to_string_dhms ()) else write (u, "(3x,A)") "T(10k evt) = [undefined]" end if call process%mci_entry(i_mci)%results%write (u) write (u, "(A)") repeat ("#", 79) call process%mci_entry(i_mci)%results%write_chain_weights (u) write (u, "(A)") repeat ("#", 79) call process%mci_entry(i_mci)%counter%write (u) write (u, "(A)") repeat ("#", 79) call process%mci_entry(i_mci)%mci%write_log_entry (u) write (u, "(A)") repeat ("#", 79) call process%beam_config%data%write (u) write (u, "(A)") repeat ("#", 79) if (allocated (process%config%ef_cuts)) then write (u, "(3x,A)") "Cut expression:" call process%config%ef_cuts%write (u) else write (u, "(3x,A)") "No cuts used." end if call write_separator (u) if (allocated (process%config%ef_scale)) then write (u, "(3x,A)") "Scale expression:" call process%config%ef_scale%write (u) else write (u, "(3x,A)") "No scale expression was given." end if call write_separator (u) if (allocated (process%config%ef_fac_scale)) then write (u, "(3x,A)") "Factorization scale expression:" call process%config%ef_fac_scale%write (u) else write (u, "(3x,A)") "No factorization scale expression was given." end if call write_separator (u) if (allocated (process%config%ef_ren_scale)) then write (u, "(3x,A)") "Renormalization scale expression:" call process%config%ef_ren_scale%write (u) else write (u, "(3x,A)") "No renormalization scale expression was given." end if call write_separator (u) if (allocated (process%config%ef_weight)) then call write_separator (u) write (u, "(3x,A)") "Weight expression:" call process%config%ef_weight%write (u) else write (u, "(3x,A)") "No weight expression was given." end if write (u, "(A)") repeat ("#", 79) write (u, "(1x,A)") "Summary of quantum-number states:" write (u, "(1x,A)") " + sign: allowed and contributing" write (u, "(1x,A)") " no + : switched off at runtime" call process%write_state_summary (u) write (u, "(A)") repeat ("#", 79) call process%env%write (u, show_var_list=.true., & show_model=.false., show_lib=.false., show_os_data=.false.) write (u, "(A)") repeat ("#", 79) close (u) end subroutine process_write_logfile @ %def process_write_logfile @ Display the quantum-number combinations of the process components, and their current status (allowed or switched off). <>= procedure :: write_state_summary => process_write_state_summary <>= subroutine process_write_state_summary (process, unit) class(process_t), intent(in) :: process integer, intent(in), optional :: unit integer :: i, i_component, u u = given_output_unit (unit) do i = 1, size (process%term) call write_separator (u) i_component = process%term(i)%i_component if (i_component /= 0) then call process%term(i)%write_state_summary & (process%get_core_term(i), unit) end if end do end subroutine process_write_state_summary @ %def process_write_state_summary @ Prepare event generation for the specified MCI entry. This implies, in particular, checking the phase-space file. <>= procedure :: prepare_simulation => process_prepare_simulation <>= subroutine process_prepare_simulation (process, i_mci) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci call process%mci_entry(i_mci)%prepare_simulation () end subroutine process_prepare_simulation @ %def process_prepare_simulation @ \subsubsection{Retrieve process data} Tell whether integral (and error) are known. <>= generic :: has_integral => has_integral_tot, has_integral_mci procedure :: has_integral_tot => process_has_integral_tot procedure :: has_integral_mci => process_has_integral_mci <>= function process_has_integral_mci (process, i_mci) result (flag) logical :: flag class(process_t), intent(in) :: process integer, intent(in) :: i_mci if (allocated (process%mci_entry)) then flag = process%mci_entry(i_mci)%has_integral () else flag = .false. end if end function process_has_integral_mci function process_has_integral_tot (process) result (flag) logical :: flag class(process_t), intent(in) :: process integer :: i, j, i_component if (allocated (process%mci_entry)) then flag = .true. do i = 1, size (process%mci_entry) do j = 1, size (process%mci_entry(i)%i_component) i_component = process%mci_entry(i)%i_component(j) if (process%component_can_be_integrated (i_component)) & flag = flag .and. process%mci_entry(i)%has_integral () end do end do else flag = .false. end if end function process_has_integral_tot @ %def process_has_integral @ Return the current integral and error obtained by the integrator [[i_mci]]. <>= generic :: get_integral => get_integral_tot, get_integral_mci generic :: get_error => get_error_tot, get_error_mci generic :: get_efficiency => get_efficiency_tot, get_efficiency_mci procedure :: get_integral_tot => process_get_integral_tot procedure :: get_integral_mci => process_get_integral_mci procedure :: get_error_tot => process_get_error_tot procedure :: get_error_mci => process_get_error_mci procedure :: get_efficiency_tot => process_get_efficiency_tot procedure :: get_efficiency_mci => process_get_efficiency_mci <>= function process_get_integral_mci (process, i_mci) result (integral) real(default) :: integral class(process_t), intent(in) :: process integer, intent(in) :: i_mci integral = process%mci_entry(i_mci)%get_integral () end function process_get_integral_mci function process_get_error_mci (process, i_mci) result (error) real(default) :: error class(process_t), intent(in) :: process integer, intent(in) :: i_mci error = process%mci_entry(i_mci)%get_error () end function process_get_error_mci function process_get_efficiency_mci (process, i_mci) result (efficiency) real(default) :: efficiency class(process_t), intent(in) :: process integer, intent(in) :: i_mci efficiency = process%mci_entry(i_mci)%get_efficiency () end function process_get_efficiency_mci function process_get_integral_tot (process) result (integral) real(default) :: integral class(process_t), intent(in) :: process integer :: i, j, i_component integral = zero if (allocated (process%mci_entry)) then do i = 1, size (process%mci_entry) do j = 1, size (process%mci_entry(i)%i_component) i_component = process%mci_entry(i)%i_component(j) if (process%component_can_be_integrated(i_component)) & integral = integral + process%mci_entry(i)%get_integral () end do end do end if end function process_get_integral_tot function process_get_error_tot (process) result (error) real(default) :: variance class(process_t), intent(in) :: process real(default) :: error integer :: i, j, i_component variance = zero if (allocated (process%mci_entry)) then do i = 1, size (process%mci_entry) do j = 1, size (process%mci_entry(i)%i_component) i_component = process%mci_entry(i)%i_component(j) if (process%component_can_be_integrated(i_component)) & variance = variance + process%mci_entry(i)%get_error () ** 2 end do end do end if error = sqrt (variance) end function process_get_error_tot function process_get_efficiency_tot (process) result (efficiency) real(default) :: efficiency class(process_t), intent(in) :: process real(default) :: den, eff, int integer :: i, j, i_component den = zero if (allocated (process%mci_entry)) then do i = 1, size (process%mci_entry) do j = 1, size (process%mci_entry(i)%i_component) i_component = process%mci_entry(i)%i_component(j) if (process%component_can_be_integrated(i_component)) then int = process%get_integral (i) if (int > 0) then eff = process%mci_entry(i)%get_efficiency () if (eff > 0) then den = den + int / eff else efficiency = 0 return end if end if end if end do end do end if if (den > 0) then efficiency = process%get_integral () / den else efficiency = 0 end if end function process_get_efficiency_tot @ %def process_get_integral process_get_efficiency @ Let us call the ratio of the NLO and the LO result $\iota = I_{NLO} / I_{LO}$. Then usual error propagation gives \begin{equation*} \sigma_{\iota}^2 = \left(\frac{\partial \iota}{\partial I_{LO}}\right)^2 \sigma_{I_{LO}}^2 + \left(\frac{\partial \iota}{\partial I_{NLO}}\right)^2 \sigma_{I_{NLO}}^2 = \frac{I_{NLO}^2\sigma_{I_{LO}}^2}{I_{LO}^4} + \frac{\sigma_{I_{NLO}}^2}{I_{LO}^2}. \end{equation*} <>= procedure :: get_correction => process_get_correction procedure :: get_correction_error => process_get_correction_error <>= function process_get_correction (process) result (ratio) real(default) :: ratio class(process_t), intent(in) :: process integer :: i_mci, i_component real(default) :: int_born, int_nlo int_nlo = zero int_born = process%mci_entry(1)%get_integral () i_mci = 2 do i_component = 2, size (process%component) if (process%component_can_be_integrated (i_component)) then int_nlo = int_nlo + process%mci_entry(i_mci)%get_integral () i_mci = i_mci + 1 end if end do ratio = int_nlo / int_born * 100 end function process_get_correction function process_get_correction_error (process) result (error) real(default) :: error class(process_t), intent(in) :: process real(default) :: int_born, sum_int_nlo real(default) :: err_born, err2 integer :: i_mci, i_component sum_int_nlo = zero; err2 = zero int_born = process%mci_entry(1)%get_integral () err_born = process%mci_entry(1)%get_error () i_mci = 2 do i_component = 2, size (process%component) if (process%component_can_be_integrated (i_component)) then sum_int_nlo = sum_int_nlo + process%mci_entry(i_mci)%get_integral () err2 = err2 + process%mci_entry(i_mci)%get_error()**2 i_mci = i_mci + 1 end if end do error = sqrt (err2 / int_born**2 + sum_int_nlo**2 * err_born**2 / int_born**4) * 100 end function process_get_correction_error @ %def process_get_correction process_get_correction_error @ <>= procedure :: lab_is_cm => process_lab_is_cm <>= pure function process_lab_is_cm (process) result (lab_is_cm) logical :: lab_is_cm class(process_t), intent(in) :: process lab_is_cm = process%beam_config%lab_is_cm ! This asks beam_config for the frame end function process_lab_is_cm @ %def process_lab_is_cm @ <>= procedure :: get_component_ptr => process_get_component_ptr <>= function process_get_component_ptr (process, i) result (component) type(process_component_t), pointer :: component class(process_t), intent(in), target :: process integer, intent(in) :: i component => process%component(i) end function process_get_component_ptr @ %def process_get_component_ptr @ <>= procedure :: get_qcd => process_get_qcd <>= function process_get_qcd (process) result (qcd) type(qcd_t) :: qcd class(process_t), intent(in) :: process qcd = process%config%get_qcd () end function process_get_qcd @ %def process_get_qcd @ <>= generic :: get_component_type => get_component_type_single procedure :: get_component_type_single => process_get_component_type_single <>= elemental function process_get_component_type_single & (process, i_component) result (comp_type) integer :: comp_type class(process_t), intent(in) :: process integer, intent(in) :: i_component comp_type = process%component(i_component)%component_type end function process_get_component_type_single @ %def process_get_component_type_single @ <>= generic :: get_component_type => get_component_type_all procedure :: get_component_type_all => process_get_component_type_all <>= function process_get_component_type_all & (process) result (comp_type) integer, dimension(:), allocatable :: comp_type class(process_t), intent(in) :: process allocate (comp_type (size (process%component))) comp_type = process%component%component_type end function process_get_component_type_all @ %def process_get_component_type_all @ <>= procedure :: get_component_i_terms => process_get_component_i_terms <>= function process_get_component_i_terms (process, i_component) result (i_term) integer, dimension(:), allocatable :: i_term class(process_t), intent(in) :: process integer, intent(in) :: i_component allocate (i_term (size (process%component(i_component)%i_term))) i_term = process%component(i_component)%i_term end function process_get_component_i_terms @ %def process_get_component_i_terms @ <>= procedure :: get_n_allowed_born => process_get_n_allowed_born <>= function process_get_n_allowed_born (process, i_born) result (n_born) class(process_t), intent(inout) :: process integer, intent(in) :: i_born integer :: n_born n_born = process%term(i_born)%n_allowed end function process_get_n_allowed_born @ %def process_get_n_allowed_born @ Workaround getter. Would be better to remove this. <>= procedure :: get_pcm_ptr => process_get_pcm_ptr <>= function process_get_pcm_ptr (process) result (pcm) class(pcm_t), pointer :: pcm class(process_t), intent(in), target :: process pcm => process%pcm end function process_get_pcm_ptr @ %def process_get_pcm_ptr <>= generic :: component_can_be_integrated => component_can_be_integrated_single generic :: component_can_be_integrated => component_can_be_integrated_all procedure :: component_can_be_integrated_single => process_component_can_be_integrated_single <>= function process_component_can_be_integrated_single (process, i_component) & result (active) logical :: active class(process_t), intent(in) :: process integer, intent(in) :: i_component logical :: combined_integration select type (pcm => process%pcm) type is (pcm_nlo_t) combined_integration = pcm%settings%combined_integration class default combined_integration = .false. end select associate (component => process%component(i_component)) active = component%can_be_integrated () if (combined_integration) & active = active .and. component%component_type <= COMP_MASTER end associate end function process_component_can_be_integrated_single @ %def process_component_can_be_integrated_single @ <>= procedure :: component_can_be_integrated_all => process_component_can_be_integrated_all <>= function process_component_can_be_integrated_all (process) result (val) logical, dimension(:), allocatable :: val class(process_t), intent(in) :: process integer :: i allocate (val (size (process%component))) do i = 1, size (process%component) val(i) = process%component_can_be_integrated (i) end do end function process_component_can_be_integrated_all @ %def process_component_can_be_integrated_all @ <>= procedure :: reset_selected_cores => process_reset_selected_cores <>= pure subroutine process_reset_selected_cores (process) class(process_t), intent(inout) :: process process%pcm%component_selected = .false. end subroutine process_reset_selected_cores @ %def process_reset_selected_cores @ <>= procedure :: select_components => process_select_components <>= pure subroutine process_select_components (process, indices) class(process_t), intent(inout) :: process integer, dimension(:), intent(in) :: indices associate (pcm => process%pcm) pcm%component_selected(indices) = .true. end associate end subroutine process_select_components @ %def process_select_components @ <>= procedure :: component_is_selected => process_component_is_selected <>= pure function process_component_is_selected (process, index) result (val) logical :: val class(process_t), intent(in) :: process integer, intent(in) :: index associate (pcm => process%pcm) val = pcm%component_selected(index) end associate end function process_component_is_selected @ %def process_component_is_selected @ <>= procedure :: get_coupling_powers => process_get_coupling_powers <>= pure subroutine process_get_coupling_powers (process, alpha_power, alphas_power) class(process_t), intent(in) :: process integer, intent(out) :: alpha_power, alphas_power call process%component(1)%config%get_coupling_powers (alpha_power, alphas_power) end subroutine process_get_coupling_powers @ %def process_get_coupling_powers @ <>= procedure :: get_real_component => process_get_real_component <>= function process_get_real_component (process) result (i_real) integer :: i_real class(process_t), intent(in) :: process integer :: i_component type(process_component_def_t), pointer :: config => null () i_real = 0 do i_component = 1, size (process%component) config => process%get_component_def_ptr (i_component) if (config%get_nlo_type () == NLO_REAL) then i_real = i_component exit end if end do end function process_get_real_component @ %def process_get_real_component @ <>= procedure :: extract_active_component_mci => process_extract_active_component_mci <>= function process_extract_active_component_mci (process) result (i_active) integer :: i_active class(process_t), intent(in) :: process integer :: i_mci, j, i_component, n_active call count_n_active () if (n_active /= 1) i_active = 0 contains subroutine count_n_active () n_active = 0 do i_mci = 1, size (process%mci_entry) associate (mci_entry => process%mci_entry(i_mci)) do j = 1, size (mci_entry%i_component) i_component = mci_entry%i_component(j) associate (component => process%component (i_component)) if (component%can_be_integrated ()) then i_active = i_mci n_active = n_active + 1 end if end associate end do end associate end do end subroutine count_n_active end function process_extract_active_component_mci @ %def process_extract_active_component_mci @ <>= procedure :: uses_real_partition => process_uses_real_partition <>= function process_uses_real_partition (process) result (val) logical :: val class(process_t), intent(in) :: process val = any (process%mci_entry%real_partition_type /= REAL_FULL) end function process_uses_real_partition @ %def process_uses_real_partition @ Return the MD5 sums that summarize the process component definitions. These values should be independent of parameters, beam details, expressions, etc. They can be used for checking the integrity of a process when reusing an old event file. <>= procedure :: get_md5sum_prc => process_get_md5sum_prc <>= function process_get_md5sum_prc (process, i_component) result (md5sum) character(32) :: md5sum class(process_t), intent(in) :: process integer, intent(in) :: i_component if (process%component(i_component)%active) then md5sum = process%component(i_component)%config%get_md5sum () else md5sum = "" end if end function process_get_md5sum_prc @ %def process_get_md5sum_prc @ Return the MD5 sums that summarize the state of the MCI integrators. These values should encode all process data, integration and phase space configuration, etc., and the integration results. They can thus be used for checking the integrity of an event-generation setup when reusing an old event file. <>= procedure :: get_md5sum_mci => process_get_md5sum_mci <>= function process_get_md5sum_mci (process, i_mci) result (md5sum) character(32) :: md5sum class(process_t), intent(in) :: process integer, intent(in) :: i_mci md5sum = process%mci_entry(i_mci)%get_md5sum () end function process_get_md5sum_mci @ %def process_get_md5sum_mci @ Return the MD5 sum of the process configuration. This should encode the process setup, data, and expressions, but no integration results. <>= procedure :: get_md5sum_cfg => process_get_md5sum_cfg <>= function process_get_md5sum_cfg (process) result (md5sum) character(32) :: md5sum class(process_t), intent(in) :: process md5sum = process%config%md5sum end function process_get_md5sum_cfg @ %def process_get_md5sum_cfg @ <>= procedure :: get_n_cores => process_get_n_cores <>= function process_get_n_cores (process) result (n) integer :: n class(process_t), intent(in) :: process n = process%pcm%n_cores end function process_get_n_cores @ %def process_get_n_cores @ <>= procedure :: get_base_i_term => process_get_base_i_term <>= function process_get_base_i_term (process, i_component) result (i_term) integer :: i_term class(process_t), intent(in) :: process integer, intent(in) :: i_component i_term = process%component(i_component)%i_term(1) end function process_get_base_i_term @ %def process_get_base_i_term @ <>= procedure :: get_core_term => process_get_core_term <>= function process_get_core_term (process, i_term) result (core) class(prc_core_t), pointer :: core class(process_t), intent(in), target :: process integer, intent(in) :: i_term integer :: i_core i_core = process%term(i_term)%i_core core => process%core_entry(i_core)%get_core_ptr () end function process_get_core_term @ %def process_get_core_term @ <>= procedure :: get_core_ptr => process_get_core_ptr <>= function process_get_core_ptr (process, i_core) result (core) class(prc_core_t), pointer :: core class(process_t), intent(in), target :: process integer, intent(in) :: i_core if (allocated (process%core_entry)) then core => process%core_entry(i_core)%get_core_ptr () else core => null () end if end function process_get_core_ptr @ %def process_get_core_ptr @ <>= procedure :: get_term_ptr => process_get_term_ptr <>= function process_get_term_ptr (process, i) result (term) type(process_term_t), pointer :: term class(process_t), intent(in), target :: process integer, intent(in) :: i term => process%term(i) end function process_get_term_ptr @ %def process_get_term_ptr @ <>= procedure :: get_i_term => process_get_i_term <>= function process_get_i_term (process, i_core) result (i_term) integer :: i_term class(process_t), intent(in) :: process integer, intent(in) :: i_core do i_term = 1, process%get_n_terms () if (process%term(i_term)%i_core == i_core) return end do i_term = -1 end function process_get_i_term @ %def process_get_i_term @ <>= procedure :: get_i_core => process_get_i_core <>= integer function process_get_i_core (process, i_term) result (i_core) class(process_t), intent(in) :: process integer, intent(in) :: i_term i_core = process%term(i_term)%i_core end function process_get_i_core @ %def process_get_i_core @ <>= procedure :: set_i_mci_work => process_set_i_mci_work <>= subroutine process_set_i_mci_work (process, i_mci) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci process%mci_entry(i_mci)%i_mci = i_mci end subroutine process_set_i_mci_work @ %def process_set_i_mci_work @ <>= procedure :: get_i_mci_work => process_get_i_mci_work <>= pure function process_get_i_mci_work (process, i_mci) result (i_mci_work) integer :: i_mci_work class(process_t), intent(in) :: process integer, intent(in) :: i_mci i_mci_work = process%mci_entry(i_mci)%i_mci end function process_get_i_mci_work @ %def process_get_i_mci_work @ <>= procedure :: get_i_sub => process_get_i_sub <>= elemental function process_get_i_sub (process, i_term) result (i_sub) integer :: i_sub class(process_t), intent(in) :: process integer, intent(in) :: i_term i_sub = process%term(i_term)%i_sub end function process_get_i_sub @ %def process_get_i_sub @ <>= procedure :: get_i_term_virtual => process_get_i_term_virtual <>= elemental function process_get_i_term_virtual (process) result (i_term) integer :: i_term class(process_t), intent(in) :: process integer :: i_component i_term = 0 do i_component = 1, size (process%component) if (process%component(i_component)%get_nlo_type () == NLO_VIRTUAL) & i_term = process%component(i_component)%i_term(1) end do end function process_get_i_term_virtual @ %def process_get_i_term_virtual @ <>= generic :: component_is_active => component_is_active_single procedure :: component_is_active_single => process_component_is_active_single <>= elemental function process_component_is_active_single (process, i_comp) result (val) logical :: val class(process_t), intent(in) :: process integer, intent(in) :: i_comp val = process%component(i_comp)%is_active () end function process_component_is_active_single @ %def process_component_is_active_single @ <>= generic :: component_is_active => component_is_active_all procedure :: component_is_active_all => process_component_is_active_all <>= pure function process_component_is_active_all (process) result (val) logical, dimension(:), allocatable :: val class(process_t), intent(in) :: process allocate (val (size (process%component))) val = process%component%is_active () end function process_component_is_active_all @ %def process_component_is_active_all @ \subsection{Default iterations} If the user does not specify the passes and iterations for integration, we should be able to give reasonable defaults. These depend on the process, therefore we implement the following procedures as methods of the process object. The algorithm is not very sophisticated yet, it may be improved by looking at the process in more detail. We investigate only the first process component, assuming that it characterizes the complexity of the process reasonable well. The number of passes is limited to two: one for adaption, one for integration. <>= procedure :: get_n_pass_default => process_get_n_pass_default procedure :: adapt_grids_default => process_adapt_grids_default procedure :: adapt_weights_default => process_adapt_weights_default <>= function process_get_n_pass_default (process) result (n_pass) class(process_t), intent(in) :: process integer :: n_pass integer :: n_eff type(process_component_def_t), pointer :: config config => process%component(1)%config n_eff = config%get_n_tot () - 2 select case (n_eff) case (1) n_pass = 1 case default n_pass = 2 end select end function process_get_n_pass_default function process_adapt_grids_default (process, pass) result (flag) class(process_t), intent(in) :: process integer, intent(in) :: pass logical :: flag integer :: n_eff type(process_component_def_t), pointer :: config config => process%component(1)%config n_eff = config%get_n_tot () - 2 select case (n_eff) case (1) flag = .false. case default select case (pass) case (1); flag = .true. case (2); flag = .false. case default call msg_bug ("adapt grids default: impossible pass index") end select end select end function process_adapt_grids_default function process_adapt_weights_default (process, pass) result (flag) class(process_t), intent(in) :: process integer, intent(in) :: pass logical :: flag integer :: n_eff type(process_component_def_t), pointer :: config config => process%component(1)%config n_eff = config%get_n_tot () - 2 select case (n_eff) case (1) flag = .false. case default select case (pass) case (1); flag = .true. case (2); flag = .false. case default call msg_bug ("adapt weights default: impossible pass index") end select end select end function process_adapt_weights_default @ %def process_get_n_pass_default @ %def process_adapt_grids_default @ %def process_adapt_weights_default @ The number of iterations and calls per iteration depends on the number of outgoing particles. <>= procedure :: get_n_it_default => process_get_n_it_default procedure :: get_n_calls_default => process_get_n_calls_default <>= function process_get_n_it_default (process, pass) result (n_it) class(process_t), intent(in) :: process integer, intent(in) :: pass integer :: n_it integer :: n_eff type(process_component_def_t), pointer :: config config => process%component(1)%config n_eff = config%get_n_tot () - 2 select case (pass) case (1) select case (n_eff) case (1); n_it = 1 case (2); n_it = 3 case (3); n_it = 5 case (4:5); n_it = 10 case (6); n_it = 15 case (7:); n_it = 20 end select case (2) select case (n_eff) case (:3); n_it = 3 case (4:); n_it = 5 end select end select end function process_get_n_it_default function process_get_n_calls_default (process, pass) result (n_calls) class(process_t), intent(in) :: process integer, intent(in) :: pass integer :: n_calls integer :: n_eff type(process_component_def_t), pointer :: config config => process%component(1)%config n_eff = config%get_n_tot () - 2 select case (pass) case (1) select case (n_eff) case (1); n_calls = 100 case (2); n_calls = 1000 case (3); n_calls = 5000 case (4); n_calls = 10000 case (5); n_calls = 20000 case (6:); n_calls = 50000 end select case (2) select case (n_eff) case (:3); n_calls = 10000 case (4); n_calls = 20000 case (5); n_calls = 50000 case (6); n_calls = 100000 case (7:); n_calls = 200000 end select end select end function process_get_n_calls_default @ %def process_get_n_it_default @ %def process_get_n_calls_default @ \subsection{Constant process data} Manually set the Run ID (unit test only). <>= procedure :: set_run_id => process_set_run_id <>= subroutine process_set_run_id (process, run_id) class(process_t), intent(inout) :: process type(string_t), intent(in) :: run_id process%meta%run_id = run_id end subroutine process_set_run_id @ %def process_set_run_id @ The following methods return basic process data that stay constant after initialization. The process and IDs. <>= procedure :: get_id => process_get_id procedure :: get_num_id => process_get_num_id procedure :: get_run_id => process_get_run_id procedure :: get_library_name => process_get_library_name <>= function process_get_id (process) result (id) class(process_t), intent(in) :: process type(string_t) :: id id = process%meta%id end function process_get_id function process_get_num_id (process) result (id) class(process_t), intent(in) :: process integer :: id id = process%meta%num_id end function process_get_num_id function process_get_run_id (process) result (id) class(process_t), intent(in) :: process type(string_t) :: id id = process%meta%run_id end function process_get_run_id function process_get_library_name (process) result (id) class(process_t), intent(in) :: process type(string_t) :: id id = process%meta%lib_name end function process_get_library_name @ %def process_get_id process_get_num_id @ %def process_get_run_id process_get_library_name @ The number of incoming particles. <>= procedure :: get_n_in => process_get_n_in <>= function process_get_n_in (process) result (n) class(process_t), intent(in) :: process integer :: n n = process%config%n_in end function process_get_n_in @ %def process_get_n_in @ The number of MCI data sets. <>= procedure :: get_n_mci => process_get_n_mci <>= function process_get_n_mci (process) result (n) class(process_t), intent(in) :: process integer :: n n = process%config%n_mci end function process_get_n_mci @ %def process_get_n_mci @ The number of process components, total. <>= procedure :: get_n_components => process_get_n_components <>= function process_get_n_components (process) result (n) class(process_t), intent(in) :: process integer :: n n = process%meta%n_components end function process_get_n_components @ %def process_get_n_components @ The number of process terms, total. <>= procedure :: get_n_terms => process_get_n_terms <>= function process_get_n_terms (process) result (n) class(process_t), intent(in) :: process integer :: n n = process%config%n_terms end function process_get_n_terms @ %def process_get_n_terms @ Return the indices of the components that belong to a specific MCI entry. <>= procedure :: get_i_component => process_get_i_component <>= subroutine process_get_i_component (process, i_mci, i_component) class(process_t), intent(in) :: process integer, intent(in) :: i_mci integer, dimension(:), intent(out), allocatable :: i_component associate (mci_entry => process%mci_entry(i_mci)) allocate (i_component (size (mci_entry%i_component))) i_component = mci_entry%i_component end associate end subroutine process_get_i_component @ %def process_get_i_component @ Return the ID of a specific component. <>= procedure :: get_component_id => process_get_component_id <>= function process_get_component_id (process, i_component) result (id) class(process_t), intent(in) :: process integer, intent(in) :: i_component type(string_t) :: id id = process%meta%component_id(i_component) end function process_get_component_id @ %def process_get_component_id @ Return a pointer to the definition of a specific component. <>= procedure :: get_component_def_ptr => process_get_component_def_ptr <>= function process_get_component_def_ptr (process, i_component) result (ptr) type(process_component_def_t), pointer :: ptr class(process_t), intent(in) :: process integer, intent(in) :: i_component ptr => process%config%process_def%get_component_def_ptr (i_component) end function process_get_component_def_ptr @ %def process_get_component_def_ptr @ These procedures extract and restore (by transferring the allocation) the process core. This is useful for changing process parameters from outside this module. <>= procedure :: extract_core => process_extract_core procedure :: restore_core => process_restore_core <>= subroutine process_extract_core (process, i_term, core) class(process_t), intent(inout) :: process integer, intent(in) :: i_term class(prc_core_t), intent(inout), allocatable :: core integer :: i_core i_core = process%term(i_term)%i_core call move_alloc (from = process%core_entry(i_core)%core, to = core) end subroutine process_extract_core subroutine process_restore_core (process, i_term, core) class(process_t), intent(inout) :: process integer, intent(in) :: i_term class(prc_core_t), intent(inout), allocatable :: core integer :: i_core i_core = process%term(i_term)%i_core call move_alloc (from = core, to = process%core_entry(i_core)%core) end subroutine process_restore_core @ %def process_extract_core @ %def process_restore_core @ The block of process constants. <>= procedure :: get_constants => process_get_constants <>= function process_get_constants (process, i_core) result (data) type(process_constants_t) :: data class(process_t), intent(in) :: process integer, intent(in) :: i_core data = process%core_entry(i_core)%core%data end function process_get_constants @ %def process_get_constants @ <>= procedure :: get_config => process_get_config <>= function process_get_config (process) result (config) type(process_config_data_t) :: config class(process_t), intent(in) :: process config = process%config end function process_get_config @ %def process_get_config @ Construct an MD5 sum for the constant data, including the NLO type. For the NLO type [[NLO_MISMATCH]], we pretend that this was [[NLO_SUBTRACTION]] instead. TODO wk 2018: should not depend explicitly on NLO data. <>= procedure :: get_md5sum_constants => process_get_md5sum_constants <>= function process_get_md5sum_constants (process, i_component, & type_string, nlo_type) result (this_md5sum) character(32) :: this_md5sum class(process_t), intent(in) :: process integer, intent(in) :: i_component type(string_t), intent(in) :: type_string integer, intent(in) :: nlo_type type(process_constants_t) :: data integer :: unit call process%env%fill_process_constants (process%meta%id, i_component, data) unit = data%fill_unit_for_md5sum (.false.) write (unit, '(A)') char(type_string) select case (nlo_type) case (NLO_MISMATCH) write (unit, '(I0)') NLO_SUBTRACTION case default write (unit, '(I0)') nlo_type end select rewind (unit) this_md5sum = md5sum (unit) close (unit) end function process_get_md5sum_constants @ %def process_get_md5sum_constants @ Return the set of outgoing flavors that are associated with a particular term. We deduce this from the effective interaction. <>= procedure :: get_term_flv_out => process_get_term_flv_out <>= subroutine process_get_term_flv_out (process, i_term, flv) class(process_t), intent(in), target :: process integer, intent(in) :: i_term type(flavor_t), dimension(:,:), allocatable, intent(out) :: flv type(interaction_t), pointer :: int int => process%term(i_term)%int_eff if (.not. associated (int)) int => process%term(i_term)%int call int%get_flv_out (flv) end subroutine process_get_term_flv_out @ %def process_get_term_flv_out @ Return true if there is any unstable particle in any of the process terms. We decide this based on the provided model instance, not the one that is stored in the process object. <>= procedure :: contains_unstable => process_contains_unstable <>= function process_contains_unstable (process, model) result (flag) class(process_t), intent(in) :: process class(model_data_t), intent(in), target :: model logical :: flag integer :: i_term type(flavor_t), dimension(:,:), allocatable :: flv flag = .false. do i_term = 1, process%get_n_terms () call process%get_term_flv_out (i_term, flv) call flv%set_model (model) flag = .not. all (flv%is_stable ()) deallocate (flv) if (flag) return end do end function process_contains_unstable @ %def process_contains_unstable @ The nominal process energy. <>= procedure :: get_sqrts => process_get_sqrts <>= function process_get_sqrts (process) result (sqrts) class(process_t), intent(in) :: process real(default) :: sqrts sqrts = process%beam_config%data%get_sqrts () end function process_get_sqrts @ %def process_get_sqrts @ The lab-frame beam energy/energies.. <>= procedure :: get_energy => process_get_energy <>= function process_get_energy (process) result (e) class(process_t), intent(in) :: process real(default), dimension(:), allocatable :: e e = process%beam_config%data%get_energy () end function process_get_energy @ %def process_get_energy @ The beam polarization in case of simple degrees. <>= procedure :: get_polarization => process_get_polarization <>= function process_get_polarization (process) result (pol) class(process_t), intent(in) :: process real(default), dimension(process%beam_config%data%n) :: pol pol = process%beam_config%data%get_polarization () end function process_get_polarization @ %def process_get_polarization @ <>= procedure :: get_meta => process_get_meta <>= function process_get_meta (process) result (meta) type(process_metadata_t) :: meta class(process_t), intent(in) :: process meta = process%meta end function process_get_meta @ %def process_get_meta <>= procedure :: has_matrix_element => process_has_matrix_element <>= function process_has_matrix_element (process, i, is_term_index) result (active) logical :: active class(process_t), intent(in) :: process integer, intent(in), optional :: i logical, intent(in), optional :: is_term_index integer :: i_component logical :: is_term is_term = .false. if (present (i)) then if (present (is_term_index)) is_term = is_term_index if (is_term) then i_component = process%term(i)%i_component else i_component = i end if active = process%component(i_component)%active else active = any (process%component%active) end if end function process_has_matrix_element @ %def process_has_matrix_element @ Pointer to the beam data object. <>= procedure :: get_beam_data_ptr => process_get_beam_data_ptr <>= function process_get_beam_data_ptr (process) result (beam_data) class(process_t), intent(in), target :: process type(beam_data_t), pointer :: beam_data beam_data => process%beam_config%data end function process_get_beam_data_ptr @ %def process_get_beam_data_ptr @ <>= procedure :: get_beam_config => process_get_beam_config <>= function process_get_beam_config (process) result (beam_config) type(process_beam_config_t) :: beam_config class(process_t), intent(in) :: process beam_config = process%beam_config end function process_get_beam_config @ %def process_get_beam_config @ <>= procedure :: get_beam_config_ptr => process_get_beam_config_ptr <>= function process_get_beam_config_ptr (process) result (beam_config) type(process_beam_config_t), pointer :: beam_config class(process_t), intent(in), target :: process beam_config => process%beam_config end function process_get_beam_config_ptr @ %def process_get_beam_config_ptr @ Get the PDF set currently in use, if any. <>= procedure :: get_pdf_set => process_get_pdf_set <>= function process_get_pdf_set (process) result (pdf_set) class(process_t), intent(in) :: process integer :: pdf_set pdf_set = process%beam_config%get_pdf_set () end function process_get_pdf_set @ %def process_get_pdf_set @ <>= procedure :: pcm_contains_pdfs => process_pcm_contains_pdfs <>= function process_pcm_contains_pdfs (process) result (has_pdfs) logical :: has_pdfs class(process_t), intent(in) :: process has_pdfs = process%pcm%has_pdfs end function process_pcm_contains_pdfs @ %def process_pcm_contains_pdfs @ Get the beam spectrum file currently in use, if any. <>= procedure :: get_beam_file => process_get_beam_file <>= function process_get_beam_file (process) result (file) class(process_t), intent(in) :: process type(string_t) :: file file = process%beam_config%get_beam_file () end function process_get_beam_file @ %def process_get_beam_file @ Pointer to the process variable list. <>= procedure :: get_var_list_ptr => process_get_var_list_ptr <>= function process_get_var_list_ptr (process) result (ptr) class(process_t), intent(in), target :: process type(var_list_t), pointer :: ptr ptr => process%env%get_var_list_ptr () end function process_get_var_list_ptr @ %def process_get_var_list_ptr @ Pointer to the common model. <>= procedure :: get_model_ptr => process_get_model_ptr <>= function process_get_model_ptr (process) result (ptr) class(process_t), intent(in) :: process class(model_data_t), pointer :: ptr ptr => process%config%model end function process_get_model_ptr @ %def process_get_model_ptr @ Use the embedded RNG factory to spawn a new random-number generator instance. (This modifies the state of the factory.) <>= procedure :: make_rng => process_make_rng <>= subroutine process_make_rng (process, rng) class(process_t), intent(inout) :: process class(rng_t), intent(out), allocatable :: rng if (allocated (process%rng_factory)) then call process%rng_factory%make (rng) else call msg_bug ("Process: make rng: factory not allocated") end if end subroutine process_make_rng @ %def process_make_rng @ \subsection{Compute an amplitude} Each process variant should allow for computing an amplitude value directly, without generating a process instance. The process component is selected by the index [[i]]. The term within the process component is selected by [[j]]. The momentum combination is transferred as the array [[p]]. The function sets the specific quantum state via the indices of a flavor [[f]], helicity [[h]], and color [[c]] combination. Each index refers to the list of flavor, helicity, and color states, respectively, as stored in the process data. Optionally, we may set factorization and renormalization scale. If unset, the partonic c.m.\ energy is inserted. The function checks arguments for validity. For invalid arguments (quantum states), we return zero. <>= procedure :: compute_amplitude => process_compute_amplitude <>= function process_compute_amplitude & (process, i_core, i, j, p, f, h, c, fac_scale, ren_scale, alpha_qcd_forced) & result (amp) class(process_t), intent(in), target :: process integer, intent(in) :: i_core integer, intent(in) :: i, j type(vector4_t), dimension(:), intent(in) :: p integer, intent(in) :: f, h, c real(default), intent(in), optional :: fac_scale, ren_scale real(default), intent(in), allocatable, optional :: alpha_qcd_forced real(default) :: fscale, rscale real(default), allocatable :: aqcd_forced complex(default) :: amp class(prc_core_t), pointer :: core amp = 0 if (0 < i .and. i <= process%meta%n_components) then if (process%component(i)%active) then associate (core => process%core_entry(i_core)%core) associate (data => core%data) if (size (p) == data%n_in + data%n_out & .and. 0 < f .and. f <= data%n_flv & .and. 0 < h .and. h <= data%n_hel & .and. 0 < c .and. c <= data%n_col) then if (present (fac_scale)) then fscale = fac_scale else fscale = sum (p(data%n_in+1:)) ** 1 end if if (present (ren_scale)) then rscale = ren_scale else rscale = fscale end if if (present (alpha_qcd_forced)) then if (allocated (alpha_qcd_forced)) & allocate (aqcd_forced, source = alpha_qcd_forced) end if amp = core%compute_amplitude (j, p, f, h, c, & fscale, rscale, aqcd_forced) end if end associate end associate else amp = 0 end if end if end function process_compute_amplitude @ %def process_compute_amplitude @ Sanity check for the process library. We abort the program if it has changed after process initialization. <>= procedure :: check_library_sanity => process_check_library_sanity <>= subroutine process_check_library_sanity (process) class(process_t), intent(in) :: process call process%env%check_lib_sanity (process%meta) end subroutine process_check_library_sanity @ %def process_check_library_sanity @ Reset the association to a process library. <>= procedure :: reset_library_ptr => process_reset_library_ptr <>= subroutine process_reset_library_ptr (process) class(process_t), intent(inout) :: process call process%env%reset_lib_ptr () end subroutine process_reset_library_ptr @ %def process_reset_library_ptr @ <>= procedure :: set_component_type => process_set_component_type <>= subroutine process_set_component_type (process, i_component, i_type) class(process_t), intent(inout) :: process integer, intent(in) :: i_component, i_type process%component(i_component)%component_type = i_type end subroutine process_set_component_type @ %def process_set_component_type @ <>= procedure :: set_counter_mci_entry => process_set_counter_mci_entry <>= subroutine process_set_counter_mci_entry (process, i_mci, counter) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci type(process_counter_t), intent(in) :: counter process%mci_entry(i_mci)%counter = counter end subroutine process_set_counter_mci_entry @ %def process_set_counter_mci_entry @ This is for suppression of numerical noise in the integration results stored in the [[process_mci_entry]] type. As the error and efficiency enter the MD5 sum, we recompute it. <>= procedure :: pacify => process_pacify <>= subroutine process_pacify (process, efficiency_reset, error_reset) class(process_t), intent(inout) :: process logical, intent(in), optional :: efficiency_reset, error_reset logical :: eff_reset, err_reset integer :: i eff_reset = .false. err_reset = .false. if (present (efficiency_reset)) eff_reset = efficiency_reset if (present (error_reset)) err_reset = error_reset if (allocated (process%mci_entry)) then do i = 1, size (process%mci_entry) call process%mci_entry(i)%results%pacify (efficiency_reset) if (allocated (process%mci_entry(i)%mci)) then associate (mci => process%mci_entry(i)%mci) if (process%mci_entry(i)%mci%error_known & .and. err_reset) & mci%error = 0 if (process%mci_entry(i)%mci%efficiency_known & .and. eff_reset) & mci%efficiency = 1 call mci%pacify (efficiency_reset, error_reset) call mci%compute_md5sum () end associate end if end do end if end subroutine process_pacify @ %def process_pacify @ The following methods are used only in the unit tests; the access process internals directly that would otherwise be hidden. <>= procedure :: test_allocate_sf_channels procedure :: test_set_component_sf_channel procedure :: test_get_mci_ptr <>= subroutine test_allocate_sf_channels (process, n) class(process_t), intent(inout) :: process integer, intent(in) :: n call process%beam_config%allocate_sf_channels (n) end subroutine test_allocate_sf_channels subroutine test_set_component_sf_channel (process, c) class(process_t), intent(inout) :: process integer, dimension(:), intent(in) :: c call process%component(1)%phs_config%set_sf_channel (c) end subroutine test_set_component_sf_channel subroutine test_get_mci_ptr (process, mci) class(process_t), intent(in), target :: process class(mci_t), intent(out), pointer :: mci mci => process%mci_entry(1)%mci end subroutine test_get_mci_ptr @ %def test_allocate_sf_channels @ %def test_set_component_sf_channel @ %def test_get_mci_ptr @ <>= procedure :: init_mci_work => process_init_mci_work <>= subroutine process_init_mci_work (process, mci_work, i) class(process_t), intent(in), target :: process type(mci_work_t), intent(out) :: mci_work integer, intent(in) :: i call mci_work%init (process%mci_entry(i)) end subroutine process_init_mci_work @ %def process_init_mci_work @ Prepare the process core with type [[test_me]], or otherwise the externally provided [[type_string]] version. The toy dispatchers as a procedure argument come handy, knowing that we need to support only the [[test_me]] and [[template]] matrix-element types. <>= procedure :: setup_test_cores => process_setup_test_cores <>= subroutine process_setup_test_cores (process, type_string) class(process_t), intent(inout) :: process class(prc_core_t), allocatable :: core type(string_t), intent(in), optional :: type_string if (present (type_string)) then select case (char (type_string)) case ("template") call process%setup_cores (dispatch_template_core) case ("test_me") call process%setup_cores (dispatch_test_me_core) case default call msg_bug ("process setup test cores: unsupported type string") end select else call process%setup_cores (dispatch_test_me_core) end if end subroutine process_setup_test_cores subroutine dispatch_test_me_core (core, core_def, model, & helicity_selection, qcd, use_color_factors, has_beam_pol) use prc_test_core, only: test_t class(prc_core_t), allocatable, intent(inout) :: core class(prc_core_def_t), intent(in) :: core_def class(model_data_t), intent(in), target, optional :: model type(helicity_selection_t), intent(in), optional :: helicity_selection type(qcd_t), intent(in), optional :: qcd logical, intent(in), optional :: use_color_factors logical, intent(in), optional :: has_beam_pol allocate (test_t :: core) end subroutine dispatch_test_me_core subroutine dispatch_template_core (core, core_def, model, & helicity_selection, qcd, use_color_factors, has_beam_pol) use prc_template_me, only: prc_template_me_t class(prc_core_t), allocatable, intent(inout) :: core class(prc_core_def_t), intent(in) :: core_def class(model_data_t), intent(in), target, optional :: model type(helicity_selection_t), intent(in), optional :: helicity_selection type(qcd_t), intent(in), optional :: qcd logical, intent(in), optional :: use_color_factors logical, intent(in), optional :: has_beam_pol allocate (prc_template_me_t :: core) select type (core) type is (prc_template_me_t) call core%set_parameters (model) end select end subroutine dispatch_template_core @ %def process_setup_test_cores @ <>= procedure :: get_connected_states => process_get_connected_states <>= function process_get_connected_states (process, i_component, & connected_terms) result (connected) type(connected_state_t), dimension(:), allocatable :: connected class(process_t), intent(in) :: process integer, intent(in) :: i_component type(connected_state_t), dimension(:), intent(in) :: connected_terms integer :: i, i_conn integer :: n_conn n_conn = 0 do i = 1, process%get_n_terms () if (process%term(i)%i_component == i_component) then n_conn = n_conn + 1 end if end do allocate (connected (n_conn)) i_conn = 1 do i = 1, process%get_n_terms () if (process%term(i)%i_component == i_component) then connected (i_conn) = connected_terms(i) i_conn = i_conn + 1 end if end do end function process_get_connected_states @ %def process_get_connected_states @ \subsection{NLO specifics} These subroutines (and the NLO specific properties they work on) could potentially be moved to [[pcm_nlo_t]] and used more generically in [[process_t]] with an appropriate interface in [[pcm_t]] TODO wk 2018: This is used only by event initialization, which deals with an incomplete process object. <>= procedure :: init_nlo_settings => process_init_nlo_settings <>= subroutine process_init_nlo_settings (process, var_list) class(process_t), intent(inout) :: process type(var_list_t), intent(in), target :: var_list select type (pcm => process%pcm) type is (pcm_nlo_t) call pcm%init_nlo_settings (var_list) if (debug_active (D_SUBTRACTION) .or. debug_active (D_VIRTUAL)) & call pcm%settings%write () class default call msg_fatal ("Attempt to set nlo_settings with a non-NLO pcm!") end select end subroutine process_init_nlo_settings @ %def process_init_nlo_settings @ <>= generic :: get_nlo_type_component => get_nlo_type_component_single procedure :: get_nlo_type_component_single => process_get_nlo_type_component_single <>= elemental function process_get_nlo_type_component_single (process, i_component) result (val) integer :: val class(process_t), intent(in) :: process integer, intent(in) :: i_component val = process%component(i_component)%get_nlo_type () end function process_get_nlo_type_component_single @ %def process_get_nlo_type_component_single @ <>= generic :: get_nlo_type_component => get_nlo_type_component_all procedure :: get_nlo_type_component_all => process_get_nlo_type_component_all <>= pure function process_get_nlo_type_component_all (process) result (val) integer, dimension(:), allocatable :: val class(process_t), intent(in) :: process allocate (val (size (process%component))) val = process%component%get_nlo_type () end function process_get_nlo_type_component_all @ %def process_get_nlo_type_component_all @ <>= procedure :: is_nlo_calculation => process_is_nlo_calculation <>= function process_is_nlo_calculation (process) result (nlo) logical :: nlo class(process_t), intent(in) :: process select type (pcm => process%pcm) type is (pcm_nlo_t) nlo = .true. class default nlo = .false. end select end function process_is_nlo_calculation @ %def process_is_nlo_calculation @ <>= procedure :: get_negative_sf => process_get_negative_sf <>= function process_get_negative_sf (process) result (neg_sf) logical :: neg_sf class(process_t), intent(in) :: process neg_sf = process%config%process_def%get_negative_sf () end function process_get_negative_sf @ %def process_get_negative_sf @ <>= procedure :: is_combined_nlo_integration & => process_is_combined_nlo_integration <>= function process_is_combined_nlo_integration (process) result (combined) logical :: combined class(process_t), intent(in) :: process select type (pcm => process%pcm) type is (pcm_nlo_t) combined = pcm%settings%combined_integration class default combined = .false. end select end function process_is_combined_nlo_integration @ %def process_is_combined_nlo_integration @ <>= procedure :: component_is_real_finite => process_component_is_real_finite <>= pure function process_component_is_real_finite (process, i_component) & result (val) logical :: val class(process_t), intent(in) :: process integer, intent(in) :: i_component val = process%component(i_component)%component_type == COMP_REAL_FIN end function process_component_is_real_finite @ %def process_component_is_real_finite @ Return nlo data of a process component <>= procedure :: get_component_nlo_type => process_get_component_nlo_type <>= elemental function process_get_component_nlo_type (process, i_component) & result (nlo_type) integer :: nlo_type class(process_t), intent(in) :: process integer, intent(in) :: i_component nlo_type = process%component(i_component)%config%get_nlo_type () end function process_get_component_nlo_type @ %def process_get_component_nlo_type @ Return a pointer to the core that belongs to a component. <>= procedure :: get_component_core_ptr => process_get_component_core_ptr <>= function process_get_component_core_ptr (process, i_component) result (core) class(process_t), intent(in), target :: process integer, intent(in) :: i_component class(prc_core_t), pointer :: core integer :: i_core i_core = process%pcm%get_i_core(i_component) core => process%core_entry(i_core)%core end function process_get_component_core_ptr @ %def process_get_component_core_ptr @ <>= procedure :: get_component_associated_born & => process_get_component_associated_born <>= function process_get_component_associated_born (process, i_component) & result (i_born) class(process_t), intent(in) :: process integer, intent(in) :: i_component integer :: i_born i_born = process%component(i_component)%config%get_associated_born () end function process_get_component_associated_born @ %def process_get_component_associated_born @ <>= procedure :: get_first_real_component => process_get_first_real_component <>= function process_get_first_real_component (process) result (i_real) integer :: i_real class(process_t), intent(in) :: process i_real = process%component(1)%config%get_associated_real () end function process_get_first_real_component @ %def process_get_first_real_component @ <>= procedure :: get_first_real_term => process_get_first_real_term <>= function process_get_first_real_term (process) result (i_real) integer :: i_real class(process_t), intent(in) :: process integer :: i_component, i_term i_component = process%component(1)%config%get_associated_real () i_real = 0 do i_term = 1, size (process%term) if (process%term(i_term)%i_component == i_component) then i_real = i_term exit end if end do if (i_real == 0) call msg_fatal ("Did not find associated real term!") end function process_get_first_real_term @ %def process_get_first_real_term @ <>= procedure :: get_associated_real_fin => process_get_associated_real_fin <>= elemental function process_get_associated_real_fin (process, i_component) result (i_real) integer :: i_real class(process_t), intent(in) :: process integer, intent(in) :: i_component i_real = process%component(i_component)%config%get_associated_real_fin () end function process_get_associated_real_fin @ %def process_get_associated_real_fin @ <>= procedure :: select_i_term => process_select_i_term <>= pure function process_select_i_term (process, i_mci) result (i_term) integer :: i_term class(process_t), intent(in) :: process integer, intent(in) :: i_mci integer :: i_component, i_sub i_component = process%mci_entry(i_mci)%i_component(1) i_term = process%component(i_component)%i_term(1) i_sub = process%term(i_term)%i_sub if (i_sub > 0) & i_term = process%term(i_sub)%i_term_global end function process_select_i_term @ %def process_select_i_term @ Would be better to do this at the level of the writer of the core but one has to bring NLO information there. <>= procedure :: prepare_any_external_code & => process_prepare_any_external_code <>= subroutine process_prepare_any_external_code (process) class(process_t), intent(inout), target :: process integer :: i if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, & "process_prepare_external_code") associate (pcm => process%pcm) do i = 1, pcm%n_cores call pcm%prepare_any_external_code ( & process%core_entry(i), i, & process%get_library_name (), & process%config%model, & process%env%get_var_list_ptr ()) end do end associate end subroutine process_prepare_any_external_code @ %def process_prepare_any_external_code @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Process config} <<[[process_config.f90]]>>= <> module process_config <> <> use format_utils, only: write_separator use io_units use md5 use os_interface use diagnostics use sf_base use sf_mappings use mappings, only: mapping_defaults_t use phs_forests, only: phs_parameters_t use sm_qcd use physics_defs use integration_results use model_data use models use interactions use quantum_numbers use flavors use helicities use colors use rng_base use state_matrices use process_libraries use process_constants use prc_core use prc_external use prc_openloops, only: prc_openloops_t use prc_threshold, only: prc_threshold_t use beams use dispatch_beams, only: dispatch_qcd use mci_base use beam_structures use phs_base use variables use expr_base use blha_olp_interfaces, only: prc_blha_t <> <> <> <> contains <> end module process_config @ %def process_config @ Identifiers for the NLO setup. <>= integer, parameter, public :: COMP_DEFAULT = 0 integer, parameter, public :: COMP_REAL_FIN = 1 integer, parameter, public :: COMP_MASTER = 2 integer, parameter, public :: COMP_VIRT = 3 integer, parameter, public :: COMP_REAL = 4 integer, parameter, public :: COMP_REAL_SING = 5 integer, parameter, public :: COMP_MISMATCH = 6 integer, parameter, public :: COMP_PDF = 7 integer, parameter, public :: COMP_SUB = 8 integer, parameter, public :: COMP_RESUM = 9 @ \subsection{Output selection flags} We declare a number of identifiers for write methods, so they only displays selected parts. The identifiers can be supplied to the [[vlist]] array argument of the standard F2008 derived-type writer call. <>= integer, parameter, public :: F_PACIFY = 1 integer, parameter, public :: F_SHOW_VAR_LIST = 11 integer, parameter, public :: F_SHOW_EXPRESSIONS = 12 integer, parameter, public :: F_SHOW_LIB = 13 integer, parameter, public :: F_SHOW_MODEL = 14 integer, parameter, public :: F_SHOW_QCD = 15 integer, parameter, public :: F_SHOW_OS_DATA = 16 integer, parameter, public :: F_SHOW_RNG = 17 integer, parameter, public :: F_SHOW_BEAMS = 18 @ %def SHOW_VAR_LIST @ %def SHOW_EXPRESSIONS @ This is a simple function that returns true if a flag value is present in [[v_list]], but not its negative. If neither is present, it returns [[default]]. <>= public :: flagged <>= function flagged (v_list, id, def) result (flag) logical :: flag integer, dimension(:), intent(in) :: v_list integer, intent(in) :: id logical, intent(in), optional :: def logical :: default_result default_result = .false.; if (present (def)) default_result = def if (default_result) then flag = all (v_list /= -id) else flag = all (v_list /= -id) .and. any (v_list == id) end if end function flagged @ %def flagged @ Related: if flag is set (unset), append [[value]] (its negative) to the [[v_list]], respectively. [[v_list]] must be allocated. <>= public :: set_flag <>= subroutine set_flag (v_list, value, flag) integer, dimension(:), intent(inout), allocatable :: v_list integer, intent(in) :: value logical, intent(in), optional :: flag if (present (flag)) then if (flag) then v_list = [v_list, value] else v_list = [v_list, -value] end if end if end subroutine set_flag @ %def set_flag @ \subsection{Generic configuration data} This information concerns physical and technical properties of the process. It is fixed upon initialization, using data from the process specification and the variable list. The number [[n_in]] is the number of incoming beam particles, simultaneously the number of incoming partons, 1 for a decay and 2 for a scattering process. (The number of outgoing partons may depend on the process component.) The number [[n_components]] is the number of components that constitute the current process. The number [[n_terms]] is the number of distinct contributions to the scattering matrix that constitute the current process. Each component may generate several terms. The number [[n_mci]] is the number of independent MC integration configurations that this process uses. Distinct process components that share a MCI configuration may be combined pointwise. (Nevertheless, a given MC variable set may correspond to several ``nearby'' kinematical configurations.) This is also the number of distinct sampling-function results that this process can generate. Process components that use distinct variable sets are added only once after an integration pass has completed. The [[model]] pointer identifies the physics model and its parameters. This is a pointer to an external object. Various [[parse_node_t]] objects are taken from the SINDARIN input. They encode expressions for evaluating cuts and scales. The workspaces for evaluating those expressions are set up in the [[effective_state]] subobjects. Note that these are really pointers, so the actual nodes are not stored inside the process object. The [[md5sum]] is taken and used to verify the process configuration when re-reading data from file. <>= public :: process_config_data_t <>= type :: process_config_data_t class(process_def_t), pointer :: process_def => null () integer :: n_in = 0 integer :: n_components = 0 integer :: n_terms = 0 integer :: n_mci = 0 type(string_t) :: model_name class(model_data_t), pointer :: model => null () type(qcd_t) :: qcd class(expr_factory_t), allocatable :: ef_cuts class(expr_factory_t), allocatable :: ef_scale class(expr_factory_t), allocatable :: ef_fac_scale class(expr_factory_t), allocatable :: ef_ren_scale class(expr_factory_t), allocatable :: ef_weight character(32) :: md5sum = "" contains <> end type process_config_data_t @ %def process_config_data_t @ Here, we may compress the expressions for cuts etc. <>= procedure :: write => process_config_data_write <>= subroutine process_config_data_write (config, u, counters, model, expressions) class(process_config_data_t), intent(in) :: config integer, intent(in) :: u logical, intent(in) :: counters logical, intent(in) :: model logical, intent(in) :: expressions write (u, "(1x,A)") "Configuration data:" if (counters) then write (u, "(3x,A,I0)") "Number of incoming particles = ", & config%n_in write (u, "(3x,A,I0)") "Number of process components = ", & config%n_components write (u, "(3x,A,I0)") "Number of process terms = ", & config%n_terms write (u, "(3x,A,I0)") "Number of MCI configurations = ", & config%n_mci end if if (associated (config%model)) then write (u, "(3x,A,A)") "Model = ", char (config%model_name) if (model) then call write_separator (u) call config%model%write (u) call write_separator (u) end if else write (u, "(3x,A,A,A)") "Model = ", char (config%model_name), & " [not associated]" end if call config%qcd%write (u, show_md5sum = .false.) call write_separator (u) if (expressions) then if (allocated (config%ef_cuts)) then call write_separator (u) write (u, "(3x,A)") "Cut expression:" call config%ef_cuts%write (u) end if if (allocated (config%ef_scale)) then call write_separator (u) write (u, "(3x,A)") "Scale expression:" call config%ef_scale%write (u) end if if (allocated (config%ef_fac_scale)) then call write_separator (u) write (u, "(3x,A)") "Factorization scale expression:" call config%ef_fac_scale%write (u) end if if (allocated (config%ef_ren_scale)) then call write_separator (u) write (u, "(3x,A)") "Renormalization scale expression:" call config%ef_ren_scale%write (u) end if if (allocated (config%ef_weight)) then call write_separator (u) write (u, "(3x,A)") "Weight expression:" call config%ef_weight%write (u) end if else call write_separator (u) write (u, "(3x,A)") "Expressions (cut, scales, weight): [not shown]" end if if (config%md5sum /= "") then call write_separator (u) write (u, "(3x,A,A,A)") "MD5 sum (config) = '", config%md5sum, "'" end if end subroutine process_config_data_write @ %def process_config_data_write @ Initialize. We use information from the process metadata and from the process library, given the process ID. We also store the currently active OS data set. The model pointer references the model data within the [[env]] record. That should be an instance of the global model. We initialize the QCD object, unless the environment information is unavailable (unit tests). The RNG factory object is imported by moving the allocation. <>= procedure :: init => process_config_data_init <>= subroutine process_config_data_init (config, meta, env) class(process_config_data_t), intent(out) :: config type(process_metadata_t), intent(in) :: meta type(process_environment_t), intent(in) :: env config%process_def => env%lib%get_process_def_ptr (meta%id) config%n_in = config%process_def%get_n_in () config%n_components = size (meta%component_id) config%model => env%get_model_ptr () config%model_name = config%model%get_name () if (env%got_var_list ()) then call dispatch_qcd & (config%qcd, env%get_var_list_ptr (), env%get_os_data ()) end if end subroutine process_config_data_init @ %def process_config_data_init @ Current implementation: nothing to finalize. <>= procedure :: final => process_config_data_final <>= subroutine process_config_data_final (config) class(process_config_data_t), intent(inout) :: config end subroutine process_config_data_final @ %def process_config_data_final @ Return a copy of the QCD data block. <>= procedure :: get_qcd => process_config_data_get_qcd <>= function process_config_data_get_qcd (config) result (qcd) class(process_config_data_t), intent(in) :: config type(qcd_t) :: qcd qcd = config%qcd end function process_config_data_get_qcd @ %def process_config_data_get_qcd @ Compute the MD5 sum of the configuration data. This encodes, in particular, the model and the expressions for cut, scales, weight, etc. It should not contain the IDs and number of components, etc., since the MD5 sum should be useful for integrating individual components. This is done only once. If the MD5 sum is nonempty, the calculation is skipped. <>= procedure :: compute_md5sum => process_config_data_compute_md5sum <>= subroutine process_config_data_compute_md5sum (config) class(process_config_data_t), intent(inout) :: config integer :: u if (config%md5sum == "") then u = free_unit () open (u, status = "scratch", action = "readwrite") call config%write (u, counters = .false., & model = .true., expressions = .true.) rewind (u) config%md5sum = md5sum (u) close (u) end if end subroutine process_config_data_compute_md5sum @ %def process_config_data_compute_md5sum @ <>= procedure :: get_md5sum => process_config_data_get_md5sum <>= pure function process_config_data_get_md5sum (config) result (md5) character(32) :: md5 class(process_config_data_t), intent(in) :: config md5 = config%md5sum end function process_config_data_get_md5sum @ %def process_config_data_get_md5sum @ \subsection{Environment} This record stores a snapshot of the process environment at the point where the process object is created. Model and variable list are implemented as pointer, so they always have the [[target]] attribute. For unit-testing purposes, setting the var list is optional. If not set, the pointer is null. <>= public :: process_environment_t <>= type :: process_environment_t private type(model_t), pointer :: model => null () type(var_list_t), pointer :: var_list => null () logical :: var_list_is_set = .false. type(process_library_t), pointer :: lib => null () type(beam_structure_t) :: beam_structure type(os_data_t) :: os_data contains <> end type process_environment_t @ %def process_environment_t @ Model and local var list are snapshots and need a finalizer. <>= procedure :: final => process_environment_final <>= subroutine process_environment_final (env) class(process_environment_t), intent(inout) :: env if (associated (env%model)) then call env%model%final () deallocate (env%model) end if if (associated (env%var_list)) then call env%var_list%final (follow_link=.true.) deallocate (env%var_list) end if end subroutine process_environment_final @ %def process_environment_final @ Output, DTIO compatible. <>= procedure :: write => process_environment_write procedure :: write_formatted => process_environment_write_formatted ! generic :: write (formatted) => write_formatted <>= subroutine process_environment_write (env, unit, & show_var_list, show_model, show_lib, show_beams, show_os_data) class(process_environment_t), intent(in) :: env integer, intent(in), optional :: unit logical, intent(in), optional :: show_var_list logical, intent(in), optional :: show_model logical, intent(in), optional :: show_lib logical, intent(in), optional :: show_beams logical, intent(in), optional :: show_os_data integer :: u, iostat integer, dimension(:), allocatable :: v_list character(0) :: iomsg u = given_output_unit (unit) allocate (v_list (0)) call set_flag (v_list, F_SHOW_VAR_LIST, show_var_list) call set_flag (v_list, F_SHOW_MODEL, show_model) call set_flag (v_list, F_SHOW_LIB, show_lib) call set_flag (v_list, F_SHOW_BEAMS, show_beams) call set_flag (v_list, F_SHOW_OS_DATA, show_os_data) call env%write_formatted (u, "LISTDIRECTED", v_list, iostat, iomsg) end subroutine process_environment_write @ %def process_environment_write @ DTIO standard write. <>= subroutine process_environment_write_formatted & (dtv, unit, iotype, v_list, iostat, iomsg) class(process_environment_t), intent(in) :: dtv integer, intent(in) :: unit character(*), intent(in) :: iotype integer, dimension(:), intent(in) :: v_list integer, intent(out) :: iostat character(*), intent(inout) :: iomsg associate (env => dtv) if (flagged (v_list, F_SHOW_VAR_LIST, .true.)) then write (unit, "(1x,A)") "Variable list:" if (associated (env%var_list)) then call write_separator (unit) call env%var_list%write (unit) else write (unit, "(3x,A)") "[not allocated]" end if call write_separator (unit) end if if (flagged (v_list, F_SHOW_MODEL, .true.)) then write (unit, "(1x,A)") "Model:" if (associated (env%model)) then call write_separator (unit) call env%model%write (unit) else write (unit, "(3x,A)") "[not allocated]" end if call write_separator (unit) end if if (flagged (v_list, F_SHOW_LIB, .true.)) then write (unit, "(1x,A)") "Process library:" if (associated (env%lib)) then call write_separator (unit) call env%lib%write (unit) else write (unit, "(3x,A)") "[not allocated]" end if end if if (flagged (v_list, F_SHOW_BEAMS, .true.)) then call write_separator (unit) call env%beam_structure%write (unit) end if if (flagged (v_list, F_SHOW_OS_DATA, .true.)) then write (unit, "(1x,A)") "Operating-system data:" call write_separator (unit) call env%os_data%write (unit) end if end associate iostat = 0 end subroutine process_environment_write_formatted @ %def process_environment_write_formatted @ Initialize: Make a snapshot of the provided model. Make a link to the current process library. Also make a snapshot of the variable list, if provided. If none is provided, there is an empty variable list nevertheless, so a pointer lookup does not return null. If no beam structure is provided, the beam-structure member is empty and will yield a number of zero beams when queried. <>= procedure :: init => process_environment_init <>= subroutine process_environment_init & (env, model, lib, os_data, var_list, beam_structure) class(process_environment_t), intent(out) :: env type(model_t), intent(in), target :: model type(process_library_t), intent(in), target :: lib type(os_data_t), intent(in) :: os_data type(var_list_t), intent(in), target, optional :: var_list type(beam_structure_t), intent(in), optional :: beam_structure allocate (env%model) call env%model%init_instance (model) env%lib => lib env%os_data = os_data allocate (env%var_list) if (present (var_list)) then call env%var_list%init_snapshot (var_list, follow_link=.true.) env%var_list_is_set = .true. end if if (present (beam_structure)) then env%beam_structure = beam_structure end if end subroutine process_environment_init @ %def process_environment_init @ Indicate whether a variable list has been provided upon initialization. <>= procedure :: got_var_list => process_environment_got_var_list <>= function process_environment_got_var_list (env) result (flag) class(process_environment_t), intent(in) :: env logical :: flag flag = env%var_list_is_set end function process_environment_got_var_list @ %def process_environment_got_var_list @ Return a pointer to the variable list. <>= procedure :: get_var_list_ptr => process_environment_get_var_list_ptr <>= function process_environment_get_var_list_ptr (env) result (var_list) class(process_environment_t), intent(in) :: env type(var_list_t), pointer :: var_list var_list => env%var_list end function process_environment_get_var_list_ptr @ %def process_environment_get_var_list_ptr @ Return a pointer to the model, if it exists. <>= procedure :: get_model_ptr => process_environment_get_model_ptr <>= function process_environment_get_model_ptr (env) result (model) class(process_environment_t), intent(in) :: env type(model_t), pointer :: model model => env%model end function process_environment_get_model_ptr @ %def process_environment_get_model_ptr @ Return the process library pointer. <>= procedure :: get_lib_ptr => process_environment_get_lib_ptr <>= function process_environment_get_lib_ptr (env) result (lib) class(process_environment_t), intent(inout) :: env type(process_library_t), pointer :: lib lib => env%lib end function process_environment_get_lib_ptr @ %def process_environment_get_lib_ptr @ Clear the process library pointer, in case the library is deleted. <>= procedure :: reset_lib_ptr => process_environment_reset_lib_ptr <>= subroutine process_environment_reset_lib_ptr (env) class(process_environment_t), intent(inout) :: env env%lib => null () end subroutine process_environment_reset_lib_ptr @ %def process_environment_reset_lib_ptr @ Check whether the process library has changed, in case the library is recompiled, etc. <>= procedure :: check_lib_sanity => process_environment_check_lib_sanity <>= subroutine process_environment_check_lib_sanity (env, meta) class(process_environment_t), intent(in) :: env type(process_metadata_t), intent(in) :: meta if (associated (env%lib)) then if (env%lib%get_update_counter () /= meta%lib_update_counter) then call msg_fatal ("Process '" // char (meta%id) & // "': library has been recompiled after integration") end if end if end subroutine process_environment_check_lib_sanity @ %def process_environment_check_lib_sanity @ Fill the [[data]] block using the appropriate process-library access entry. <>= procedure :: fill_process_constants => & process_environment_fill_process_constants <>= subroutine process_environment_fill_process_constants & (env, id, i_component, data) class(process_environment_t), intent(in) :: env type(string_t), intent(in) :: id integer, intent(in) :: i_component type(process_constants_t), intent(out) :: data call env%lib%fill_constants (id, i_component, data) end subroutine process_environment_fill_process_constants @ %def process_environment_fill_process_constants @ Return the entire beam structure. <>= procedure :: get_beam_structure => process_environment_get_beam_structure <>= function process_environment_get_beam_structure (env) result (beam_structure) class(process_environment_t), intent(in) :: env type(beam_structure_t) :: beam_structure beam_structure = env%beam_structure end function process_environment_get_beam_structure @ %def process_environment_get_beam_structure @ Check the beam structure for PDFs. <>= procedure :: has_pdfs => process_environment_has_pdfs <>= function process_environment_has_pdfs (env) result (flag) class(process_environment_t), intent(in) :: env logical :: flag flag = env%beam_structure%has_pdf () end function process_environment_has_pdfs @ %def process_environment_has_pdfs @ Check the beam structure for polarized beams. <>= procedure :: has_polarized_beams => process_environment_has_polarized_beams <>= function process_environment_has_polarized_beams (env) result (flag) class(process_environment_t), intent(in) :: env logical :: flag flag = env%beam_structure%has_polarized_beams () end function process_environment_has_polarized_beams @ %def process_environment_has_polarized_beams @ Return a copy of the OS data block. <>= procedure :: get_os_data => process_environment_get_os_data <>= function process_environment_get_os_data (env) result (os_data) class(process_environment_t), intent(in) :: env type(os_data_t) :: os_data os_data = env%os_data end function process_environment_get_os_data @ %def process_environment_get_os_data @ \subsection{Metadata} This information describes the process. It is fixed upon initialization. The [[id]] string is the name of the process object, as given by the user. The matrix element generator will use this string for naming Fortran procedures and types, so it should qualify as a Fortran name. The [[num_id]] is meaningful if nonzero. It is used for communication with external programs or file standards which do not support string IDs. The [[run_id]] string distinguishes among several runs for the same process. It identifies process instances with respect to adapted integration grids and similar run-specific data. The run ID is kept when copying processes for creating instances, however, so it does not distinguish event samples. The [[lib_name]] identifies the process library where the process definition and the process driver are located. The [[lib_index]] is the index of entry in the process library that corresponds to the current process. The [[component_id]] array identifies the individual process components. The [[component_description]] is an array of human-readable strings that characterize the process components, for instance [[a, b => c, d]]. The [[active]] mask array marks those components which are active. The others are skipped. <>= public :: process_metadata_t <>= type :: process_metadata_t integer :: type = PRC_UNKNOWN type(string_t) :: id integer :: num_id = 0 type(string_t) :: run_id type(string_t), allocatable :: lib_name integer :: lib_update_counter = 0 integer :: lib_index = 0 integer :: n_components = 0 type(string_t), dimension(:), allocatable :: component_id type(string_t), dimension(:), allocatable :: component_description logical, dimension(:), allocatable :: active contains <> end type process_metadata_t @ %def process_metadata_t @ Output: ID and run ID. We write the variable list only upon request. <>= procedure :: write => process_metadata_write <>= subroutine process_metadata_write (meta, u, screen) class(process_metadata_t), intent(in) :: meta integer, intent(in) :: u logical, intent(in) :: screen integer :: i select case (meta%type) case (PRC_UNKNOWN) if (screen) then write (msg_buffer, "(A)") "Process [undefined]" else write (u, "(1x,A)") "Process [undefined]" end if return case (PRC_DECAY) if (screen) then write (msg_buffer, "(A,1x,A,A,A)") "Process [decay]:", & "'", char (meta%id), "'" else write (u, "(1x,A)", advance="no") "Process [decay]:" end if case (PRC_SCATTERING) if (screen) then write (msg_buffer, "(A,1x,A,A,A)") "Process [scattering]:", & "'", char (meta%id), "'" else write (u, "(1x,A)", advance="no") "Process [scattering]:" end if case default call msg_bug ("process_write: undefined process type") end select if (screen) then call msg_message () else write (u, "(1x,A,A,A)") "'", char (meta%id), "'" end if if (meta%num_id /= 0) then if (screen) then write (msg_buffer, "(2x,A,I0)") "ID (num) = ", meta%num_id call msg_message () else write (u, "(3x,A,I0)") "ID (num) = ", meta%num_id end if end if if (screen) then if (meta%run_id /= "") then write (msg_buffer, "(2x,A,A,A)") "Run ID = '", & char (meta%run_id), "'" call msg_message () end if else write (u, "(3x,A,A,A)") "Run ID = '", char (meta%run_id), "'" end if if (allocated (meta%lib_name)) then if (screen) then write (msg_buffer, "(2x,A,A,A)") "Library name = '", & char (meta%lib_name), "'" call msg_message () else write (u, "(3x,A,A,A)") "Library name = '", & char (meta%lib_name), "'" end if else if (screen) then write (msg_buffer, "(2x,A)") "Library name = [not associated]" call msg_message () else write (u, "(3x,A)") "Library name = [not associated]" end if end if if (screen) then write (msg_buffer, "(2x,A,I0)") "Process index = ", meta%lib_index call msg_message () else write (u, "(3x,A,I0)") "Process index = ", meta%lib_index end if if (allocated (meta%component_id)) then if (screen) then if (any (meta%active)) then write (msg_buffer, "(2x,A)") "Process components:" else write (msg_buffer, "(2x,A)") "Process components: [none]" end if call msg_message () else write (u, "(3x,A)") "Process components:" end if do i = 1, size (meta%component_id) if (.not. meta%active(i)) cycle if (screen) then write (msg_buffer, "(4x,I0,9A)") i, ": '", & char (meta%component_id (i)), "': ", & char (meta%component_description (i)) call msg_message () else write (u, "(5x,I0,9A)") i, ": '", & char (meta%component_id (i)), "': ", & char (meta%component_description (i)) end if end do end if if (screen) then write (msg_buffer, "(A)") repeat ("-", 72) call msg_message () else call write_separator (u) end if end subroutine process_metadata_write @ %def process_metadata_write @ Short output: list components. <>= procedure :: show => process_metadata_show <>= subroutine process_metadata_show (meta, u, model_name) class(process_metadata_t), intent(in) :: meta integer, intent(in) :: u type(string_t), intent(in) :: model_name integer :: i select case (meta%type) case (PRC_UNKNOWN) write (u, "(A)") "Process: [undefined]" return case default write (u, "(A)", advance="no") "Process:" end select write (u, "(1x,A)", advance="no") char (meta%id) select case (meta%num_id) case (0) case default write (u, "(1x,'(',I0,')')", advance="no") meta%num_id end select select case (char (model_name)) case ("") case default write (u, "(1x,'[',A,']')", advance="no") char (model_name) end select write (u, *) if (allocated (meta%component_id)) then do i = 1, size (meta%component_id) if (meta%active(i)) then write (u, "(2x,I0,':',1x,A)") i, & char (meta%component_description (i)) end if end do end if end subroutine process_metadata_show @ %def process_metadata_show @ Initialize. Find process ID and run ID. Also find the process ID in the process library and retrieve some metadata from there. <>= procedure :: init => process_metadata_init <>= subroutine process_metadata_init (meta, id, lib, var_list) class(process_metadata_t), intent(out) :: meta type(string_t), intent(in) :: id type(process_library_t), intent(in), target :: lib type(var_list_t), intent(in) :: var_list select case (lib%get_n_in (id)) case (1); meta%type = PRC_DECAY case (2); meta%type = PRC_SCATTERING case default call msg_bug ("Process '" // char (id) // "': impossible n_in") end select meta%id = id meta%run_id = var_list%get_sval (var_str ("$run_id")) allocate (meta%lib_name) meta%lib_name = lib%get_name () meta%lib_update_counter = lib%get_update_counter () if (lib%contains (id)) then meta%lib_index = lib%get_entry_index (id) meta%num_id = lib%get_num_id (id) call lib%get_component_list (id, meta%component_id) meta%n_components = size (meta%component_id) call lib%get_component_description_list & (id, meta%component_description) allocate (meta%active (meta%n_components), source = .true.) else call msg_fatal ("Process library does not contain process '" & // char (id) // "'") end if if (.not. lib%is_active ()) then call msg_bug ("Process init: inactive library not handled yet") end if end subroutine process_metadata_init @ %def process_metadata_init @ Mark a component as inactive. <>= procedure :: deactivate_component => process_metadata_deactivate_component <>= subroutine process_metadata_deactivate_component (meta, i) class(process_metadata_t), intent(inout) :: meta integer, intent(in) :: i call msg_message ("Process component '" & // char (meta%component_id(i)) // "': matrix element vanishes") meta%active(i) = .false. end subroutine process_metadata_deactivate_component @ %def process_metadata_deactivate_component @ \subsection{Phase-space configuration} A process can have a number of independent phase-space configuration entries, depending on the process definition and evaluation algorithm. Each entry holds various configuration-parameter data and the actual [[phs_config_t]] record, which can vary in concrete type. <>= public :: process_phs_config_t <>= type :: process_phs_config_t type(phs_parameters_t) :: phs_par type(mapping_defaults_t) :: mapping_defs class(phs_config_t), allocatable :: phs_config contains <> end type process_phs_config_t @ %def process_phs_config_t @ Output, DTIO compatible. <>= procedure :: write => process_phs_config_write procedure :: write_formatted => process_phs_config_write_formatted ! generic :: write (formatted) => write_formatted <>= subroutine process_phs_config_write (phs_config, unit) class(process_phs_config_t), intent(in) :: phs_config integer, intent(in), optional :: unit integer :: u, iostat integer, dimension(:), allocatable :: v_list character(0) :: iomsg u = given_output_unit (unit) allocate (v_list (0)) call phs_config%write_formatted (u, "LISTDIRECTED", v_list, iostat, iomsg) end subroutine process_phs_config_write @ %def process_phs_config_write @ DTIO standard write. <>= subroutine process_phs_config_write_formatted & (dtv, unit, iotype, v_list, iostat, iomsg) class(process_phs_config_t), intent(in) :: dtv integer, intent(in) :: unit character(*), intent(in) :: iotype integer, dimension(:), intent(in) :: v_list integer, intent(out) :: iostat character(*), intent(inout) :: iomsg associate (phs_config => dtv) write (unit, "(1x, A)") "Phase-space configuration entry:" call phs_config%phs_par%write (unit) call phs_config%mapping_defs%write (unit) end associate iostat = 0 end subroutine process_phs_config_write_formatted @ %def process_phs_config_write_formatted @ \subsection{Beam configuration} The object [[data]] holds all details about the initial beam configuration. The allocatable array [[sf]] holds the structure-function configuration blocks. There are [[n_strfun]] entries in the structure-function chain (not counting the initial beam object). We maintain [[n_channel]] independent parameterizations of this chain. If this is greater than zero, we need a multi-channel sampling algorithm, where for each point one channel is selected to generate kinematics. The number of parameters that are required for generating a structure-function chain is [[n_sfpar]]. The flag [[azimuthal_dependence]] tells whether the process setup is symmetric about the beam axis in the c.m.\ system. This implies that there is no transversal beam polarization. The flag [[lab_is_cm]] is obvious. <>= public :: process_beam_config_t <>= type :: process_beam_config_t type(beam_data_t) :: data integer :: n_strfun = 0 integer :: n_channel = 1 integer :: n_sfpar = 0 type(sf_config_t), dimension(:), allocatable :: sf type(sf_channel_t), dimension(:), allocatable :: sf_channel logical :: azimuthal_dependence = .false. logical :: lab_is_cm = .true. character(32) :: md5sum = "" logical :: sf_trace = .false. type(string_t) :: sf_trace_file contains <> end type process_beam_config_t @ %def process_beam_config_t @ Here we write beam data only if they are actually used. The [[verbose]] flag is passed to the beam-data writer. <>= procedure :: write => process_beam_config_write <>= subroutine process_beam_config_write (object, unit, verbose) class(process_beam_config_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u, i, c u = given_output_unit (unit) call object%data%write (u, verbose = verbose) if (object%data%initialized) then write (u, "(3x,A,L1)") "Azimuthal dependence = ", & object%azimuthal_dependence write (u, "(3x,A,L1)") "Lab frame is c.m. frame = ", & object%lab_is_cm if (object%md5sum /= "") then write (u, "(3x,A,A,A)") "MD5 sum (beams/strf) = '", & object%md5sum, "'" end if if (allocated (object%sf)) then do i = 1, size (object%sf) call object%sf(i)%write (u) end do if (any_sf_channel_has_mapping (object%sf_channel)) then write (u, "(1x,A,L1)") "Structure-function mappings per channel:" do c = 1, object%n_channel write (u, "(3x,I0,':')", advance="no") c call object%sf_channel(c)%write (u) end do end if end if end if end subroutine process_beam_config_write @ %def process_beam_config_write @ The beam data have a finalizer. We assume that there is none for the structure-function data. <>= procedure :: final => process_beam_config_final <>= subroutine process_beam_config_final (object) class(process_beam_config_t), intent(inout) :: object call object%data%final () end subroutine process_beam_config_final @ %def process_beam_config_final @ Initialize the beam setup with a given beam structure object. <>= procedure :: init_beam_structure => process_beam_config_init_beam_structure <>= subroutine process_beam_config_init_beam_structure & (beam_config, beam_structure, sqrts, model, decay_rest_frame) class(process_beam_config_t), intent(out) :: beam_config type(beam_structure_t), intent(in) :: beam_structure logical, intent(in), optional :: decay_rest_frame real(default), intent(in) :: sqrts class(model_data_t), intent(in), target :: model call beam_config%data%init_structure (beam_structure, & sqrts, model, decay_rest_frame) beam_config%lab_is_cm = beam_config%data%lab_is_cm end subroutine process_beam_config_init_beam_structure @ %def process_beam_config_init_beam_structure @ Initialize the beam setup for a scattering process with specified flavor combination, other properties taken from the beam structure object (if any). <>= procedure :: init_scattering => process_beam_config_init_scattering <>= subroutine process_beam_config_init_scattering & (beam_config, flv_in, sqrts, beam_structure) class(process_beam_config_t), intent(out) :: beam_config type(flavor_t), dimension(2), intent(in) :: flv_in real(default), intent(in) :: sqrts type(beam_structure_t), intent(in), optional :: beam_structure if (present (beam_structure)) then if (beam_structure%polarized ()) then call beam_config%data%init_sqrts (sqrts, flv_in, & beam_structure%get_smatrix (), beam_structure%get_pol_f ()) else call beam_config%data%init_sqrts (sqrts, flv_in) end if else call beam_config%data%init_sqrts (sqrts, flv_in) end if end subroutine process_beam_config_init_scattering @ %def process_beam_config_init_scattering @ Initialize the beam setup for a decay process with specified flavor, other properties taken from the beam structure object (if present). For a cascade decay, we set [[rest_frame]] to false, indicating a event-wise varying momentum. The beam data itself are initialized for the particle at rest. <>= procedure :: init_decay => process_beam_config_init_decay <>= subroutine process_beam_config_init_decay & (beam_config, flv_in, rest_frame, beam_structure) class(process_beam_config_t), intent(out) :: beam_config type(flavor_t), dimension(1), intent(in) :: flv_in logical, intent(in), optional :: rest_frame type(beam_structure_t), intent(in), optional :: beam_structure if (present (beam_structure)) then if (beam_structure%polarized ()) then call beam_config%data%init_decay (flv_in, & beam_structure%get_smatrix (), beam_structure%get_pol_f (), & rest_frame = rest_frame) else call beam_config%data%init_decay (flv_in, rest_frame = rest_frame) end if else call beam_config%data%init_decay (flv_in, & rest_frame = rest_frame) end if beam_config%lab_is_cm = beam_config%data%lab_is_cm end subroutine process_beam_config_init_decay @ %def process_beam_config_init_decay @ Print an informative message. <>= procedure :: startup_message => process_beam_config_startup_message <>= subroutine process_beam_config_startup_message & (beam_config, unit, beam_structure) class(process_beam_config_t), intent(in) :: beam_config integer, intent(in), optional :: unit type(beam_structure_t), intent(in), optional :: beam_structure integer :: u u = free_unit () open (u, status="scratch", action="readwrite") if (present (beam_structure)) then call beam_structure%write (u) end if call beam_config%data%write (u) rewind (u) do read (u, "(1x,A)", end=1) msg_buffer call msg_message () end do 1 continue close (u) end subroutine process_beam_config_startup_message @ %def process_beam_config_startup_message @ Allocate the structure-function array. <>= procedure :: init_sf_chain => process_beam_config_init_sf_chain <>= subroutine process_beam_config_init_sf_chain & (beam_config, sf_config, sf_trace_file) class(process_beam_config_t), intent(inout) :: beam_config type(sf_config_t), dimension(:), intent(in) :: sf_config type(string_t), intent(in), optional :: sf_trace_file integer :: i beam_config%n_strfun = size (sf_config) allocate (beam_config%sf (beam_config%n_strfun)) do i = 1, beam_config%n_strfun associate (sf => sf_config(i)) call beam_config%sf(i)%init (sf%i, sf%data) if (.not. sf%data%is_generator ()) then beam_config%n_sfpar = beam_config%n_sfpar + sf%data%get_n_par () end if end associate end do if (present (sf_trace_file)) then beam_config%sf_trace = .true. beam_config%sf_trace_file = sf_trace_file end if end subroutine process_beam_config_init_sf_chain @ %def process_beam_config_init_sf_chain @ Allocate the structure-function mapping channel array, given the requested number of channels. <>= procedure :: allocate_sf_channels => process_beam_config_allocate_sf_channels <>= subroutine process_beam_config_allocate_sf_channels (beam_config, n_channel) class(process_beam_config_t), intent(inout) :: beam_config integer, intent(in) :: n_channel beam_config%n_channel = n_channel call allocate_sf_channels (beam_config%sf_channel, & n_channel = n_channel, & n_strfun = beam_config%n_strfun) end subroutine process_beam_config_allocate_sf_channels @ %def process_beam_config_allocate_sf_channels @ Set a structure-function mapping channel for an array of structure-function entries, for a single channel. (The default is no mapping.) <>= procedure :: set_sf_channel => process_beam_config_set_sf_channel <>= subroutine process_beam_config_set_sf_channel (beam_config, c, sf_channel) class(process_beam_config_t), intent(inout) :: beam_config integer, intent(in) :: c type(sf_channel_t), intent(in) :: sf_channel beam_config%sf_channel(c) = sf_channel end subroutine process_beam_config_set_sf_channel @ %def process_beam_config_set_sf_channel @ Print an informative startup message. <>= procedure :: sf_startup_message => process_beam_config_sf_startup_message <>= subroutine process_beam_config_sf_startup_message & (beam_config, sf_string, unit) class(process_beam_config_t), intent(in) :: beam_config type(string_t), intent(in) :: sf_string integer, intent(in), optional :: unit if (beam_config%n_strfun > 0) then call msg_message ("Beam structure: " // char (sf_string), unit = unit) write (msg_buffer, "(A,3(1x,I0,1x,A))") & "Beam structure:", & beam_config%n_channel, "channels,", & beam_config%n_sfpar, "dimensions" call msg_message (unit = unit) if (beam_config%sf_trace) then call msg_message ("Beam structure: tracing & &values in '" // char (beam_config%sf_trace_file) // "'") end if end if end subroutine process_beam_config_sf_startup_message @ %def process_beam_config_startup_message @ Return the PDF set currently in use, if any. This should be unique, so we scan the structure functions until we get a nonzero number. (This implies that if the PDF set is not unique (e.g., proton and photon structure used together), this does not work correctly.) <>= procedure :: get_pdf_set => process_beam_config_get_pdf_set <>= function process_beam_config_get_pdf_set (beam_config) result (pdf_set) class(process_beam_config_t), intent(in) :: beam_config integer :: pdf_set integer :: i pdf_set = 0 if (allocated (beam_config%sf)) then do i = 1, size (beam_config%sf) pdf_set = beam_config%sf(i)%get_pdf_set () if (pdf_set /= 0) return end do end if end function process_beam_config_get_pdf_set @ %def process_beam_config_get_pdf_set @ Return the beam file. <>= procedure :: get_beam_file => process_beam_config_get_beam_file <>= function process_beam_config_get_beam_file (beam_config) result (file) class(process_beam_config_t), intent(in) :: beam_config type(string_t) :: file integer :: i file = "" if (allocated (beam_config%sf)) then do i = 1, size (beam_config%sf) file = beam_config%sf(i)%get_beam_file () if (file /= "") return end do end if end function process_beam_config_get_beam_file @ %def process_beam_config_get_beam_file @ Compute the MD5 sum for the complete beam setup. We rely on the default output of [[write]] to contain all relevant data. This is done only once, when the MD5 sum is still empty. <>= procedure :: compute_md5sum => process_beam_config_compute_md5sum <>= subroutine process_beam_config_compute_md5sum (beam_config) class(process_beam_config_t), intent(inout) :: beam_config integer :: u if (beam_config%md5sum == "") then u = free_unit () open (u, status = "scratch", action = "readwrite") call beam_config%write (u, verbose=.true.) rewind (u) beam_config%md5sum = md5sum (u) close (u) end if end subroutine process_beam_config_compute_md5sum @ %def process_beam_config_compute_md5sum @ <>= procedure :: get_md5sum => process_beam_config_get_md5sum <>= pure function process_beam_config_get_md5sum (beam_config) result (md5) character(32) :: md5 class(process_beam_config_t), intent(in) :: beam_config md5 = beam_config%md5sum end function process_beam_config_get_md5sum @ %def process_beam_config_get_md5sum @ <>= procedure :: has_structure_function => process_beam_config_has_structure_function <>= pure function process_beam_config_has_structure_function (beam_config) result (has_sf) logical :: has_sf class(process_beam_config_t), intent(in) :: beam_config has_sf = beam_config%n_strfun > 0 end function process_beam_config_has_structure_function @ %def process_beam_config_has_structure_function @ \subsection{Process components} A process component is an individual contribution to a process (scattering or decay) which needs not be physical. The sum over all components should be physical. The [[index]] indentifies this component within its parent process. The actual process component is stored in the [[core]] subobject. We use a polymorphic subobject instead of an extension of [[process_component_t]], because the individual entries in the array of process components can have different types. In short, [[process_component_t]] is a wrapper for the actual process variants. If the [[active]] flag is false, we should skip this component. This happens if the associated process has vanishing matrix element. The index array [[i_term]] points to the individual terms generated by this component. The indices refer to the parent process. The index [[i_mci]] is the index of the MC integrator and parameter set which are associated to this process component. <>= public :: process_component_t <>= type :: process_component_t type(process_component_def_t), pointer :: config => null () integer :: index = 0 logical :: active = .false. integer, dimension(:), allocatable :: i_term integer :: i_mci = 0 class(phs_config_t), allocatable :: phs_config character(32) :: md5sum_phs = "" integer :: component_type = COMP_DEFAULT contains <> end type process_component_t @ %def process_component_t @ Finalizer. The MCI template may (potentially) need a finalizer. The process configuration finalizer may include closing an open scratch file. <>= procedure :: final => process_component_final <>= subroutine process_component_final (object) class(process_component_t), intent(inout) :: object if (allocated (object%phs_config)) then call object%phs_config%final () end if end subroutine process_component_final @ %def process_component_final @ The meaning of [[verbose]] depends on the process variant. <>= procedure :: write => process_component_write <>= subroutine process_component_write (object, unit) class(process_component_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) if (associated (object%config)) then write (u, "(1x,A,I0)") "Component #", object%index call object%config%write (u) if (object%md5sum_phs /= "") then write (u, "(3x,A,A,A)") "MD5 sum (phs) = '", & object%md5sum_phs, "'" end if else write (u, "(1x,A)") "Process component: [not allocated]" end if if (.not. object%active) then write (u, "(1x,A)") "[Inactive]" return end if write (u, "(1x,A)") "Referenced data:" if (allocated (object%i_term)) then write (u, "(3x,A,999(1x,I0))") "Terms =", & object%i_term else write (u, "(3x,A)") "Terms = [undefined]" end if if (object%i_mci /= 0) then write (u, "(3x,A,I0)") "MC dataset = ", object%i_mci else write (u, "(3x,A)") "MC dataset = [undefined]" end if if (allocated (object%phs_config)) then call object%phs_config%write (u) end if end subroutine process_component_write @ %def process_component_write @ Initialize the component. <>= procedure :: init => process_component_init <>= subroutine process_component_init (component, & i_component, env, meta, config, & active, & phs_config_template) class(process_component_t), intent(out) :: component integer, intent(in) :: i_component type(process_environment_t), intent(in) :: env type(process_metadata_t), intent(in) :: meta type(process_config_data_t), intent(in) :: config logical, intent(in) :: active class(phs_config_t), intent(in), allocatable :: phs_config_template type(process_constants_t) :: data component%index = i_component component%config => & config%process_def%get_component_def_ptr (i_component) component%active = active if (component%active) then allocate (component%phs_config, source = phs_config_template) call env%fill_process_constants (meta%id, i_component, data) call component%phs_config%init (data, config%model) end if end subroutine process_component_init @ %def process_component_init @ <>= procedure :: is_active => process_component_is_active <>= elemental function process_component_is_active (component) result (active) logical :: active class(process_component_t), intent(in) :: component active = component%active end function process_component_is_active @ %def process_component_is_active @ Finalize the phase-space configuration. <>= procedure :: configure_phs => process_component_configure_phs <>= subroutine process_component_configure_phs & (component, sqrts, beam_config, rebuild, & ignore_mismatch, subdir) class(process_component_t), intent(inout) :: component real(default), intent(in) :: sqrts type(process_beam_config_t), intent(in) :: beam_config logical, intent(in), optional :: rebuild logical, intent(in), optional :: ignore_mismatch type(string_t), intent(in), optional :: subdir logical :: no_strfun integer :: nlo_type no_strfun = beam_config%n_strfun == 0 nlo_type = component%config%get_nlo_type () call component%phs_config%configure (sqrts, & azimuthal_dependence = beam_config%azimuthal_dependence, & sqrts_fixed = no_strfun, & lab_is_cm = beam_config%lab_is_cm .and. no_strfun, & rebuild = rebuild, ignore_mismatch = ignore_mismatch, & nlo_type = nlo_type, & subdir = subdir) end subroutine process_component_configure_phs @ %def process_component_configure_phs @ The process component possesses two MD5 sums: the checksum of the component definition, which should be available when the component is initialized, and the phase-space MD5 sum, which is available after configuration. <>= procedure :: compute_md5sum => process_component_compute_md5sum <>= subroutine process_component_compute_md5sum (component) class(process_component_t), intent(inout) :: component component%md5sum_phs = component%phs_config%get_md5sum () end subroutine process_component_compute_md5sum @ %def process_component_compute_md5sum @ Match phase-space channels with structure-function channels, where applicable. This calls a method of the [[phs_config]] phase-space implementation. <>= procedure :: collect_channels => process_component_collect_channels <>= subroutine process_component_collect_channels (component, coll) class(process_component_t), intent(inout) :: component type(phs_channel_collection_t), intent(inout) :: coll call component%phs_config%collect_channels (coll) end subroutine process_component_collect_channels @ %def process_component_collect_channels @ <>= procedure :: get_config => process_component_get_config <>= function process_component_get_config (component) & result (config) type(process_component_def_t) :: config class(process_component_t), intent(in) :: component config = component%config end function process_component_get_config @ %def process_component_get_config @ <>= procedure :: get_md5sum => process_component_get_md5sum <>= pure function process_component_get_md5sum (component) result (md5) type(string_t) :: md5 class(process_component_t), intent(in) :: component md5 = component%config%get_md5sum () // component%md5sum_phs end function process_component_get_md5sum @ %def process_component_get_md5sum @ Return the number of phase-space parameters. <>= procedure :: get_n_phs_par => process_component_get_n_phs_par <>= function process_component_get_n_phs_par (component) result (n_par) class(process_component_t), intent(in) :: component integer :: n_par n_par = component%phs_config%get_n_par () end function process_component_get_n_phs_par @ %def process_component_get_n_phs_par @ <>= procedure :: get_phs_config => process_component_get_phs_config <>= subroutine process_component_get_phs_config (component, phs_config) class(process_component_t), intent(in), target :: component class(phs_config_t), intent(out), pointer :: phs_config phs_config => component%phs_config end subroutine process_component_get_phs_config @ %def process_component_get_phs_config @ <>= procedure :: get_nlo_type => process_component_get_nlo_type <>= elemental function process_component_get_nlo_type (component) result (nlo_type) integer :: nlo_type class(process_component_t), intent(in) :: component nlo_type = component%config%get_nlo_type () end function process_component_get_nlo_type @ %def process_component_get_nlo_type @ <>= procedure :: needs_mci_entry => process_component_needs_mci_entry <>= function process_component_needs_mci_entry (component, combined_integration) result (value) logical :: value class(process_component_t), intent(in) :: component logical, intent(in), optional :: combined_integration value = component%active if (present (combined_integration)) then if (combined_integration) & value = value .and. component%component_type <= COMP_MASTER end if end function process_component_needs_mci_entry @ %def process_component_needs_mci_entry @ <>= procedure :: can_be_integrated => process_component_can_be_integrated <>= elemental function process_component_can_be_integrated (component) result (active) logical :: active class(process_component_t), intent(in) :: component active = component%config%can_be_integrated () end function process_component_can_be_integrated @ %def process_component_can_be_integrated @ \subsection{Process terms} For straightforward tree-level calculations, each process component corresponds to a unique elementary interaction. However, in the case of NLO calculations with subtraction terms, a process component may split into several separate contributions to the scattering, which are qualified by interactions with distinct kinematics and particle content. We represent their configuration as [[process_term_t]] objects, the actual instances will be introduced below as [[term_instance_t]]. In any case, the process term contains an elementary interaction with a definite quantum-number and momentum content. The index [[i_term_global]] identifies the term relative to the process. The index [[i_component]] identifies the process component which generates this term, relative to the parent process. The index [[i_term]] identifies the term relative to the process component (not the process). The [[data]] subobject holds all process constants. The number of allowed flavor/helicity/color combinations is stored as [[n_allowed]]. This is the total number of independent entries in the density matrix. For each combination, the index of the flavor, helicity, and color state is stored in the arrays [[flv]], [[hel]], and [[col]], respectively. The flag [[rearrange]] is true if we need to rearrange the particles of the hard interaction, to obtain the effective parton state. The interaction [[int]] holds the quantum state for the (resolved) hard interaction, the parent-child relations of the particles, and their momenta. The momenta are not filled yet; this is postponed to copies of [[int]] which go into the process instances. If recombination is in effect, we should allocate [[int_eff]] to describe the rearranged partonic state. This type is public only for use in a unit test. <>= public :: process_term_t <>= type :: process_term_t integer :: i_term_global = 0 integer :: i_component = 0 integer :: i_term = 0 integer :: i_sub = 0 integer :: i_core = 0 integer :: n_allowed = 0 type(process_constants_t) :: data real(default) :: alpha_s = 0 integer, dimension(:), allocatable :: flv, hel, col integer :: n_sub, n_sub_color, n_sub_spin type(interaction_t) :: int type(interaction_t), pointer :: int_eff => null () contains <> end type process_term_t @ %def process_term_t @ For the output, we skip the process constants and the tables of allowed quantum numbers. Those can also be read off from the interaction object. <>= procedure :: write => process_term_write <>= subroutine process_term_write (term, unit) class(process_term_t), intent(in) :: term integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A,I0)") "Term #", term%i_term_global write (u, "(3x,A,I0)") "Process component index = ", & term%i_component write (u, "(3x,A,I0)") "Term index w.r.t. component = ", & term%i_term call write_separator (u) write (u, "(1x,A)") "Hard interaction:" call write_separator (u) call term%int%basic_write (u) end subroutine process_term_write @ %def process_term_write @ Write an account of all quantum number states and their current status. <>= procedure :: write_state_summary => process_term_write_state_summary <>= subroutine process_term_write_state_summary (term, core, unit) class(process_term_t), intent(in) :: term class(prc_core_t), intent(in) :: core integer, intent(in), optional :: unit integer :: u, i, f, h, c type(state_iterator_t) :: it character :: sgn u = given_output_unit (unit) write (u, "(1x,A,I0)") "Term #", term%i_term_global call it%init (term%int%get_state_matrix_ptr ()) do while (it%is_valid ()) i = it%get_me_index () f = term%flv(i) h = term%hel(i) if (allocated (term%col)) then c = term%col(i) else c = 1 end if if (core%is_allowed (term%i_term, f, h, c)) then sgn = "+" else sgn = " " end if write (u, "(1x,A1,1x,I0,2x)", advance="no") sgn, i call quantum_numbers_write (it%get_quantum_numbers (), u) write (u, *) call it%advance () end do end subroutine process_term_write_state_summary @ %def process_term_write_state_summary @ Finalizer: the [[int]] and potentially [[int_eff]] components have a finalizer that we must call. <>= procedure :: final => process_term_final <>= subroutine process_term_final (term) class(process_term_t), intent(inout) :: term call term%int%final () end subroutine process_term_final @ %def process_term_final @ Initialize the term. We copy the process constants from the [[core]] object and set up the [[int]] hard interaction accordingly. The [[alpha_s]] value is useful for writing external event records. This is the constant value which may be overridden by an event-specific running value. If the model does not contain the strong coupling, the value is zero. The [[rearrange]] part is commented out; this or something equivalent could become relevant for NLO algorithms. <>= procedure :: init => process_term_init <>= subroutine process_term_init & (term, i_term_global, i_component, i_term, core, model, & nlo_type, use_beam_pol, subtraction_method, & has_pdfs, n_emitters) class(process_term_t), intent(inout), target :: term integer, intent(in) :: i_term_global integer, intent(in) :: i_component integer, intent(in) :: i_term class(prc_core_t), intent(inout) :: core class(model_data_t), intent(in), target :: model integer, intent(in), optional :: nlo_type logical, intent(in), optional :: use_beam_pol type(string_t), intent(in), optional :: subtraction_method logical, intent(in), optional :: has_pdfs integer, intent(in), optional :: n_emitters class(modelpar_data_t), pointer :: alpha_s_ptr logical :: use_internal_color term%i_term_global = i_term_global term%i_component = i_component term%i_term = i_term call core%get_constants (term%data, i_term) alpha_s_ptr => model%get_par_data_ptr (var_str ("alphas")) if (associated (alpha_s_ptr)) then term%alpha_s = alpha_s_ptr%get_real () else term%alpha_s = -1 end if use_internal_color = .false. if (present (subtraction_method)) & use_internal_color = (char (subtraction_method) == 'omega') & .or. (char (subtraction_method) == 'threshold') call term%setup_interaction (core, model, nlo_type = nlo_type, & pol_beams = use_beam_pol, use_internal_color = use_internal_color, & has_pdfs = has_pdfs, n_emitters = n_emitters) end subroutine process_term_init @ %def process_term_init @ We fetch the process constants which determine the quantum numbers and use those to create the interaction. The interaction contains incoming and outgoing particles, no virtuals. The incoming particles are parents of the outgoing ones. Keeping previous \whizard\ conventions, we invert the color assignment (but not flavor or helicity) for the incoming particles. When the color-flow square matrix is evaluated, this inversion is done again, so in the color-flow sequence we get the color assignments of the matrix element. \textbf{Why are these four subtraction entries for structure-function aware interactions?} Taking the soft or collinear limit of the real-emission matrix element, the behavior of the parton energy fractions has to be taken into account. In the pure real case, $x_\oplus$ and $x_\ominus$ are given by \begin{equation*} x_\oplus = \frac{\bar{x}_\oplus}{\sqrt{1-\xi}} \sqrt{\frac{2 - \xi(1-y)}{2 - \xi(1+y)}}, \quad x_\ominus = \frac{\bar{x}_\ominus}{\sqrt{1-\xi}} \sqrt{\frac{2 - \xi(1+y)}{2 - \xi(1-y)}}. \end{equation*} In the soft limit, $\xi \to 0$, this yields $x_\oplus = \bar{x}_\oplus$ and $x_\ominus = \bar{x}_\ominus$. In the collinear limit, $y \to 1$, it is $x_\oplus = \bar{x}_\oplus / (1 - \xi)$ and $x_\ominus = \bar{x}_\ominus$. Likewise, in the anti-collinear limit $y \to -1$, the inverse relation holds. We therefore have to distinguish four cases with the PDF assignments $f(x_\oplus) \cdot f(x_\ominus)$, $f(\bar{x}_\oplus) \cdot f(\bar{x}_\ominus)$, $f\left(\bar{x}_\oplus / (1-\xi)\right) \cdot f(\bar{x}_\ominus)$ and $f(\bar{x}_\oplus) \cdot f\left(\bar{x}_\ominus / (1-\xi)\right)$. The [[n_emitters]] optional argument is provided by the caller if this term requires spin-correlated matrix elements, and thus involves additional subtractions. <>= procedure :: setup_interaction => process_term_setup_interaction <>= subroutine process_term_setup_interaction (term, core, model, & nlo_type, pol_beams, has_pdfs, use_internal_color, n_emitters) class(process_term_t), intent(inout) :: term class(prc_core_t), intent(inout) :: core class(model_data_t), intent(in), target :: model logical, intent(in), optional :: pol_beams logical, intent(in), optional :: has_pdfs integer, intent(in), optional :: nlo_type logical, intent(in), optional :: use_internal_color integer, intent(in), optional :: n_emitters integer :: n, n_tot type(flavor_t), dimension(:), allocatable :: flv type(color_t), dimension(:), allocatable :: col type(helicity_t), dimension(:), allocatable :: hel type(quantum_numbers_t), dimension(:), allocatable :: qn logical :: is_pol, use_color integer :: nlo_t, n_sub is_pol = .false.; if (present (pol_beams)) is_pol = pol_beams nlo_t = BORN; if (present (nlo_type)) nlo_t = nlo_type n_tot = term%data%n_in + term%data%n_out call count_number_of_states () term%n_allowed = n call compute_n_sub (n_emitters, has_pdfs) call fill_quantum_numbers () call term%int%basic_init & (term%data%n_in, 0, term%data%n_out, set_relations = .true.) select type (core) class is (prc_blha_t) call setup_states_blha_olp () type is (prc_threshold_t) call setup_states_threshold () class is (prc_external_t) call setup_states_other_prc_external () class default call setup_states_omega () end select call term%int%freeze () contains subroutine count_number_of_states () integer :: f, h, c n = 0 select type (core) class is (prc_external_t) do f = 1, term%data%n_flv do h = 1, term%data%n_hel do c = 1, term%data%n_col n = n + 1 end do end do end do class default !!! Omega and all test cores do f = 1, term%data%n_flv do h = 1, term%data%n_hel do c = 1, term%data%n_col if (core%is_allowed (term%i_term, f, h, c)) n = n + 1 end do end do end do end select end subroutine count_number_of_states subroutine compute_n_sub (n_emitters, has_pdfs) integer, intent(in), optional :: n_emitters logical, intent(in), optional :: has_pdfs logical :: can_have_sub integer :: n_sub_color, n_sub_spin use_color = .false.; if (present (use_internal_color)) & use_color = use_internal_color can_have_sub = nlo_t == NLO_VIRTUAL .or. & (nlo_t == NLO_REAL .and. term%i_term_global == term%i_sub) .or. & nlo_t == NLO_MISMATCH .or. nlo_t == NLO_DGLAP n_sub_color = 0; n_sub_spin = 0 if (can_have_sub) then if (.not. use_color) n_sub_color = n_tot * (n_tot - 1) / 2 if (nlo_t == NLO_REAL) then if (present (n_emitters)) then n_sub_spin = 6 * n_emitters end if end if end if n_sub = n_sub_color + n_sub_spin !!! For the virtual subtraction we also need the finite virtual contribution !!! corresponding to the $\epsilon^0$-pole if (nlo_t == NLO_VIRTUAL) n_sub = n_sub + 1 if (present (has_pdfs)) then if (has_pdfs & .and. ((nlo_t == NLO_REAL .and. can_have_sub) & .or. nlo_t == NLO_DGLAP)) then !!! necessary dummy, needs refactoring, !!! c.f. [[term_instance_evaluate_interaction_userdef_tree]] n_sub = n_sub + n_beams_rescaled end if end if term%n_sub = n_sub term%n_sub_color = n_sub_color term%n_sub_spin = n_sub_spin end subroutine compute_n_sub subroutine fill_quantum_numbers () integer :: nn logical :: can_have_sub select type (core) class is (prc_external_t) can_have_sub = nlo_t == NLO_VIRTUAL .or. & (nlo_t == NLO_REAL .and. term%i_term_global == term%i_sub) .or. & nlo_t == NLO_MISMATCH .or. nlo_t == NLO_DGLAP if (can_have_sub) then nn = (n_sub + 1) * n else nn = n end if class default nn = n end select allocate (term%flv (nn), term%col (nn), term%hel (nn)) allocate (flv (n_tot), col (n_tot), hel (n_tot)) allocate (qn (n_tot)) end subroutine fill_quantum_numbers subroutine setup_states_blha_olp () integer :: s, f, c, h, i i = 0 associate (data => term%data) do s = 0, n_sub do f = 1, data%n_flv do h = 1, data%n_hel do c = 1, data%n_col i = i + 1 term%flv(i) = f term%hel(i) = h !!! Dummy-initialization of color term%col(i) = c call flv%init (data%flv_state (:,f), model) call color_init_from_array (col, & data%col_state(:,:,c), data%ghost_flag(:,c)) call col(1:data%n_in)%invert () if (is_pol) then select type (core) type is (prc_openloops_t) call hel%init (data%hel_state (:,h)) call qn%init (flv, hel, col, s) class default call msg_fatal ("Polarized beams only supported by OpenLoops") end select else call qn%init (flv, col, s) end if call qn%tag_hard_process () call term%int%add_state (qn) end do end do end do end do end associate end subroutine setup_states_blha_olp subroutine setup_states_threshold () integer :: s, f, c, h, i i = 0 n_sub = 0; if (nlo_t == NLO_VIRTUAL) n_sub = 1 associate (data => term%data) do s = 0, n_sub do f = 1, term%data%n_flv do h = 1, data%n_hel do c = 1, data%n_col i = i + 1 term%flv(i) = f term%hel(i) = h !!! Dummy-initialization of color term%col(i) = 1 call flv%init (term%data%flv_state (:,f), model) if (is_pol) then call hel%init (data%hel_state (:,h)) call qn%init (flv, hel, s) else call qn%init (flv, s) end if call qn%tag_hard_process () call term%int%add_state (qn) end do end do end do end do end associate end subroutine setup_states_threshold subroutine setup_states_other_prc_external () integer :: s, f, i, c, h if (is_pol) & call msg_fatal ("Polarized beams only supported by OpenLoops") i = 0 !!! n_sub = 0; if (nlo_t == NLO_VIRTUAL) n_sub = 1 associate (data => term%data) do s = 0, n_sub do f = 1, data%n_flv do h = 1, data%n_hel do c = 1, data%n_col i = i + 1 term%flv(i) = f term%hel(i) = h !!! Dummy-initialization of color term%col(i) = c call flv%init (data%flv_state (:,f), model) call color_init_from_array (col, & data%col_state(:,:,c), data%ghost_flag(:,c)) call col(1:data%n_in)%invert () call qn%init (flv, col, s) call qn%tag_hard_process () call term%int%add_state (qn) end do end do end do end do end associate end subroutine setup_states_other_prc_external subroutine setup_states_omega () integer :: f, h, c, i i = 0 associate (data => term%data) do f = 1, data%n_flv do h = 1, data%n_hel do c = 1, data%n_col if (core%is_allowed (term%i_term, f, h, c)) then i = i + 1 term%flv(i) = f term%hel(i) = h term%col(i) = c call flv%init (data%flv_state(:,f), model) call color_init_from_array (col, & data%col_state(:,:,c), & data%ghost_flag(:,c)) call col(:data%n_in)%invert () call hel%init (data%hel_state(:,h)) call qn%init (flv, col, hel) call qn%tag_hard_process () call term%int%add_state (qn) end if end do end do end do end associate end subroutine setup_states_omega end subroutine process_term_setup_interaction @ %def process_term_setup_interaction @ <>= procedure :: get_process_constants => process_term_get_process_constants <>= subroutine process_term_get_process_constants & (term, prc_constants) class(process_term_t), intent(inout) :: term type(process_constants_t), intent(out) :: prc_constants prc_constants = term%data end subroutine process_term_get_process_constants @ %def process_term_get_process_constants @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Process call statistics} Very simple object for statistics. Could be moved to a more basic chapter. <<[[process_counter.f90]]>>= <> module process_counter use io_units <> <> <> <> contains <> end module process_counter @ %def process_counter @ This object can record process calls, categorized by evaluation status. It is a part of the [[mci_entry]] component below. <>= public :: process_counter_t <>= type :: process_counter_t integer :: total = 0 integer :: failed_kinematics = 0 integer :: failed_cuts = 0 integer :: has_passed = 0 integer :: evaluated = 0 integer :: complete = 0 contains <> end type process_counter_t @ %def process_counter_t @ Here are the corresponding numeric codes: <>= integer, parameter, public :: STAT_UNDEFINED = 0 integer, parameter, public :: STAT_INITIAL = 1 integer, parameter, public :: STAT_ACTIVATED = 2 integer, parameter, public :: STAT_BEAM_MOMENTA = 3 integer, parameter, public :: STAT_FAILED_KINEMATICS = 4 integer, parameter, public :: STAT_SEED_KINEMATICS = 5 integer, parameter, public :: STAT_HARD_KINEMATICS = 6 integer, parameter, public :: STAT_EFF_KINEMATICS = 7 integer, parameter, public :: STAT_FAILED_CUTS = 8 integer, parameter, public :: STAT_PASSED_CUTS = 9 integer, parameter, public :: STAT_EVALUATED_TRACE = 10 integer, parameter, public :: STAT_EVENT_COMPLETE = 11 @ %def STAT_UNDEFINED STAT_INITIAL STAT_ACTIVATED @ %def STAT_BEAM_MOMENTA STAT_FAILED_KINEMATICS @ %def STAT_SEED_KINEMATICS STAT_HARD_KINEMATICS STAT_EFF_KINEMATICS @ %def STAT_EVALUATED_TRACE STAT_EVENT_COMPLETE @ Output. <>= procedure :: write => process_counter_write <>= subroutine process_counter_write (object, unit) class(process_counter_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) if (object%total > 0) then write (u, "(1x,A)") "Call statistics (current run):" write (u, "(3x,A,I0)") "total = ", object%total write (u, "(3x,A,I0)") "failed kin. = ", object%failed_kinematics write (u, "(3x,A,I0)") "failed cuts = ", object%failed_cuts write (u, "(3x,A,I0)") "passed cuts = ", object%has_passed write (u, "(3x,A,I0)") "evaluated = ", object%evaluated else write (u, "(1x,A)") "Call statistics (current run): [no calls]" end if end subroutine process_counter_write @ %def process_counter_write @ Reset. Just enforce default initialization. <>= procedure :: reset => process_counter_reset <>= subroutine process_counter_reset (counter) class(process_counter_t), intent(out) :: counter counter%total = 0 counter%failed_kinematics = 0 counter%failed_cuts = 0 counter%has_passed = 0 counter%evaluated = 0 counter%complete = 0 end subroutine process_counter_reset @ %def process_counter_reset @ We record an event according to the lowest status code greater or equal to the actual status. This is actually done by the process instance; the process object just copies the instance counter. <>= procedure :: record => process_counter_record <>= subroutine process_counter_record (counter, status) class(process_counter_t), intent(inout) :: counter integer, intent(in) :: status if (status <= STAT_FAILED_KINEMATICS) then counter%failed_kinematics = counter%failed_kinematics + 1 else if (status <= STAT_FAILED_CUTS) then counter%failed_cuts = counter%failed_cuts + 1 else if (status <= STAT_PASSED_CUTS) then counter%has_passed = counter%has_passed + 1 else counter%evaluated = counter%evaluated + 1 end if counter%total = counter%total + 1 end subroutine process_counter_record @ %def process_counter_record @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Multi-channel integration} <<[[process_mci.f90]]>>= <> module process_mci <> <> <> use io_units use diagnostics use physics_defs use md5 use cputime use rng_base use mci_base use variables use integration_results use process_libraries use phs_base use process_counter use process_config <> <> <> <> contains <> end module process_mci @ %def process_mci \subsection{Process MCI entry} The [[process_mci_entry_t]] block contains, for each process component that is integrated independently, the configuration data for its MC input parameters. Each input parameter set is handled by a [[mci_t]] integrator. The MC input parameter set is broken down into the parameters required by the structure-function chain and the parameters required by the phase space of the elementary process. The MD5 sum collects all information about the associated processes that may affect the integration. It does not contain the MCI object itself or integration results. MC integration is organized in passes. Each pass may consist of several iterations, and for each iteration there is a number of calls. We store explicitly the values that apply to the current pass. Previous values are archived in the [[results]] object. The [[counter]] receives the counter statistics from the associated process instance, for diagnostics. The [[results]] object records results, broken down in passes and iterations. <>= public :: process_mci_entry_t <>= type :: process_mci_entry_t integer :: i_mci = 0 integer, dimension(:), allocatable :: i_component integer :: process_type = PRC_UNKNOWN integer :: n_par = 0 integer :: n_par_sf = 0 integer :: n_par_phs = 0 character(32) :: md5sum = "" integer :: pass = 0 integer :: n_it = 0 integer :: n_calls = 0 logical :: activate_timer = .false. real(default) :: error_threshold = 0 class(mci_t), allocatable :: mci type(process_counter_t) :: counter type(integration_results_t) :: results logical :: negative_weights = .false. logical :: combined_integration = .false. integer :: real_partition_type = REAL_FULL contains <> end type process_mci_entry_t @ %def process_mci_entry_t @ Finalizer for the [[mci]] component. <>= procedure :: final => process_mci_entry_final <>= subroutine process_mci_entry_final (object) class(process_mci_entry_t), intent(inout) :: object if (allocated (object%mci)) call object%mci%final () end subroutine process_mci_entry_final @ %def process_mci_entry_final @ Output. Write pass/iteration information only if set (the pass index is nonzero). Write the MCI block only if it exists (for some self-tests it does not). Write results only if there are any. <>= procedure :: write => process_mci_entry_write <>= subroutine process_mci_entry_write (object, unit, pacify) class(process_mci_entry_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify integer :: u u = given_output_unit (unit) write (u, "(3x,A,I0)") "Associated components = ", object%i_component write (u, "(3x,A,I0)") "MC input parameters = ", object%n_par write (u, "(3x,A,I0)") "MC parameters (SF) = ", object%n_par_sf write (u, "(3x,A,I0)") "MC parameters (PHS) = ", object%n_par_phs if (object%pass > 0) then write (u, "(3x,A,I0)") "Current pass = ", object%pass write (u, "(3x,A,I0)") "Number of iterations = ", object%n_it write (u, "(3x,A,I0)") "Number of calls = ", object%n_calls end if if (object%md5sum /= "") then write (u, "(3x,A,A,A)") "MD5 sum (components) = '", object%md5sum, "'" end if if (allocated (object%mci)) then call object%mci%write (u) end if call object%counter%write (u) if (object%results%exist ()) then call object%results%write (u, suppress = pacify) call object%results%write_chain_weights (u) end if end subroutine process_mci_entry_write @ %def process_mci_entry_write @ Configure the MCI entry. This is intent(inout) since some specific settings may be done before this. The actual [[mci_t]] object is an instance of the [[mci_template]] argument, which determines the concrete types. In a unit-test context, the [[mci_template]] argument may be unallocated. We obtain the number of channels and the number of parameters, separately for the structure-function chain and for the associated process component. We assume that the phase-space object has already been configured. We assume that there is only one process component directly associated with a MCI entry. <>= procedure :: configure => process_mci_entry_configure <>= subroutine process_mci_entry_configure (mci_entry, mci_template, & process_type, i_mci, i_component, component, & n_sfpar, rng_factory) class(process_mci_entry_t), intent(inout) :: mci_entry class(mci_t), intent(in), allocatable :: mci_template integer, intent(in) :: process_type integer, intent(in) :: i_mci integer, intent(in) :: i_component type(process_component_t), intent(in), target :: component integer, intent(in) :: n_sfpar class(rng_factory_t), intent(inout) :: rng_factory class(rng_t), allocatable :: rng associate (phs_config => component%phs_config) mci_entry%i_mci = i_mci call mci_entry%create_component_list (i_component, component%get_config ()) mci_entry%n_par_sf = n_sfpar mci_entry%n_par_phs = phs_config%get_n_par () mci_entry%n_par = mci_entry%n_par_sf + mci_entry%n_par_phs mci_entry%process_type = process_type if (allocated (mci_template)) then allocate (mci_entry%mci, source = mci_template) call mci_entry%mci%record_index (mci_entry%i_mci) call mci_entry%mci%set_dimensions & (mci_entry%n_par, phs_config%get_n_channel ()) call mci_entry%mci%declare_flat_dimensions & (phs_config%get_flat_dimensions ()) if (phs_config%provides_equivalences) then call mci_entry%mci%declare_equivalences & (phs_config%channel, mci_entry%n_par_sf) end if if (phs_config%provides_chains) then call mci_entry%mci%declare_chains (phs_config%chain) end if call rng_factory%make (rng) call mci_entry%mci%import_rng (rng) end if call mci_entry%results%init (process_type) end associate end subroutine process_mci_entry_configure @ %def process_mci_entry_configure @ <>= integer, parameter, public :: REAL_FULL = 0 integer, parameter, public :: REAL_SINGULAR = 1 integer, parameter, public :: REAL_FINITE = 2 @ <>= procedure :: create_component_list => & process_mci_entry_create_component_list <>= subroutine process_mci_entry_create_component_list (mci_entry, & i_component, component_config) class (process_mci_entry_t), intent(inout) :: mci_entry integer, intent(in) :: i_component type(process_component_def_t), intent(in) :: component_config integer, dimension(:), allocatable :: i_list integer :: n integer, save :: i_rfin_offset = 0 if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "process_mci_entry_create_component_list") if (mci_entry%combined_integration) then if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, & "mci_entry%real_partition_type", mci_entry%real_partition_type) n = get_n_components (mci_entry%real_partition_type) allocate (i_list (n)) select case (mci_entry%real_partition_type) case (REAL_FULL) i_list = component_config%get_association_list () allocate (mci_entry%i_component (size (i_list))) mci_entry%i_component = i_list case (REAL_SINGULAR) i_list = component_config%get_association_list (ASSOCIATED_REAL_FIN) allocate (mci_entry%i_component (size(i_list))) mci_entry%i_component = i_list case (REAL_FINITE) allocate (mci_entry%i_component (1)) mci_entry%i_component(1) = & component_config%get_associated_real_fin () + i_rfin_offset i_rfin_offset = i_rfin_offset + 1 end select else allocate (mci_entry%i_component (1)) mci_entry%i_component(1) = i_component end if contains function get_n_components (real_partition_type) result (n_components) integer :: n_components integer, intent(in) :: real_partition_type select case (real_partition_type) case (REAL_FULL) n_components = size (component_config%get_association_list ()) case (REAL_SINGULAR) n_components = size (component_config%get_association_list & (ASSOCIATED_REAL_FIN)) end select if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "n_components", n_components) end function get_n_components end subroutine process_mci_entry_create_component_list @ %def process_mci_entry_create_component_list @ Set some additional parameters. <>= procedure :: set_parameters => process_mci_entry_set_parameters <>= subroutine process_mci_entry_set_parameters (mci_entry, var_list) class(process_mci_entry_t), intent(inout) :: mci_entry type(var_list_t), intent(in) :: var_list integer :: integration_results_verbosity real(default) :: error_threshold integration_results_verbosity = & var_list%get_ival (var_str ("integration_results_verbosity")) error_threshold = & var_list%get_rval (var_str ("error_threshold")) mci_entry%activate_timer = & var_list%get_lval (var_str ("?integration_timer")) call mci_entry%results%set_verbosity (integration_results_verbosity) call mci_entry%results%set_error_threshold (error_threshold) end subroutine process_mci_entry_set_parameters @ %def process_mci_entry_set_parameters @ Compute an MD5 sum that summarizes all information that could influence integration results, for the associated process components. We take the process-configuration MD5 sum which represents parameters, cuts, etc., the MD5 sums for the process component definitions and their phase space objects (which should be configured), and the beam configuration MD5 sum. (The QCD setup is included in the process configuration data MD5 sum.) Done only once, when the MD5 sum is still empty. <>= procedure :: compute_md5sum => process_mci_entry_compute_md5sum <>= subroutine process_mci_entry_compute_md5sum (mci_entry, & config, component, beam_config) class(process_mci_entry_t), intent(inout) :: mci_entry type(process_config_data_t), intent(in) :: config type(process_component_t), dimension(:), intent(in) :: component type(process_beam_config_t), intent(in) :: beam_config type(string_t) :: buffer integer :: i if (mci_entry%md5sum == "") then buffer = config%get_md5sum () // beam_config%get_md5sum () do i = 1, size (component) if (component(i)%is_active ()) then buffer = buffer // component(i)%get_md5sum () end if end do mci_entry%md5sum = md5sum (char (buffer)) end if if (allocated (mci_entry%mci)) then call mci_entry%mci%set_md5sum (mci_entry%md5sum) end if end subroutine process_mci_entry_compute_md5sum @ %def process_mci_entry_compute_md5sum @ Test the MCI sampler by calling it a given number of time, discarding the results. The instance should be initialized. The [[mci_entry]] is [[intent(inout)]] because the integrator contains the random-number state. <>= procedure :: sampler_test => process_mci_entry_sampler_test <>= subroutine process_mci_entry_sampler_test (mci_entry, mci_sampler, n_calls) class(process_mci_entry_t), intent(inout) :: mci_entry class(mci_sampler_t), intent(inout), target :: mci_sampler integer, intent(in) :: n_calls call mci_entry%mci%sampler_test (mci_sampler, n_calls) end subroutine process_mci_entry_sampler_test @ %def process_mci_entry_sampler_test @ Integrate. The [[integrate]] method counts as an integration pass; the pass count is increased by one. We transfer the pass parameters (number of iterations and number of calls) to the actual integration routine. The [[mci_entry]] is [[intent(inout)]] because the integrator contains the random-number state. Note: The results are written to screen and to logfile. This behavior is hardcoded. <>= procedure :: integrate => process_mci_entry_integrate procedure :: final_integration => process_mci_entry_final_integration <>= subroutine process_mci_entry_integrate (mci_entry, mci_instance, & mci_sampler, n_it, n_calls, & adapt_grids, adapt_weights, final, pacify, & nlo_type) class(process_mci_entry_t), intent(inout) :: mci_entry class(mci_instance_t), intent(inout) :: mci_instance class(mci_sampler_t), intent(inout) :: mci_sampler integer, intent(in) :: n_it integer, intent(in) :: n_calls logical, intent(in), optional :: adapt_grids logical, intent(in), optional :: adapt_weights logical, intent(in), optional :: final, pacify integer, intent(in), optional :: nlo_type integer :: u_log u_log = logfile_unit () mci_entry%pass = mci_entry%pass + 1 mci_entry%n_it = n_it mci_entry%n_calls = n_calls if (mci_entry%pass == 1) & call mci_entry%mci%startup_message (n_calls = n_calls) call mci_entry%mci%set_timer (active = mci_entry%activate_timer) call mci_entry%results%display_init (screen = .true., unit = u_log) call mci_entry%results%new_pass () if (present (nlo_type)) then select case (nlo_type) case (NLO_VIRTUAL, NLO_REAL, NLO_MISMATCH, NLO_DGLAP) mci_instance%negative_weights = .true. end select end if call mci_entry%mci%add_pass (adapt_grids, adapt_weights, final) call mci_entry%mci%start_timer () call mci_entry%mci%integrate (mci_instance, mci_sampler, n_it, & n_calls, mci_entry%results, pacify = pacify) call mci_entry%mci%stop_timer () if (signal_is_pending ()) return end subroutine process_mci_entry_integrate subroutine process_mci_entry_final_integration (mci_entry) class(process_mci_entry_t), intent(inout) :: mci_entry call mci_entry%results%display_final () call mci_entry%time_message () end subroutine process_mci_entry_final_integration @ %def process_mci_entry_integrate @ %def process_mci_entry_final_integration @ If appropriate, issue an informative message about the expected time for an event sample. <>= procedure :: get_time => process_mci_entry_get_time procedure :: time_message => process_mci_entry_time_message <>= subroutine process_mci_entry_get_time (mci_entry, time, sample) class(process_mci_entry_t), intent(in) :: mci_entry type(time_t), intent(out) :: time integer, intent(in) :: sample real(default) :: time_last_pass, efficiency, calls time_last_pass = mci_entry%mci%get_time () calls = mci_entry%results%get_n_calls () efficiency = mci_entry%mci%get_efficiency () if (time_last_pass > 0 .and. calls > 0 .and. efficiency > 0) then time = nint (time_last_pass / calls / efficiency * sample) end if end subroutine process_mci_entry_get_time subroutine process_mci_entry_time_message (mci_entry) class(process_mci_entry_t), intent(in) :: mci_entry type(time_t) :: time integer :: sample sample = 10000 call mci_entry%get_time (time, sample) if (time%is_known ()) then call msg_message ("Time estimate for generating 10000 events: " & // char (time%to_string_dhms ())) end if end subroutine process_mci_entry_time_message @ %def process_mci_entry_time_message @ Prepare event generation. (For the test integrator, this does nothing. It is relevant for the VAMP integrator.) <>= procedure :: prepare_simulation => process_mci_entry_prepare_simulation <>= subroutine process_mci_entry_prepare_simulation (mci_entry) class(process_mci_entry_t), intent(inout) :: mci_entry call mci_entry%mci%prepare_simulation () end subroutine process_mci_entry_prepare_simulation @ %def process_mci_entry_prepare_simulation @ Generate an event. The instance should be initialized, otherwise event generation is directed by the [[mci]] integrator subobject. The integrator instance is contained in a [[mci_work]] subobject of the process instance, which simultaneously serves as the sampler object. (We avoid the anti-aliasing rules if we assume that the sampling itself does not involve the integrator instance contained in the process instance.) Regarding weighted events, we only take events which are valid, which means that they have valid kinematics and have passed cuts. Therefore, we have a rejection loop. For unweighted events, the unweighting routine should already take care of this. The [[keep_failed]] flag determines whether events which failed cuts are nevertheless produced, to be recorded with zero weight. Alternatively, failed events are dropped, and this fact is recorded by the counter [[n_dropped]]. <>= procedure :: generate_weighted_event => & process_mci_entry_generate_weighted_event procedure :: generate_unweighted_event => & process_mci_entry_generate_unweighted_event <>= subroutine process_mci_entry_generate_weighted_event (mci_entry, & mci_instance, mci_sampler, keep_failed) class(process_mci_entry_t), intent(inout) :: mci_entry class(mci_instance_t), intent(inout) :: mci_instance class(mci_sampler_t), intent(inout) :: mci_sampler logical, intent(in) :: keep_failed logical :: generate_new generate_new = .true. call mci_instance%reset_n_event_dropped () REJECTION: do while (generate_new) call mci_entry%mci%generate_weighted_event (mci_instance, mci_sampler) if (signal_is_pending ()) return if (.not. mci_sampler%is_valid()) then if (keep_failed) then generate_new = .false. else call mci_instance%record_event_dropped () generate_new = .true. end if else generate_new = .false. end if end do REJECTION end subroutine process_mci_entry_generate_weighted_event subroutine process_mci_entry_generate_unweighted_event (mci_entry, mci_instance, mci_sampler) class(process_mci_entry_t), intent(inout) :: mci_entry class(mci_instance_t), intent(inout) :: mci_instance class(mci_sampler_t), intent(inout) :: mci_sampler call mci_entry%mci%generate_unweighted_event (mci_instance, mci_sampler) end subroutine process_mci_entry_generate_unweighted_event @ %def process_mci_entry_generate_weighted_event @ %def process_mci_entry_generate_unweighted_event @ Extract results. <>= procedure :: has_integral => process_mci_entry_has_integral procedure :: get_integral => process_mci_entry_get_integral procedure :: get_error => process_mci_entry_get_error procedure :: get_accuracy => process_mci_entry_get_accuracy procedure :: get_chi2 => process_mci_entry_get_chi2 procedure :: get_efficiency => process_mci_entry_get_efficiency <>= function process_mci_entry_has_integral (mci_entry) result (flag) class(process_mci_entry_t), intent(in) :: mci_entry logical :: flag flag = mci_entry%results%exist () end function process_mci_entry_has_integral function process_mci_entry_get_integral (mci_entry) result (integral) class(process_mci_entry_t), intent(in) :: mci_entry real(default) :: integral integral = mci_entry%results%get_integral () end function process_mci_entry_get_integral function process_mci_entry_get_error (mci_entry) result (error) class(process_mci_entry_t), intent(in) :: mci_entry real(default) :: error error = mci_entry%results%get_error () end function process_mci_entry_get_error function process_mci_entry_get_accuracy (mci_entry) result (accuracy) class(process_mci_entry_t), intent(in) :: mci_entry real(default) :: accuracy accuracy = mci_entry%results%get_accuracy () end function process_mci_entry_get_accuracy function process_mci_entry_get_chi2 (mci_entry) result (chi2) class(process_mci_entry_t), intent(in) :: mci_entry real(default) :: chi2 chi2 = mci_entry%results%get_chi2 () end function process_mci_entry_get_chi2 function process_mci_entry_get_efficiency (mci_entry) result (efficiency) class(process_mci_entry_t), intent(in) :: mci_entry real(default) :: efficiency efficiency = mci_entry%results%get_efficiency () end function process_mci_entry_get_efficiency @ %def process_mci_entry_get_integral process_mci_entry_get_error @ %def process_mci_entry_get_accuracy process_mci_entry_get_chi2 @ %def process_mci_entry_get_efficiency @ Return the MCI checksum. This may be the one used for configuration, but may also incorporate results, if they change the state of the integrator (adaptation). <>= procedure :: get_md5sum => process_mci_entry_get_md5sum <>= pure function process_mci_entry_get_md5sum (entry) result (md5sum) class(process_mci_entry_t), intent(in) :: entry character(32) :: md5sum md5sum = entry%mci%get_md5sum () end function process_mci_entry_get_md5sum @ %def process_mci_entry_get_md5sum @ \subsection{MC parameter set and MCI instance} For each process component that is associated with a multi-channel integration (MCI) object, the [[mci_work_t]] object contains the currently active parameter set. It also holds the implementation of the [[mci_instance_t]] that the integrator needs for doing its work. <>= public :: mci_work_t <>= type :: mci_work_t type(process_mci_entry_t), pointer :: config => null () real(default), dimension(:), allocatable :: x class(mci_instance_t), pointer :: mci => null () type(process_counter_t) :: counter logical :: keep_failed_events = .false. integer :: n_event_dropped = 0 contains <> end type mci_work_t @ %def mci_work_t @ First write configuration data, then the current values. <>= procedure :: write => mci_work_write <>= subroutine mci_work_write (mci_work, unit, testflag) class(mci_work_t), intent(in) :: mci_work integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u, i u = given_output_unit (unit) write (u, "(1x,A,I0,A)") "Active MCI instance #", & mci_work%config%i_mci, " =" write (u, "(2x)", advance="no") do i = 1, mci_work%config%n_par write (u, "(1x,F7.5)", advance="no") mci_work%x(i) if (i == mci_work%config%n_par_sf) & write (u, "(1x,'|')", advance="no") end do write (u, *) if (associated (mci_work%mci)) then call mci_work%mci%write (u, pacify = testflag) call mci_work%counter%write (u) end if end subroutine mci_work_write @ %def mci_work_write @ The [[mci]] component may require finalization. <>= procedure :: final => mci_work_final <>= subroutine mci_work_final (mci_work) class(mci_work_t), intent(inout) :: mci_work if (associated (mci_work%mci)) then call mci_work%mci%final () deallocate (mci_work%mci) end if end subroutine mci_work_final @ %def mci_work_final @ Initialize with the maximum length that we will need. Contents are not initialized. The integrator inside the [[mci_entry]] object is responsible for allocating and initializing its own instance, which is referred to by a pointer in the [[mci_work]] object. <>= procedure :: init => mci_work_init <>= subroutine mci_work_init (mci_work, mci_entry) class(mci_work_t), intent(out) :: mci_work type(process_mci_entry_t), intent(in), target :: mci_entry mci_work%config => mci_entry allocate (mci_work%x (mci_entry%n_par)) if (allocated (mci_entry%mci)) then call mci_entry%mci%allocate_instance (mci_work%mci) call mci_work%mci%init (mci_entry%mci) end if end subroutine mci_work_init @ %def mci_work_init @ Set parameters explicitly, either all at once, or separately for the structure-function and process parts. <>= procedure :: set => mci_work_set procedure :: set_x_strfun => mci_work_set_x_strfun procedure :: set_x_process => mci_work_set_x_process <>= subroutine mci_work_set (mci_work, x) class(mci_work_t), intent(inout) :: mci_work real(default), dimension(:), intent(in) :: x mci_work%x = x end subroutine mci_work_set subroutine mci_work_set_x_strfun (mci_work, x) class(mci_work_t), intent(inout) :: mci_work real(default), dimension(:), intent(in) :: x mci_work%x(1 : mci_work%config%n_par_sf) = x end subroutine mci_work_set_x_strfun subroutine mci_work_set_x_process (mci_work, x) class(mci_work_t), intent(inout) :: mci_work real(default), dimension(:), intent(in) :: x mci_work%x(mci_work%config%n_par_sf + 1 : mci_work%config%n_par) = x end subroutine mci_work_set_x_process @ %def mci_work_set @ %def mci_work_set_x_strfun @ %def mci_work_set_x_process @ Return the array of active components, i.e., those that correspond to the currently selected MC parameter set. <>= procedure :: get_active_components => mci_work_get_active_components <>= function mci_work_get_active_components (mci_work) result (i_component) class(mci_work_t), intent(in) :: mci_work integer, dimension(:), allocatable :: i_component allocate (i_component (size (mci_work%config%i_component))) i_component = mci_work%config%i_component end function mci_work_get_active_components @ %def mci_work_get_active_components @ Return the active parameters as a simple array with correct length. Do this separately for the structure-function parameters and the process parameters. <>= procedure :: get_x_strfun => mci_work_get_x_strfun procedure :: get_x_process => mci_work_get_x_process <>= pure function mci_work_get_x_strfun (mci_work) result (x) class(mci_work_t), intent(in) :: mci_work real(default), dimension(mci_work%config%n_par_sf) :: x x = mci_work%x(1 : mci_work%config%n_par_sf) end function mci_work_get_x_strfun pure function mci_work_get_x_process (mci_work) result (x) class(mci_work_t), intent(in) :: mci_work real(default), dimension(mci_work%config%n_par_phs) :: x x = mci_work%x(mci_work%config%n_par_sf + 1 : mci_work%config%n_par) end function mci_work_get_x_process @ %def mci_work_get_x_strfun @ %def mci_work_get_x_process @ Initialize and finalize event generation for the specified MCI entry. This also resets the counter. <>= procedure :: init_simulation => mci_work_init_simulation procedure :: final_simulation => mci_work_final_simulation <>= subroutine mci_work_init_simulation (mci_work, safety_factor, keep_failed_events) class(mci_work_t), intent(inout) :: mci_work real(default), intent(in), optional :: safety_factor logical, intent(in), optional :: keep_failed_events call mci_work%mci%init_simulation (safety_factor) call mci_work%counter%reset () if (present (keep_failed_events)) & mci_work%keep_failed_events = keep_failed_events end subroutine mci_work_init_simulation subroutine mci_work_final_simulation (mci_work) class(mci_work_t), intent(inout) :: mci_work call mci_work%mci%final_simulation () end subroutine mci_work_final_simulation @ %def mci_work_init_simulation @ %def mci_work_final_simulation @ Counter. <>= procedure :: reset_counter => mci_work_reset_counter procedure :: record_call => mci_work_record_call procedure :: get_counter => mci_work_get_counter <>= subroutine mci_work_reset_counter (mci_work) class(mci_work_t), intent(inout) :: mci_work call mci_work%counter%reset () end subroutine mci_work_reset_counter subroutine mci_work_record_call (mci_work, status) class(mci_work_t), intent(inout) :: mci_work integer, intent(in) :: status call mci_work%counter%record (status) end subroutine mci_work_record_call pure function mci_work_get_counter (mci_work) result (counter) class(mci_work_t), intent(in) :: mci_work type(process_counter_t) :: counter counter = mci_work%counter end function mci_work_get_counter @ %def mci_work_reset_counter @ %def mci_work_record_call @ %def mci_work_get_counter @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Process component manager} <<[[pcm.f90]]>>= <> module pcm <> <> <> use constants, only: zero, two use diagnostics use lorentz use phs_points, only: assignment(=) use io_units, only: free_unit use os_interface use process_constants, only: process_constants_t use physics_defs use model_data, only: model_data_t use models, only: model_t use interactions, only: interaction_t use quantum_numbers, only: quantum_numbers_t, quantum_numbers_mask_t use flavors, only: flavor_t use variables, only: var_list_t use nlo_data, only: nlo_settings_t use mci_base, only: mci_t use phs_base, only: phs_config_t use mappings, only: mapping_defaults_t use phs_forests, only: phs_parameters_t use phs_fks, only: isr_kinematics_t, real_kinematics_t use phs_fks, only: phs_identifier_t use dispatch_fks, only: dispatch_fks_s use fks_regions, only: region_data_t use nlo_data, only: fks_template_t use phs_fks, only: phs_fks_generator_t use phs_fks, only: dalitz_plot_t use phs_fks, only: phs_fks_config_t, get_filtered_resonance_histories use dispatch_phase_space, only: dispatch_phs use process_libraries, only: process_component_def_t use real_subtraction, only: real_subtraction_t, soft_mismatch_t use real_subtraction, only: FIXED_ORDER_EVENTS, POWHEG use real_subtraction, only: real_partition_t, powheg_damping_simple_t use real_subtraction, only: real_partition_fixed_order_t use virtual, only: virtual_t use dglap_remnant, only: dglap_remnant_t use prc_threshold, only: threshold_def_t use resonances, only: resonance_history_t, resonance_history_set_t use nlo_data, only: FKS_DEFAULT, FKS_RESONANCES use blha_config, only: blha_master_t use blha_olp_interfaces, only: prc_blha_t use pcm_base use process_config use process_mci, only: process_mci_entry_t use process_mci, only: REAL_SINGULAR, REAL_FINITE <> <> <> contains <> end module pcm @ %def pcm @ \subsection{Default process component manager} This is the configuration object which has the duty of allocating the corresponding instance. The default version is trivial. <>= public :: pcm_default_t <>= type, extends (pcm_t) :: pcm_default_t contains <> end type pcm_default_t @ %def pcm_default_t <>= procedure :: allocate_workspace => pcm_default_allocate_workspace <>= subroutine pcm_default_allocate_workspace (pcm, work) class(pcm_default_t), intent(in) :: pcm class(pcm_workspace_t), intent(inout), allocatable :: work allocate (pcm_default_workspace_t :: work) end subroutine pcm_default_allocate_workspace @ %def pcm_default_allocate_workspace @ Finalizer: apply to core manager. <>= procedure :: final => pcm_default_final <>= subroutine pcm_default_final (pcm) class(pcm_default_t), intent(inout) :: pcm end subroutine pcm_default_final @ %def pcm_default_final @ <>= procedure :: is_nlo => pcm_default_is_nlo <>= function pcm_default_is_nlo (pcm) result (is_nlo) logical :: is_nlo class(pcm_default_t), intent(in) :: pcm is_nlo = .false. end function pcm_default_is_nlo @ %def pcm_default_is_nlo @ Initialize configuration data, using environment variables. <>= procedure :: init => pcm_default_init <>= subroutine pcm_default_init (pcm, env, meta) class(pcm_default_t), intent(out) :: pcm type(process_environment_t), intent(in) :: env type(process_metadata_t), intent(in) :: meta pcm%has_pdfs = env%has_pdfs () call pcm%set_blha_defaults & (env%has_polarized_beams (), env%get_var_list_ptr ()) pcm%os_data = env%get_os_data () end subroutine pcm_default_init @ %def pcm_default_init @ <>= type, extends (pcm_workspace_t) :: pcm_default_workspace_t contains <> end type pcm_default_workspace_t @ %def pcm_default_workspace_t @ <>= procedure :: final => pcm_default_workspace_final <>= subroutine pcm_default_workspace_final (pcm_work) class(pcm_default_workspace_t), intent(inout) :: pcm_work end subroutine pcm_default_workspace_final @ %def pcm_default_workspace_final @ <>= procedure :: is_nlo => pcm_default_workspace_is_nlo <>= function pcm_default_workspace_is_nlo (pcm_work) result (is_nlo) logical :: is_nlo class(pcm_default_workspace_t), intent(inout) :: pcm_work is_nlo = .false. end function pcm_default_workspace_is_nlo @ %def pcm_default_workspace_is_nlo @ \subsection{Implementations for the default manager} Categorize components. Nothing to do here, all components are of Born type. <>= procedure :: categorize_components => pcm_default_categorize_components <>= subroutine pcm_default_categorize_components (pcm, config) class(pcm_default_t), intent(inout) :: pcm type(process_config_data_t), intent(in) :: config end subroutine pcm_default_categorize_components @ %def pcm_default_categorize_components @ \subsubsection{Phase-space configuration} Default setup for tree processes: a single phase-space configuration that is valid for all components. <>= procedure :: init_phs_config => pcm_default_init_phs_config <>= subroutine pcm_default_init_phs_config & (pcm, phs_entry, meta, env, phs_par, mapping_defs) class(pcm_default_t), intent(inout) :: pcm type(process_phs_config_t), & dimension(:), allocatable, intent(out) :: phs_entry type(process_metadata_t), intent(in) :: meta type(process_environment_t), intent(in) :: env type(mapping_defaults_t), intent(in) :: mapping_defs type(phs_parameters_t), intent(in) :: phs_par allocate (phs_entry (1)) allocate (pcm%i_phs_config (pcm%n_components), source=1) call dispatch_phs (phs_entry(1)%phs_config, & env%get_var_list_ptr (), & env%get_os_data (), & meta%id, & mapping_defs, phs_par) end subroutine pcm_default_init_phs_config @ %def pcm_default_init_phs_config @ \subsubsection{Core management} The default component manager assigns one core per component. We allocate and configure the core objects, using the process-component configuration data. <>= procedure :: allocate_cores => pcm_default_allocate_cores <>= subroutine pcm_default_allocate_cores (pcm, config, core_entry) class(pcm_default_t), intent(inout) :: pcm type(process_config_data_t), intent(in) :: config type(core_entry_t), dimension(:), allocatable, intent(out) :: core_entry type(process_component_def_t), pointer :: component_def integer :: i allocate (pcm%i_core (pcm%n_components), source = 0) pcm%n_cores = pcm%n_components allocate (core_entry (pcm%n_cores)) do i = 1, pcm%n_cores pcm%i_core(i) = i core_entry(i)%i_component = i component_def => config%process_def%get_component_def_ptr (i) core_entry(i)%core_def => component_def%get_core_def_ptr () core_entry(i)%active = component_def%can_be_integrated () end do end subroutine pcm_default_allocate_cores @ %def pcm_default_allocate_cores @ Extra code is required for certain core types (threshold) or if BLHA uses an external OLP (Born only, this case) for getting its matrix elements. <>= procedure :: prepare_any_external_code => & pcm_default_prepare_any_external_code <>= subroutine pcm_default_prepare_any_external_code & (pcm, core_entry, i_core, libname, model, var_list) class(pcm_default_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry integer, intent(in) :: i_core type(string_t), intent(in) :: libname type(model_data_t), intent(in), target :: model type(var_list_t), intent(in) :: var_list if (core_entry%active) then associate (core => core_entry%core) if (core%needs_external_code ()) then call core%prepare_external_code & (core%data%flv_state, & var_list, pcm%os_data, libname, model, i_core, .false.) end if call core%set_equivalent_flv_hel_indices () end associate end if end subroutine pcm_default_prepare_any_external_code @ %def pcm_default_prepare_any_external_code @ Allocate and configure the BLHA record for a specific core, assuming that the core type requires it. In the default case, this is a Born configuration. <>= procedure :: setup_blha => pcm_default_setup_blha <>= subroutine pcm_default_setup_blha (pcm, core_entry) class(pcm_default_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry allocate (core_entry%blha_config, source = pcm%blha_defaults) call core_entry%blha_config%set_born () end subroutine pcm_default_setup_blha @ %def pcm_default_setup_blha @ Apply the configuration, using [[pcm]] data. <>= procedure :: prepare_blha_core => pcm_default_prepare_blha_core <>= subroutine pcm_default_prepare_blha_core (pcm, core_entry, model) class(pcm_default_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry class(model_data_t), intent(in), target :: model integer :: n_in integer :: n_legs integer :: n_flv integer :: n_hel select type (core => core_entry%core) class is (prc_blha_t) associate (blha_config => core_entry%blha_config) n_in = core%data%n_in n_legs = core%data%get_n_tot () n_flv = core%data%n_flv n_hel = blha_config%get_n_hel (core%data%flv_state (1:n_in,1), model) call core%init_blha (blha_config, n_in, n_legs, n_flv, n_hel) call core%init_driver (pcm%os_data) end associate end select end subroutine pcm_default_prepare_blha_core @ %def pcm_default_prepare_blha_core @ Read the method settings from the variable list and store them in the BLHA master. This version: no NLO flag. <>= procedure :: set_blha_methods => pcm_default_set_blha_methods <>= subroutine pcm_default_set_blha_methods (pcm, blha_master, var_list) class(pcm_default_t), intent(inout) :: pcm type(blha_master_t), intent(inout) :: blha_master type(var_list_t), intent(in) :: var_list call blha_master%set_methods (.false., var_list) end subroutine pcm_default_set_blha_methods @ %def pcm_default_set_blha_methods @ Produce the LO and NLO flavor-state tables (as far as available), as appropriate for BLHA configuration. The default version looks at the first process core only, to get the Born data. (Multiple cores are thus unsupported.) The NLO flavor table is left unallocated. <>= procedure :: get_blha_flv_states => pcm_default_get_blha_flv_states <>= subroutine pcm_default_get_blha_flv_states & (pcm, core_entry, flv_born, flv_real) class(pcm_default_t), intent(in) :: pcm type(core_entry_t), dimension(:), intent(in) :: core_entry integer, dimension(:,:), allocatable, intent(out) :: flv_born integer, dimension(:,:), allocatable, intent(out) :: flv_real flv_born = core_entry(1)%core%data%flv_state end subroutine pcm_default_get_blha_flv_states @ %def pcm_default_get_blha_flv_states @ Allocate and configure the MCI (multi-channel integrator) records. There is one record per active process component. Second procedure: call the MCI dispatcher with default-setup arguments. <>= procedure :: setup_mci => pcm_default_setup_mci procedure :: call_dispatch_mci => pcm_default_call_dispatch_mci <>= subroutine pcm_default_setup_mci (pcm, mci_entry) class(pcm_default_t), intent(inout) :: pcm type(process_mci_entry_t), & dimension(:), allocatable, intent(out) :: mci_entry class(mci_t), allocatable :: mci_template integer :: i, i_mci pcm%n_mci = count (pcm%component_active) allocate (pcm%i_mci (pcm%n_components), source = 0) i_mci = 0 do i = 1, pcm%n_components if (pcm%component_active(i)) then i_mci = i_mci + 1 pcm%i_mci(i) = i_mci end if end do allocate (mci_entry (pcm%n_mci)) end subroutine pcm_default_setup_mci subroutine pcm_default_call_dispatch_mci (pcm, & dispatch_mci, var_list, process_id, mci_template) class(pcm_default_t), intent(inout) :: pcm procedure(dispatch_mci_proc) :: dispatch_mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id class(mci_t), allocatable, intent(out) :: mci_template call dispatch_mci (mci_template, var_list, process_id) end subroutine pcm_default_call_dispatch_mci @ %def pcm_default_setup_mci @ %def pcm_default_call_dispatch_mci @ Nothing left to do for the default algorithm. <>= procedure :: complete_setup => pcm_default_complete_setup <>= subroutine pcm_default_complete_setup (pcm, core_entry, component, model) class(pcm_default_t), intent(inout) :: pcm type(core_entry_t), dimension(:), intent(in) :: core_entry type(process_component_t), dimension(:), intent(inout) :: component type(model_t), intent(in), target :: model end subroutine pcm_default_complete_setup @ %def pcm_default_complete_setup @ \subsubsection{Component management} Initialize a single component. We require all process-configuration blocks, and specific templates for the phase-space and integrator configuration. We also provide the current component index [[i]] and the [[active]] flag. In the default mode, all components are marked as master components. <>= procedure :: init_component => pcm_default_init_component <>= subroutine pcm_default_init_component & (pcm, component, i, active, & phs_config, env, meta, config) class(pcm_default_t), intent(in) :: pcm type(process_component_t), intent(out) :: component integer, intent(in) :: i logical, intent(in) :: active class(phs_config_t), allocatable, intent(in) :: phs_config type(process_environment_t), intent(in) :: env type(process_metadata_t), intent(in) :: meta type(process_config_data_t), intent(in) :: config call component%init (i, & env, meta, config, & active, & phs_config) component%component_type = COMP_MASTER end subroutine pcm_default_init_component @ %def pcm_default_init_component @ \subsection{NLO process component manager} The NLO-aware version of the process-component manager. This is the configuration object, which has the duty of allocating the corresponding instance. This is the nontrivial NLO version. <>= public :: pcm_nlo_t <>= type, extends (pcm_t) :: pcm_nlo_t type(string_t) :: id logical :: combined_integration = .false. logical :: vis_fks_regions = .false. integer, dimension(:), allocatable :: nlo_type integer, dimension(:), allocatable :: nlo_type_core integer, dimension(:), allocatable :: component_type integer :: i_born = 0 integer :: i_real = 0 integer :: i_sub = 0 type(nlo_settings_t) :: settings type(region_data_t) :: region_data logical :: use_real_partition = .false. logical :: use_real_singular = .false. real(default) :: real_partition_scale = 0 class(real_partition_t), allocatable :: real_partition type(dalitz_plot_t) :: dalitz_plot type(quantum_numbers_t), dimension(:,:), allocatable :: qn_real, qn_born contains <> end type pcm_nlo_t @ %def pcm_nlo_t @ Initialize configuration data, using environment variables. <>= procedure :: init => pcm_nlo_init <>= subroutine pcm_nlo_init (pcm, env, meta) class(pcm_nlo_t), intent(out) :: pcm type(process_metadata_t), intent(in) :: meta type(process_environment_t), intent(in) :: env type(var_list_t), pointer :: var_list type(fks_template_t) :: fks_template pcm%id = meta%id pcm%has_pdfs = env%has_pdfs () var_list => env%get_var_list_ptr () call dispatch_fks_s (fks_template, var_list) call pcm%settings%init (var_list, fks_template) pcm%combined_integration = & var_list%get_lval (var_str ('?combined_nlo_integration')) select case (char (var_list%get_sval (var_str ("$real_partition_mode")))) case ("default", "off") pcm%use_real_partition = .false. pcm%use_real_singular = .false. case ("all", "on", "singular") pcm%use_real_partition = .true. pcm%use_real_singular = .true. case ("finite") pcm%use_real_partition = .true. pcm%use_real_singular = .false. case default call msg_fatal ("The real partition mode can only be " // & "default, off, all, on, singular or finite.") end select pcm%real_partition_scale = & var_list%get_rval (var_str ("real_partition_scale")) pcm%vis_fks_regions = & var_list%get_lval (var_str ("?vis_fks_regions")) call pcm%set_blha_defaults & (env%has_polarized_beams (), env%get_var_list_ptr ()) pcm%os_data = env%get_os_data () end subroutine pcm_nlo_init @ %def pcm_nlo_init @ Init/rewrite NLO settings without the FKS template. <>= procedure :: init_nlo_settings => pcm_nlo_init_nlo_settings <>= subroutine pcm_nlo_init_nlo_settings (pcm, var_list) class(pcm_nlo_t), intent(inout) :: pcm type(var_list_t), intent(in), target :: var_list call pcm%settings%init (var_list) end subroutine pcm_nlo_init_nlo_settings @ %def pcm_nlo_init_nlo_settings @ As appropriate for the NLO/FKS algorithm, the category defined by the process, is called [[nlo_type]]. We refine this by setting the component category [[component_type]] separately. The component types [[COMP_MISMATCH]], [[COMP_PDF]], [[COMP_SUB]] are set only if the algorithm uses combined integration. Otherwise, they are set to [[COMP_DEFAULT]]. The component type [[COMP_REAL]] is further distinguished between [[COMP_REAL_SING]] or [[COMP_REAL_FIN]], if the algorithm uses real partitions. The former acts as a reference component for the latter, and we always assume that it is the first real component. Each component is assigned its own core. Exceptions: the finite-real component gets the same core as the singular-real component. The mismatch component gets the same core as the subtraction component. TODO wk 2018: this convention for real components can be improved. Check whether all component types should be assigned, not just for combined integration. <>= procedure :: categorize_components => pcm_nlo_categorize_components <>= subroutine pcm_nlo_categorize_components (pcm, config) class(pcm_nlo_t), intent(inout) :: pcm type(process_config_data_t), intent(in) :: config type(process_component_def_t), pointer :: component_def integer :: i allocate (pcm%nlo_type (pcm%n_components), source = COMPONENT_UNDEFINED) allocate (pcm%component_type (pcm%n_components), source = COMP_DEFAULT) do i = 1, pcm%n_components component_def => config%process_def%get_component_def_ptr (i) pcm%nlo_type(i) = component_def%get_nlo_type () if (pcm%combined_integration) then select case (pcm%nlo_type(i)) case (BORN) pcm%i_born = i pcm%component_type(i) = COMP_MASTER case (NLO_REAL) pcm%component_type(i) = COMP_REAL case (NLO_VIRTUAL) pcm%component_type(i) = COMP_VIRT case (NLO_MISMATCH) pcm%component_type(i) = COMP_MISMATCH case (NLO_DGLAP) pcm%component_type(i) = COMP_PDF case (NLO_SUBTRACTION) pcm%component_type(i) = COMP_SUB pcm%i_sub = i end select else select case (pcm%nlo_type(i)) case (BORN) pcm%i_born = i pcm%component_type(i) = COMP_MASTER case (NLO_REAL) pcm%component_type(i) = COMP_REAL case (NLO_VIRTUAL) pcm%component_type(i) = COMP_VIRT case (NLO_MISMATCH) pcm%component_type(i) = COMP_MISMATCH case (NLO_SUBTRACTION) pcm%i_sub = i end select end if end do call refine_real_type ( & pack ([(i, i=1, pcm%n_components)], & pcm%component_type==COMP_REAL)) contains subroutine refine_real_type (i_real) integer, dimension(:), intent(in) :: i_real pcm%i_real = i_real(1) if (pcm%use_real_partition) then pcm%component_type (i_real(1)) = COMP_REAL_SING pcm%component_type (i_real(2:)) = COMP_REAL_FIN end if end subroutine refine_real_type end subroutine pcm_nlo_categorize_components @ %def pcm_nlo_categorize_components @ \subsubsection{Phase-space initial configuration} Setup for the NLO/PHS processes: two phase-space configurations, (1) Born/wood, (2) real correction/FKS. All components use either one of these two configurations. TODO wk 2018: The [[first_real_component]] identifier is really ugly. Nothing should rely on the ordering. <>= procedure :: init_phs_config => pcm_nlo_init_phs_config <>= subroutine pcm_nlo_init_phs_config & (pcm, phs_entry, meta, env, phs_par, mapping_defs) class(pcm_nlo_t), intent(inout) :: pcm type(process_phs_config_t), & dimension(:), allocatable, intent(out) :: phs_entry type(process_metadata_t), intent(in) :: meta type(process_environment_t), intent(in) :: env type(mapping_defaults_t), intent(in) :: mapping_defs type(phs_parameters_t), intent(in) :: phs_par integer :: i logical :: first_real_component allocate (phs_entry (2)) call dispatch_phs (phs_entry(1)%phs_config, & env%get_var_list_ptr (), & env%get_os_data (), & meta%id, & mapping_defs, phs_par, & var_str ("wood")) call dispatch_phs (phs_entry(2)%phs_config, & env%get_var_list_ptr (), & env%get_os_data (), & meta%id, & mapping_defs, phs_par, & var_str ("fks")) allocate (pcm%i_phs_config (pcm%n_components), source=0) first_real_component = .true. do i = 1, pcm%n_components select case (pcm%nlo_type(i)) case (BORN, NLO_VIRTUAL, NLO_SUBTRACTION) pcm%i_phs_config(i) = 1 case (NLO_REAL) if (pcm%use_real_partition) then if (pcm%use_real_singular) then if (first_real_component) then pcm%i_phs_config(i) = 2 first_real_component = .false. else pcm%i_phs_config(i) = 1 end if else pcm%i_phs_config(i) = 1 end if else pcm%i_phs_config(i) = 2 end if case (NLO_MISMATCH, NLO_DGLAP, GKS) pcm%i_phs_config(i) = 2 end select end do end subroutine pcm_nlo_init_phs_config @ %def pcm_nlo_init_phs_config @ \subsubsection{Core management} Allocate the core (matrix-element interface) objects that we will need for evaluation. Every component gets an associated core, except for the real-finite and mismatch components (if any). Those components are associated with their previous corresponding real-singular and subtraction cores, respectively. After cores are allocated, configure the region-data block that is maintained by the NLO process-component manager. <>= procedure :: allocate_cores => pcm_nlo_allocate_cores <>= subroutine pcm_nlo_allocate_cores (pcm, config, core_entry) class(pcm_nlo_t), intent(inout) :: pcm type(process_config_data_t), intent(in) :: config type(core_entry_t), dimension(:), allocatable, intent(out) :: core_entry type(process_component_def_t), pointer :: component_def integer :: i, i_core allocate (pcm%i_core (pcm%n_components), source = 0) pcm%n_cores = pcm%n_components & - count (pcm%component_type(:) == COMP_REAL_FIN) & - count (pcm%component_type(:) == COMP_MISMATCH) allocate (core_entry (pcm%n_cores)) allocate (pcm%nlo_type_core (pcm%n_cores), source = BORN) i_core = 0 do i = 1, pcm%n_components select case (pcm%component_type(i)) case default i_core = i_core + 1 pcm%i_core(i) = i_core pcm%nlo_type_core(i_core) = pcm%nlo_type(i) core_entry(i_core)%i_component = i component_def => config%process_def%get_component_def_ptr (i) core_entry(i_core)%core_def => component_def%get_core_def_ptr () select case (pcm%nlo_type(i)) case default core_entry(i)%active = component_def%can_be_integrated () case (NLO_REAL, NLO_SUBTRACTION) core_entry(i)%active = .true. end select case (COMP_REAL_FIN) pcm%i_core(i) = pcm%i_core(pcm%i_real) case (COMP_MISMATCH) pcm%i_core(i) = pcm%i_core(pcm%i_sub) end select end do end subroutine pcm_nlo_allocate_cores @ %def pcm_nlo_allocate_cores @ Extra code is required for certain core types (threshold) or if BLHA uses an external OLP for getting its matrix elements. OMega matrix elements, by definition, do not need extra code. NLO-virtual or subtraction matrix elements always need extra code. More precisely: for the Born and virtual matrix element, the extra code is accessed only if the component is active. The radiation (real) and the subtraction corrections (singular and finite), extra code is accessed in any case. The flavor state is taken from the [[region_data]] table in the [[pcm]] record. We use the Born and real flavor-state tables as appropriate. <>= procedure :: prepare_any_external_code => & pcm_nlo_prepare_any_external_code <>= subroutine pcm_nlo_prepare_any_external_code & (pcm, core_entry, i_core, libname, model, var_list) class(pcm_nlo_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry integer, intent(in) :: i_core type(string_t), intent(in) :: libname type(model_data_t), intent(in), target :: model type(var_list_t), intent(in) :: var_list integer, dimension(:,:), allocatable :: flv_born, flv_real integer :: i call pcm%region_data%get_all_flv_states (flv_born, flv_real) if (core_entry%active) then associate (core => core_entry%core) if (core%needs_external_code ()) then select case (pcm%nlo_type (core_entry%i_component)) case default call core%data%set_flv_state (flv_born) case (NLO_REAL) call core%data%set_flv_state (flv_real) end select call core%prepare_external_code & (core%data%flv_state, & var_list, pcm%os_data, libname, model, i_core, .true.) end if call core%set_equivalent_flv_hel_indices () end associate end if end subroutine pcm_nlo_prepare_any_external_code @ %def pcm_nlo_prepare_any_external_code @ Allocate and configure the BLHA record for a specific core, assuming that the core type requires it. The configuration depends on the NLO type of the core. <>= procedure :: setup_blha => pcm_nlo_setup_blha <>= subroutine pcm_nlo_setup_blha (pcm, core_entry) class(pcm_nlo_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry allocate (core_entry%blha_config, source = pcm%blha_defaults) select case (pcm%nlo_type(core_entry%i_component)) case (BORN) call core_entry%blha_config%set_born () case (NLO_REAL) call core_entry%blha_config%set_real_trees () case (NLO_VIRTUAL) call core_entry%blha_config%set_loop () case (NLO_SUBTRACTION) call core_entry%blha_config%set_subtraction () call core_entry%blha_config%set_internal_color_correlations () case (NLO_DGLAP) call core_entry%blha_config%set_dglap () end select end subroutine pcm_nlo_setup_blha @ %def pcm_nlo_setup_blha @ After phase-space configuration data and core entries are available, we fill tables and compute the remaining NLO data that will steer the integration and subtraction algorithm. There are three parts: recognize a threshold-type process core (if it exists), prepare the region-data tables (always), and prepare for real partitioning (if requested). The real-component phase space acts as the source for resonance-history information, required for the region data. <>= procedure :: complete_setup => pcm_nlo_complete_setup <>= subroutine pcm_nlo_complete_setup (pcm, core_entry, component, model) class(pcm_nlo_t), intent(inout) :: pcm type(core_entry_t), dimension(:), intent(in) :: core_entry type(process_component_t), dimension(:), intent(inout) :: component type(model_t), intent(in), target :: model integer :: alpha_power, alphas_power call pcm%handle_threshold_core (core_entry) call component(1)%config%get_coupling_powers (alpha_power, alphas_power) call pcm%setup_region_data & (core_entry, component(pcm%i_real)%phs_config, model, alpha_power, alphas_power) call pcm%setup_real_partition () end subroutine pcm_nlo_complete_setup @ %def pcm_nlo_complete_setup @ Apply the BLHA configuration to a core object, using the region data from [[pcm]] for determining the particle content. <>= procedure :: prepare_blha_core => pcm_nlo_prepare_blha_core <>= subroutine pcm_nlo_prepare_blha_core (pcm, core_entry, model) class(pcm_nlo_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry class(model_data_t), intent(in), target :: model integer :: n_in integer :: n_legs integer :: n_flv integer :: n_hel select type (core => core_entry%core) class is (prc_blha_t) associate (blha_config => core_entry%blha_config) n_in = core%data%n_in select case (pcm%nlo_type(core_entry%i_component)) case (NLO_REAL) n_legs = pcm%region_data%get_n_legs_real () n_flv = pcm%region_data%get_n_flv_real () case default n_legs = pcm%region_data%get_n_legs_born () n_flv = pcm%region_data%get_n_flv_born () end select n_hel = blha_config%get_n_hel (core%data%flv_state (1:n_in,1), model) call core%init_blha (blha_config, n_in, n_legs, n_flv, n_hel) call core%init_driver (pcm%os_data) end associate end select end subroutine pcm_nlo_prepare_blha_core @ %def pcm_nlo_prepare_blha_core @ Read the method settings from the variable list and store them in the BLHA master. This version: NLO flag set. <>= procedure :: set_blha_methods => pcm_nlo_set_blha_methods <>= subroutine pcm_nlo_set_blha_methods (pcm, blha_master, var_list) class(pcm_nlo_t), intent(inout) :: pcm type(blha_master_t), intent(inout) :: blha_master type(var_list_t), intent(in) :: var_list call blha_master%set_methods (.true., var_list) call pcm%blha_defaults%set_loop_method (blha_master) end subroutine pcm_nlo_set_blha_methods @ %def pcm_nlo_set_blha_methods @ Produce the LO and NLO flavor-state tables (as far as available), as appropriate for BLHA configuration. The NLO version copies the tables from the region data inside [[pcm]]. The core array is not needed. <>= procedure :: get_blha_flv_states => pcm_nlo_get_blha_flv_states <>= subroutine pcm_nlo_get_blha_flv_states & (pcm, core_entry, flv_born, flv_real) class(pcm_nlo_t), intent(in) :: pcm type(core_entry_t), dimension(:), intent(in) :: core_entry integer, dimension(:,:), allocatable, intent(out) :: flv_born integer, dimension(:,:), allocatable, intent(out) :: flv_real call pcm%region_data%get_all_flv_states (flv_born, flv_real) end subroutine pcm_nlo_get_blha_flv_states @ %def pcm_nlo_get_blha_flv_states @ Allocate and configure the MCI (multi-channel integrator) records. The relation depends on the [[combined_integration]] setting. If we integrate components separately, each component gets its own record, except for the subtraction component. If we do the combination, there is one record for the master (Born) component and a second one for the real-finite component, if present. Each entry acquires some NLO-specific initialization. Generic configuration follows later. Second procedure: call the MCI dispatcher with NLO-setup arguments. <>= procedure :: setup_mci => pcm_nlo_setup_mci procedure :: call_dispatch_mci => pcm_nlo_call_dispatch_mci <>= subroutine pcm_nlo_setup_mci (pcm, mci_entry) class(pcm_nlo_t), intent(inout) :: pcm type(process_mci_entry_t), & dimension(:), allocatable, intent(out) :: mci_entry class(mci_t), allocatable :: mci_template integer :: i, i_mci if (pcm%combined_integration) then pcm%n_mci = 1 & + count (pcm%component_active(:) & & .and. pcm%component_type(:) == COMP_REAL_FIN) allocate (pcm%i_mci (pcm%n_components), source = 0) do i = 1, pcm%n_components if (pcm%component_active(i)) then select case (pcm%component_type(i)) case (COMP_MASTER) pcm%i_mci(i) = 1 case (COMP_REAL_FIN) pcm%i_mci(i) = 2 end select end if end do else pcm%n_mci = count (pcm%component_active(:) & & .and. pcm%nlo_type(:) /= NLO_SUBTRACTION) allocate (pcm%i_mci (pcm%n_components), source = 0) i_mci = 0 do i = 1, pcm%n_components if (pcm%component_active(i)) then select case (pcm%nlo_type(i)) case default i_mci = i_mci + 1 pcm%i_mci(i) = i_mci case (NLO_SUBTRACTION) end select end if end do end if allocate (mci_entry (pcm%n_mci)) mci_entry(:)%combined_integration = pcm%combined_integration if (pcm%use_real_partition) then do i = 1, pcm%n_components i_mci = pcm%i_mci(i) if (i_mci > 0) then select case (pcm%component_type(i)) case (COMP_REAL_FIN) mci_entry(i_mci)%real_partition_type = REAL_FINITE case default mci_entry(i_mci)%real_partition_type = REAL_SINGULAR end select end if end do end if end subroutine pcm_nlo_setup_mci subroutine pcm_nlo_call_dispatch_mci (pcm, & dispatch_mci, var_list, process_id, mci_template) class(pcm_nlo_t), intent(inout) :: pcm procedure(dispatch_mci_proc) :: dispatch_mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id class(mci_t), allocatable, intent(out) :: mci_template call dispatch_mci (mci_template, var_list, process_id, is_nlo = .true.) end subroutine pcm_nlo_call_dispatch_mci @ %def pcm_nlo_setup_mci @ %def pcm_nlo_call_dispatch_mci @ Check for a threshold core and adjust the configuration accordingly, before singular region data are considered. <>= procedure :: handle_threshold_core => pcm_nlo_handle_threshold_core <>= subroutine pcm_nlo_handle_threshold_core (pcm, core_entry) class(pcm_nlo_t), intent(inout) :: pcm type(core_entry_t), dimension(:), intent(in) :: core_entry integer :: i do i = 1, size (core_entry) select type (core => core_entry(i)%core_def) type is (threshold_def_t) pcm%settings%factorization_mode = FACTORIZATION_THRESHOLD return end select end do end subroutine pcm_nlo_handle_threshold_core @ %def pcm_nlo_handle_threshold_core @ Configure the singular-region tables based on the process data for the Born and Real (singular) cores, using also the appropriate FKS phase-space configuration object. In passing, we may create a table of resonance histories that are relevant for the singular-region configuration. TODO wk 2018: check whether [[phs_entry]] needs to be intent(inout). <>= procedure :: setup_region_data => pcm_nlo_setup_region_data <>= subroutine pcm_nlo_setup_region_data & (pcm, core_entry, phs_config, model, alpha_power, alphas_power) class(pcm_nlo_t), intent(inout) :: pcm type(core_entry_t), dimension(:), intent(in) :: core_entry class(phs_config_t), intent(inout) :: phs_config type(model_t), intent(in), target :: model type(process_constants_t) :: data_born, data_real integer, dimension (:,:), allocatable :: flavor_born, flavor_real type(resonance_history_t), dimension(:), allocatable :: resonance_histories type(var_list_t), pointer :: var_list integer, intent(in) :: alpha_power, alphas_power logical :: success data_born = core_entry(pcm%i_core(pcm%i_born))%core%data data_real = core_entry(pcm%i_core(pcm%i_real))%core%data call data_born%get_flv_state (flavor_born) call data_real%get_flv_state (flavor_real) call pcm%region_data%init & (data_born%n_in, model, flavor_born, flavor_real, & pcm%settings%nlo_correction_type, alpha_power, alphas_power) associate (template => pcm%settings%fks_template) if (template%mapping_type == FKS_RESONANCES) then select type (phs_config) type is (phs_fks_config_t) call get_filtered_resonance_histories (phs_config, & data_born%n_in, flavor_born, model, & template%excluded_resonances, & resonance_histories, success) end select if (.not. success) template%mapping_type = FKS_DEFAULT end if call pcm%region_data%setup_fks_mappings (template, data_born%n_in) !!! Check again, mapping_type might have changed if (template%mapping_type == FKS_RESONANCES) then call pcm%region_data%set_resonance_mappings (resonance_histories) call pcm%region_data%init_resonance_information () pcm%settings%use_resonance_mappings = .true. end if end associate if (pcm%settings%factorization_mode == FACTORIZATION_THRESHOLD) then call pcm%region_data%set_isr_pseudo_regions () call pcm%region_data%split_up_interference_regions_for_threshold () end if call pcm%region_data%compute_number_of_phase_spaces () call pcm%region_data%set_i_phs_to_i_con () call pcm%region_data%write_to_file & (pcm%id, pcm%vis_fks_regions, pcm%os_data) if (debug_active (D_SUBTRACTION)) & call pcm%region_data%check_consistency (.true.) end subroutine pcm_nlo_setup_region_data @ %def pcm_nlo_setup_region_data @ After region data are set up, we allocate and configure the [[real_partition]] objects, if requested. <>= procedure :: setup_real_partition => pcm_nlo_setup_real_partition <>= subroutine pcm_nlo_setup_real_partition (pcm) class(pcm_nlo_t), intent(inout) :: pcm if (pcm%use_real_partition) then if (.not. allocated (pcm%real_partition)) then allocate (real_partition_fixed_order_t :: pcm%real_partition) select type (partition => pcm%real_partition) type is (real_partition_fixed_order_t) call pcm%region_data%get_all_ftuples (partition%fks_pairs) partition%scale = pcm%real_partition_scale end select end if end if end subroutine pcm_nlo_setup_real_partition @ %def pcm_nlo_setup_real_partition @ Initialize a single component. We require all process-configuration blocks, and specific templates for the phase-space and integrator configuration. We also provide the current component index [[i]] and the [[active]] flag. For a subtraction component, the [[active]] flag is overridden. In the nlo mode, the component types have been determined before. TODO wk 2018: the component type need not be stored in the component; we may remove this when everything is controlled by [[pcm]]. <>= procedure :: init_component => pcm_nlo_init_component <>= subroutine pcm_nlo_init_component & (pcm, component, i, active, & phs_config, env, meta, config) class(pcm_nlo_t), intent(in) :: pcm type(process_component_t), intent(out) :: component integer, intent(in) :: i logical, intent(in) :: active class(phs_config_t), allocatable, intent(in) :: phs_config type(process_environment_t), intent(in) :: env type(process_metadata_t), intent(in) :: meta type(process_config_data_t), intent(in) :: config logical :: activate select case (pcm%nlo_type(i)) case default; activate = active case (NLO_SUBTRACTION); activate = .false. end select call component%init (i, & env, meta, config, & activate, & phs_config) component%component_type = pcm%component_type(i) end subroutine pcm_nlo_init_component @ %def pcm_nlo_init_component @ Override the base method: record the active components in the PCM object, and report inactive components (except for the subtraction component). <>= procedure :: record_inactive_components => pcm_nlo_record_inactive_components <>= subroutine pcm_nlo_record_inactive_components (pcm, component, meta) class(pcm_nlo_t), intent(inout) :: pcm type(process_component_t), dimension(:), intent(in) :: component type(process_metadata_t), intent(inout) :: meta integer :: i pcm%component_active = component%active do i = 1, pcm%n_components select case (pcm%nlo_type(i)) case (NLO_SUBTRACTION) case default if (.not. component(i)%active) call meta%deactivate_component (i) end select end do end subroutine pcm_nlo_record_inactive_components @ %def pcm_nlo_record_inactive_components @ <>= procedure :: core_is_radiation => pcm_nlo_core_is_radiation <>= function pcm_nlo_core_is_radiation (pcm, i_core) result (is_rad) logical :: is_rad class(pcm_nlo_t), intent(in) :: pcm integer, intent(in) :: i_core is_rad = pcm%nlo_type(i_core) == NLO_REAL ! .and. .not. pcm%cm%sub(i_core) end function pcm_nlo_core_is_radiation @ %def pcm_nlo_core_is_radiation @ <>= procedure :: get_n_flv_born => pcm_nlo_get_n_flv_born <>= function pcm_nlo_get_n_flv_born (pcm_nlo) result (n_flv) integer :: n_flv class(pcm_nlo_t), intent(in) :: pcm_nlo n_flv = pcm_nlo%region_data%n_flv_born end function pcm_nlo_get_n_flv_born @ %def pcm_nlo_get_n_flv_born @ <>= procedure :: get_n_flv_real => pcm_nlo_get_n_flv_real <>= function pcm_nlo_get_n_flv_real (pcm_nlo) result (n_flv) integer :: n_flv class(pcm_nlo_t), intent(in) :: pcm_nlo n_flv = pcm_nlo%region_data%n_flv_real end function pcm_nlo_get_n_flv_real @ %def pcm_nlo_get_n_flv_real @ <>= procedure :: get_n_alr => pcm_nlo_get_n_alr <>= function pcm_nlo_get_n_alr (pcm) result (n_alr) integer :: n_alr class(pcm_nlo_t), intent(in) :: pcm n_alr = pcm%region_data%n_regions end function pcm_nlo_get_n_alr @ %def pcm_nlo_get_n_alr @ <>= procedure :: get_flv_states => pcm_nlo_get_flv_states <>= function pcm_nlo_get_flv_states (pcm, born) result (flv) integer, dimension(:,:), allocatable :: flv class(pcm_nlo_t), intent(in) :: pcm logical, intent(in) :: born if (born) then flv = pcm%region_data%get_flv_states_born () else flv = pcm%region_data%get_flv_states_real () end if end function pcm_nlo_get_flv_states @ %def pcm_nlo_get_flv_states @ <>= procedure :: get_qn => pcm_nlo_get_qn <>= function pcm_nlo_get_qn (pcm, born) result (qn) type(quantum_numbers_t), dimension(:,:), allocatable :: qn class(pcm_nlo_t), intent(in) :: pcm logical, intent(in) :: born if (born) then qn = pcm%qn_born else qn = pcm%qn_real end if end function pcm_nlo_get_qn @ %def pcm_nlo_get_qn @ Check if there are massive emitters. Since the mass-structure of all underlying Born configurations have to be the same (\textbf{This does not have to be the case when different components are generated at LO}) , we just use the first one to determine this. <>= procedure :: has_massive_emitter => pcm_nlo_has_massive_emitter <>= function pcm_nlo_has_massive_emitter (pcm) result (val) logical :: val class(pcm_nlo_t), intent(in) :: pcm integer :: i val = .false. associate (reg_data => pcm%region_data) do i = reg_data%n_in + 1, reg_data%n_legs_born if (any (i == reg_data%emitters)) & val = val .or. reg_data%flv_born(1)%massive(i) end do end associate end function pcm_nlo_has_massive_emitter @ %def pcm_nlo_has_massive_emitter @ Returns an array which specifies if the particle at position [[i]] is massive. <>= procedure :: get_mass_info => pcm_nlo_get_mass_info <>= function pcm_nlo_get_mass_info (pcm, i_flv) result (massive) class(pcm_nlo_t), intent(in) :: pcm integer, intent(in) :: i_flv logical, dimension(:), allocatable :: massive allocate (massive (size (pcm%region_data%flv_born(i_flv)%massive))) massive = pcm%region_data%flv_born(i_flv)%massive end function pcm_nlo_get_mass_info @ %def pcm_nlo_get_mass_info @ <>= procedure :: allocate_workspace => pcm_nlo_allocate_workspace <>= subroutine pcm_nlo_allocate_workspace (pcm, work) class(pcm_nlo_t), intent(in) :: pcm class(pcm_workspace_t), intent(inout), allocatable :: work allocate (pcm_nlo_workspace_t :: work) end subroutine pcm_nlo_allocate_workspace @ %def pcm_nlo_allocate_workspace @ <>= procedure :: init_qn => pcm_nlo_init_qn <>= subroutine pcm_nlo_init_qn (pcm, model) class(pcm_nlo_t), intent(inout) :: pcm class(model_data_t), intent(in) :: model integer, dimension(:,:), allocatable :: flv_states type(flavor_t), dimension(:), allocatable :: flv integer :: i type(quantum_numbers_t), dimension(:), allocatable :: qn allocate (flv_states (pcm%region_data%n_legs_born, pcm%region_data%n_flv_born)) flv_states = pcm%get_flv_states (.true.) allocate (pcm%qn_born (size (flv_states, dim = 1), size (flv_states, dim = 2))) allocate (flv (size (flv_states, dim = 1))) allocate (qn (size (flv_states, dim = 1))) do i = 1, pcm%get_n_flv_born () call flv%init (flv_states (:,i), model) call qn%init (flv) pcm%qn_born(:,i) = qn end do deallocate (flv); deallocate (qn) deallocate (flv_states) allocate (flv_states (pcm%region_data%n_legs_real, pcm%region_data%n_flv_real)) flv_states = pcm%get_flv_states (.false.) allocate (pcm%qn_real (size (flv_states, dim = 1), size (flv_states, dim = 2))) allocate (flv (size (flv_states, dim = 1))) allocate (qn (size (flv_states, dim = 1))) do i = 1, pcm%get_n_flv_real () call flv%init (flv_states (:,i), model) call qn%init (flv) pcm%qn_real(:,i) = qn end do end subroutine pcm_nlo_init_qn @ %def pcm_nlo_init_qn @ <>= procedure :: allocate_ps_matching => pcm_nlo_allocate_ps_matching <>= subroutine pcm_nlo_allocate_ps_matching (pcm) class(pcm_nlo_t), intent(inout) :: pcm if (.not. allocated (pcm%real_partition)) then allocate (powheg_damping_simple_t :: pcm%real_partition) end if end subroutine pcm_nlo_allocate_ps_matching @ %def pcm_nlo_allocate_ps_matching @ <>= procedure :: activate_dalitz_plot => pcm_nlo_activate_dalitz_plot <>= subroutine pcm_nlo_activate_dalitz_plot (pcm, filename) class(pcm_nlo_t), intent(inout) :: pcm type(string_t), intent(in) :: filename call pcm%dalitz_plot%init (free_unit (), filename, .false.) call pcm%dalitz_plot%write_header () end subroutine pcm_nlo_activate_dalitz_plot @ %def pcm_nlo_activate_dalitz_plot @ <>= procedure :: register_dalitz_plot => pcm_nlo_register_dalitz_plot <>= subroutine pcm_nlo_register_dalitz_plot (pcm, emitter, p) class(pcm_nlo_t), intent(inout) :: pcm integer, intent(in) :: emitter type(vector4_t), intent(in), dimension(:) :: p real(default) :: k0_n, k0_np1 k0_n = p(emitter)%p(0) k0_np1 = p(size(p))%p(0) call pcm%dalitz_plot%register (k0_n, k0_np1) end subroutine pcm_nlo_register_dalitz_plot @ %def pcm_nlo_register_dalitz_plot @ <>= procedure :: setup_phs_generator => pcm_nlo_setup_phs_generator <>= subroutine pcm_nlo_setup_phs_generator (pcm, pcm_work, generator, & sqrts, mode, singular_jacobian) class(pcm_nlo_t), intent(in) :: pcm type(phs_fks_generator_t), intent(inout) :: generator type(pcm_nlo_workspace_t), intent(in), target :: pcm_work real(default), intent(in) :: sqrts integer, intent(in), optional:: mode logical, intent(in), optional :: singular_jacobian logical :: yorn yorn = .false.; if (present (singular_jacobian)) yorn = singular_jacobian call generator%connect_kinematics (pcm_work%isr_kinematics, & pcm_work%real_kinematics, pcm%has_massive_emitter ()) generator%n_in = pcm%region_data%n_in call generator%set_sqrts_hat (sqrts) call generator%set_emitters (pcm%region_data%emitters) call generator%setup_masses (pcm%region_data%n_legs_born) generator%is_massive = pcm%get_mass_info (1) generator%singular_jacobian = yorn if (present (mode)) generator%mode = mode call generator%set_xi_and_y_bounds (pcm%settings%fks_template%xi_min, & pcm%settings%fks_template%y_max) end subroutine pcm_nlo_setup_phs_generator @ %def pcm_nlo_setup_phs_generator @ <>= procedure :: final => pcm_nlo_final <>= subroutine pcm_nlo_final (pcm) class(pcm_nlo_t), intent(inout) :: pcm if (allocated (pcm%real_partition)) deallocate (pcm%real_partition) call pcm%dalitz_plot%final () end subroutine pcm_nlo_final @ %def pcm_nlo_final @ <>= procedure :: is_nlo => pcm_nlo_is_nlo <>= function pcm_nlo_is_nlo (pcm) result (is_nlo) logical :: is_nlo class(pcm_nlo_t), intent(in) :: pcm is_nlo = .true. end function pcm_nlo_is_nlo @ %def pcm_nlo_is_nlo @ As a first implementation, it acts as a wrapper for the NLO controller object and the squared matrix-element collector. <>= public :: pcm_nlo_workspace_t <>= type, extends (pcm_workspace_t) :: pcm_nlo_workspace_t type(real_kinematics_t), pointer :: real_kinematics => null () type(isr_kinematics_t), pointer :: isr_kinematics => null () type(real_subtraction_t) :: real_sub type(virtual_t) :: virtual type(soft_mismatch_t) :: soft_mismatch type(dglap_remnant_t) :: dglap_remnant integer, dimension(:), allocatable :: i_mci_to_real_component contains <> end type pcm_nlo_workspace_t @ %def pcm_nlo_workspace_t @ <>= procedure :: set_radiation_event => pcm_nlo_workspace_set_radiation_event procedure :: set_subtraction_event => pcm_nlo_workspace_set_subtraction_event <>= subroutine pcm_nlo_workspace_set_radiation_event (pcm_work) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work pcm_work%real_sub%radiation_event = .true. pcm_work%real_sub%subtraction_event = .false. end subroutine pcm_nlo_workspace_set_radiation_event subroutine pcm_nlo_workspace_set_subtraction_event (pcm_work) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work pcm_work%real_sub%radiation_event = .false. pcm_work%real_sub%subtraction_event = .true. end subroutine pcm_nlo_workspace_set_subtraction_event @ %def pcm_nlo_workspace_set_radiation_event @ %def pcm_nlo_workspace_set_subtraction_event <>= procedure :: disable_subtraction => pcm_nlo_workspace_disable_subtraction <>= subroutine pcm_nlo_workspace_disable_subtraction (pcm_work) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work pcm_work%real_sub%subtraction_deactivated = .true. end subroutine pcm_nlo_workspace_disable_subtraction @ %def pcm_nlo_workspace_disable_subtraction @ <>= procedure :: init_config => pcm_nlo_workspace_init_config <>= subroutine pcm_nlo_workspace_init_config (pcm_work, pcm, active_components, & nlo_types, energy, i_real_fin, model) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work class(pcm_t), intent(in) :: pcm logical, intent(in), dimension(:) :: active_components integer, intent(in), dimension(:) :: nlo_types real(default), intent(in), dimension(:) :: energy integer, intent(in) :: i_real_fin class(model_data_t), intent(in) :: model integer :: i_component if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "pcm_nlo_workspace_init_config") call pcm_work%init_real_and_isr_kinematics (pcm, energy) select type (pcm) type is (pcm_nlo_t) do i_component = 1, size (active_components) if (active_components(i_component) .or. pcm%settings%combined_integration) then select case (nlo_types(i_component)) case (NLO_REAL) if (i_component /= i_real_fin) then call pcm_work%setup_real_component (pcm, & pcm%settings%fks_template%subtraction_disabled) end if case (NLO_VIRTUAL) call pcm_work%init_virtual (pcm, model) case (NLO_MISMATCH) call pcm_work%init_soft_mismatch (pcm) case (NLO_DGLAP) call pcm_work%init_dglap_remnant (pcm) end select end if end do end select end subroutine pcm_nlo_workspace_init_config @ %def pcm_nlo_workspace_init_config @ <>= procedure :: setup_real_component => pcm_nlo_workspace_setup_real_component <>= subroutine pcm_nlo_workspace_setup_real_component (pcm_work, pcm, & subtraction_disabled) class(pcm_nlo_workspace_t), intent(inout), target :: pcm_work class(pcm_t), intent(in) :: pcm logical, intent(in) :: subtraction_disabled select type (pcm) type is (pcm_nlo_t) call pcm_work%init_real_subtraction (pcm) if (subtraction_disabled) call pcm_work%disable_subtraction () end select end subroutine pcm_nlo_workspace_setup_real_component @ %def pcm_nlo_workspace_setup_real_component @ <>= procedure :: init_real_and_isr_kinematics => & pcm_nlo_workspace_init_real_and_isr_kinematics <>= subroutine pcm_nlo_workspace_init_real_and_isr_kinematics (pcm_work, pcm, energy) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work class(pcm_t), intent(in) :: pcm real(default), dimension(:), intent(in) :: energy integer :: n_contr allocate (pcm_work%real_kinematics) allocate (pcm_work%isr_kinematics) select type (pcm) type is (pcm_nlo_t) associate (region_data => pcm%region_data) if (allocated (region_data%alr_contributors)) then n_contr = size (region_data%alr_contributors) else if (pcm%settings%factorization_mode == FACTORIZATION_THRESHOLD) then n_contr = 2 else n_contr = 1 end if call pcm_work%real_kinematics%init & (region_data%n_legs_real, region_data%n_phs, & region_data%n_regions, n_contr) if (pcm%settings%factorization_mode == FACTORIZATION_THRESHOLD) & call pcm_work%real_kinematics%init_onshell & (region_data%n_legs_real, region_data%n_phs) pcm_work%isr_kinematics%n_in = region_data%n_in end associate end select pcm_work%isr_kinematics%beam_energy = energy end subroutine pcm_nlo_workspace_init_real_and_isr_kinematics @ %def pcm_nlo_workspace_init_real_and_isr_kinematics @ <>= procedure :: set_real_and_isr_kinematics => & pcm_nlo_workspace_set_real_and_isr_kinematics <>= subroutine pcm_nlo_workspace_set_real_and_isr_kinematics (pcm_work, phs_identifiers, sqrts) class(pcm_nlo_workspace_t), intent(inout), target :: pcm_work type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers real(default), intent(in) :: sqrts call pcm_work%real_sub%set_real_kinematics & (pcm_work%real_kinematics) call pcm_work%real_sub%set_isr_kinematics & (pcm_work%isr_kinematics) end subroutine pcm_nlo_workspace_set_real_and_isr_kinematics @ %def pcm_nlo_workspace_set_real_and_isr_kinematics @ <>= procedure :: init_real_subtraction => pcm_nlo_workspace_init_real_subtraction <>= subroutine pcm_nlo_workspace_init_real_subtraction (pcm_work, pcm) class(pcm_nlo_workspace_t), intent(inout), target :: pcm_work class(pcm_t), intent(in) :: pcm select type (pcm) type is (pcm_nlo_t) associate (region_data => pcm%region_data) call pcm_work%real_sub%init (region_data, pcm%settings) if (allocated (pcm%settings%selected_alr)) then associate (selected_alr => pcm%settings%selected_alr) if (any (selected_alr < 0)) then call msg_fatal ("Fixed alpha region must be non-negative!") else if (any (selected_alr > region_data%n_regions)) then call msg_fatal ("Fixed alpha region is larger than the total"& &" number of singular regions!") else allocate (pcm_work%real_sub%selected_alr (size (selected_alr))) pcm_work%real_sub%selected_alr = selected_alr end if end associate end if end associate end select end subroutine pcm_nlo_workspace_init_real_subtraction @ %def pcm_nlo_workspace_init_real_subtraction @ <>= procedure :: set_momenta_and_scales_virtual => & pcm_nlo_workspace_set_momenta_and_scales_virtual <>= subroutine pcm_nlo_workspace_set_momenta_and_scales_virtual (pcm_work, p, & ren_scale, fac_scale, es_scale) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work type(vector4_t), intent(in), dimension(:) :: p real(default), allocatable, intent(in) :: ren_scale real(default), intent(in) :: fac_scale real(default), allocatable, intent(in) :: es_scale associate (virtual => pcm_work%virtual) call virtual%set_ren_scale (ren_scale) call virtual%set_fac_scale (p, fac_scale) call virtual%set_ellis_sexton_scale (es_scale) end associate end subroutine pcm_nlo_workspace_set_momenta_and_scales_virtual @ %def pcm_nlo_workspace_set_momenta_and_scales_virtual @ <>= procedure :: set_fac_scale => pcm_nlo_workspace_set_fac_scale <>= subroutine pcm_nlo_workspace_set_fac_scale (pcm_work, fac_scale) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work real(default), intent(in) :: fac_scale pcm_work%isr_kinematics%fac_scale = fac_scale end subroutine pcm_nlo_workspace_set_fac_scale @ %def pcm_nlo_workspace_set_fac_scale @ <>= procedure :: set_momenta => pcm_nlo_workspace_set_momenta <>= subroutine pcm_nlo_workspace_set_momenta (pcm_work, p_born, p_real, i_phs, cms) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work type(vector4_t), dimension(:), intent(in) :: p_born, p_real integer, intent(in) :: i_phs logical, intent(in), optional :: cms logical :: yorn yorn = .false.; if (present (cms)) yorn = cms associate (kinematics => pcm_work%real_kinematics) if (yorn) then if (.not. kinematics%p_born_cms%initialized) & call kinematics%p_born_cms%init (size (p_born), 1) if (.not. kinematics%p_real_cms%initialized) & call kinematics%p_real_cms%init (size (p_real), 1) kinematics%p_born_cms%phs_point(1) = p_born kinematics%p_real_cms%phs_point(i_phs) = p_real else if (.not. kinematics%p_born_lab%initialized) & call kinematics%p_born_lab%init (size (p_born), 1) if (.not. kinematics%p_real_lab%initialized) & call kinematics%p_real_lab%init (size (p_real), 1) kinematics%p_born_lab%phs_point(1) = p_born kinematics%p_real_lab%phs_point(i_phs) = p_real end if end associate end subroutine pcm_nlo_workspace_set_momenta @ %def pcm_nlo_workspace_set_momenta @ <>= procedure :: get_momenta => pcm_nlo_workspace_get_momenta <>= function pcm_nlo_workspace_get_momenta (pcm_work, pcm, & i_phs, born_phsp, cms) result (p) type(vector4_t), dimension(:), allocatable :: p class(pcm_nlo_workspace_t), intent(in) :: pcm_work class(pcm_t), intent(in) :: pcm integer, intent(in) :: i_phs logical, intent(in) :: born_phsp logical, intent(in), optional :: cms logical :: yorn yorn = .false.; if (present (cms)) yorn = cms select type (pcm) type is (pcm_nlo_t) if (born_phsp) then if (yorn) then p = pcm_work%real_kinematics%p_born_cms%phs_point(1) else p =pcm_work%real_kinematics%p_born_lab%phs_point(1) end if else if (yorn) then p = pcm_work%real_kinematics%p_real_cms%phs_point(i_phs) else p = pcm_work%real_kinematics%p_real_lab%phs_point(i_phs) end if end if end select end function pcm_nlo_workspace_get_momenta @ %def pcm_nlo_workspace_get_momenta @ <>= procedure :: get_xi_max => pcm_nlo_workspace_get_xi_max <>= function pcm_nlo_workspace_get_xi_max (pcm_work, alr) result (xi_max) real(default) :: xi_max class(pcm_nlo_workspace_t), intent(in) :: pcm_work integer, intent(in) :: alr integer :: i_phs i_phs = pcm_work%real_kinematics%alr_to_i_phs (alr) xi_max = pcm_work%real_kinematics%xi_max (i_phs) end function pcm_nlo_workspace_get_xi_max @ %def pcm_nlo_workspace_get_xi_max @ <>= procedure :: set_x_rad => pcm_nlo_workspace_set_x_rad <>= subroutine pcm_nlo_workspace_set_x_rad (pcm_work, x_tot) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work real(default), intent(in), dimension(:) :: x_tot integer :: n_par n_par = size (x_tot) if (n_par < 3) then pcm_work%real_kinematics%x_rad = zero else pcm_work%real_kinematics%x_rad = x_tot (n_par - 2 : n_par) end if end subroutine pcm_nlo_workspace_set_x_rad @ %def pcm_nlo_workspace_set_x_rad @ <>= procedure :: init_virtual => pcm_nlo_workspace_init_virtual <>= subroutine pcm_nlo_workspace_init_virtual (pcm_work, pcm, model) class(pcm_nlo_workspace_t), intent(inout), target :: pcm_work class(pcm_t), intent(in) :: pcm class(model_data_t), intent(in) :: model select type (pcm) type is (pcm_nlo_t) associate (region_data => pcm%region_data) call pcm_work%virtual%init (region_data%get_flv_states_born (), & region_data%n_in, pcm%settings, model, pcm%has_pdfs) end associate end select end subroutine pcm_nlo_workspace_init_virtual @ %def pcm_nlo_workspace_init_virtual @ <>= procedure :: disable_virtual_subtraction => pcm_nlo_workspace_disable_virtual_subtraction <>= subroutine pcm_nlo_workspace_disable_virtual_subtraction (pcm_work) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work end subroutine pcm_nlo_workspace_disable_virtual_subtraction @ %def pcm_nlo_workspace_disable_virtual_subtraction @ <>= procedure :: compute_sqme_virt => pcm_nlo_workspace_compute_sqme_virt <>= subroutine pcm_nlo_workspace_compute_sqme_virt (pcm_work, pcm, p, & alpha_coupling, separate_uborns, sqme_virt) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work class(pcm_t), intent(in) :: pcm type(vector4_t), intent(in), dimension(:) :: p real(default), dimension(2), intent(in) :: alpha_coupling logical, intent(in) :: separate_uborns real(default), dimension(:), allocatable, intent(inout) :: sqme_virt type(vector4_t), dimension(:), allocatable :: pp associate (virtual => pcm_work%virtual) allocate (pp (size (p))) if (virtual%settings%factorization_mode == FACTORIZATION_THRESHOLD) then pp = pcm_work%real_kinematics%p_born_onshell%get_momenta (1) else pp = p end if select type (pcm) type is (pcm_nlo_t) if (separate_uborns) then allocate (sqme_virt (pcm%get_n_flv_born ())) else allocate (sqme_virt (1)) end if sqme_virt = zero call virtual%evaluate (pcm%region_data, & alpha_coupling, pp, separate_uborns, sqme_virt) end select end associate end subroutine pcm_nlo_workspace_compute_sqme_virt @ %def pcm_nlo_workspace_compute_sqme_virt @ <>= procedure :: compute_sqme_mismatch => pcm_nlo_workspace_compute_sqme_mismatch <>= subroutine pcm_nlo_workspace_compute_sqme_mismatch (pcm_work, pcm, & alpha_s, separate_uborns, sqme_mism) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work class(pcm_t), intent(in) :: pcm real(default), intent(in) :: alpha_s logical, intent(in) :: separate_uborns real(default), dimension(:), allocatable, intent(inout) :: sqme_mism select type (pcm) type is (pcm_nlo_t) if (separate_uborns) then allocate (sqme_mism (pcm%get_n_flv_born ())) else allocate (sqme_mism (1)) end if sqme_mism = zero sqme_mism = pcm_work%soft_mismatch%evaluate (alpha_s) end select end subroutine pcm_nlo_workspace_compute_sqme_mismatch @ %def pcm_nlo_workspace_compute_sqme_mismatch @ <>= procedure :: compute_sqme_dglap_remnant => pcm_nlo_workspace_compute_sqme_dglap_remnant <>= subroutine pcm_nlo_workspace_compute_sqme_dglap_remnant (pcm_work, pcm, & alpha_coupling, separate_uborns, sqme_dglap) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work class(pcm_t), intent(in) :: pcm real(default), dimension(2), intent(in) :: alpha_coupling logical, intent(in) :: separate_uborns real(default), dimension(:), allocatable, intent(inout) :: sqme_dglap select type (pcm) type is (pcm_nlo_t) if (separate_uborns) then allocate (sqme_dglap (pcm%get_n_flv_born ())) else allocate (sqme_dglap (1)) end if end select sqme_dglap = zero call pcm_work%dglap_remnant%evaluate (alpha_coupling, separate_uborns, sqme_dglap) end subroutine pcm_nlo_workspace_compute_sqme_dglap_remnant @ %def pcm_nlo_workspace_compute_sqme_dglap_remnant @ <>= procedure :: set_fixed_order_event_mode => pcm_nlo_workspace_set_fixed_order_event_mode <>= subroutine pcm_nlo_workspace_set_fixed_order_event_mode (pcm_work) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work pcm_work%real_sub%purpose = FIXED_ORDER_EVENTS end subroutine pcm_nlo_workspace_set_fixed_order_event_mode <>= procedure :: set_powheg_mode => pcm_nlo_workspace_set_powheg_mode <>= subroutine pcm_nlo_workspace_set_powheg_mode (pcm_work) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work pcm_work%real_sub%purpose = POWHEG end subroutine pcm_nlo_workspace_set_powheg_mode @ %def pcm_nlo_workspace_set_fixed_order_event_mode @ %def pcm_nlo_workspace_set_powheg_mode @ <>= procedure :: init_soft_mismatch => pcm_nlo_workspace_init_soft_mismatch <>= subroutine pcm_nlo_workspace_init_soft_mismatch (pcm_work, pcm) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work class(pcm_t), intent(in) :: pcm select type (pcm) type is (pcm_nlo_t) call pcm_work%soft_mismatch%init (pcm%region_data, & pcm_work%real_kinematics, pcm%settings%factorization_mode) end select end subroutine pcm_nlo_workspace_init_soft_mismatch @ %def pcm_nlo_workspace_init_soft_mismatch @ <>= procedure :: init_dglap_remnant => pcm_nlo_workspace_init_dglap_remnant <>= subroutine pcm_nlo_workspace_init_dglap_remnant (pcm_work, pcm) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work class(pcm_t), intent(in) :: pcm select type (pcm) type is (pcm_nlo_t) call pcm_work%dglap_remnant%init ( & pcm%settings, & pcm%region_data, & pcm_work%isr_kinematics) end select end subroutine pcm_nlo_workspace_init_dglap_remnant @ %def pcm_nlo_workspace_init_dglap_remnant @ <>= procedure :: is_fixed_order_nlo_events & => pcm_nlo_workspace_is_fixed_order_nlo_events <>= function pcm_nlo_workspace_is_fixed_order_nlo_events (pcm_work) result (is_fnlo) logical :: is_fnlo class(pcm_nlo_workspace_t), intent(in) :: pcm_work is_fnlo = pcm_work%real_sub%purpose == FIXED_ORDER_EVENTS end function pcm_nlo_workspace_is_fixed_order_nlo_events @ %def pcm_nlo_workspace_is_fixed_order_nlo_events @ <>= procedure :: final => pcm_nlo_workspace_final <>= subroutine pcm_nlo_workspace_final (pcm_work) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work call pcm_work%real_sub%final () call pcm_work%virtual%final () call pcm_work%soft_mismatch%final () call pcm_work%dglap_remnant%final () if (associated (pcm_work%real_kinematics)) then call pcm_work%real_kinematics%final () nullify (pcm_work%real_kinematics) end if if (associated (pcm_work%isr_kinematics)) then nullify (pcm_work%isr_kinematics) end if end subroutine pcm_nlo_workspace_final @ %def pcm_nlo_workspace_final @ <>= procedure :: is_nlo => pcm_nlo_workspace_is_nlo <>= function pcm_nlo_workspace_is_nlo (pcm_work) result (is_nlo) logical :: is_nlo class(pcm_nlo_workspace_t), intent(inout) :: pcm_work is_nlo = .true. end function pcm_nlo_workspace_is_nlo @ %def pcm_nlo_workspace_is_nlo @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Kinematics instance} In this data type we combine all objects (instances) necessary for generating (or recovering) a kinematical configuration. The components work together as an implementation of multi-channel phase space. [[sf_chain]] is an instance of the structure-function chain. It is used both for generating kinematics and, after the proper scale has been determined, evaluating the structure function entries. [[phs]] is an instance of the phase space for the elementary process. The array [[f]] contains the products of the Jacobians that originate from parameter mappings in the structure-function chain or in the phase space. We allocate this explicitly if either [[sf_chain]] or [[phs]] are explicitly allocated, otherwise we can take over a pointer. All components are implemented as pointers to (anonymous) targets. For each component, there is a flag that tells whether this component is to be regarded as a proper component (`owned' by the object) or as a pointer. @ <<[[kinematics.f90]]>>= <> module kinematics <> <> use format_utils, only: write_separator use diagnostics use io_units use lorentz use phs_points, only: assignment(=), size use physics_defs use sf_base use phs_base use interactions use mci_base use phs_fks use fks_regions use process_config use process_mci use pcm_base, only: pcm_t, pcm_workspace_t use pcm, only: pcm_nlo_t, pcm_nlo_workspace_t use ttv_formfactors, only: m1s_to_mpole <> <> <> contains <> end module kinematics @ %def kinematics <>= public :: kinematics_t <>= type :: kinematics_t integer :: n_in = 0 integer :: n_channel = 0 integer :: selected_channel = 0 type(sf_chain_instance_t), pointer :: sf_chain => null () class(phs_t), pointer :: phs => null () real(default), dimension(:), pointer :: f => null () real(default) :: phs_factor logical :: sf_chain_allocated = .false. logical :: phs_allocated = .false. logical :: f_allocated = .false. integer :: emitter = -1 integer :: i_phs = 0 integer :: i_con = 0 logical :: only_cm_frame = .false. logical :: new_seed = .true. logical :: threshold = .false. contains <> end type kinematics_t @ %def kinematics_t @ Output. Show only those components which are marked as owned. <>= procedure :: write => kinematics_write <>= subroutine kinematics_write (object, unit) class(kinematics_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, c u = given_output_unit (unit) if (object%f_allocated) then write (u, "(1x,A)") "Flux * PHS volume:" write (u, "(2x,ES19.12)") object%phs_factor write (u, "(1x,A)") "Jacobian factors per channel:" do c = 1, size (object%f) write (u, "(3x,I0,':',1x,ES14.7)", advance="no") c, object%f(c) if (c == object%selected_channel) then write (u, "(1x,A)") "[selected]" else write (u, *) end if end do end if if (object%sf_chain_allocated) then call write_separator (u) call object%sf_chain%write (u) end if if (object%phs_allocated) then call write_separator (u) call object%phs%write (u) end if end subroutine kinematics_write @ %def kinematics_write @ Finalizer. Delete only those components which are marked as owned. <>= procedure :: final => kinematics_final <>= subroutine kinematics_final (object) class(kinematics_t), intent(inout) :: object if (object%sf_chain_allocated) then call object%sf_chain%final () deallocate (object%sf_chain) object%sf_chain_allocated = .false. end if if (object%phs_allocated) then call object%phs%final () deallocate (object%phs) object%phs_allocated = .false. end if if (object%f_allocated) then deallocate (object%f) object%f_allocated = .false. end if end subroutine kinematics_final @ %def kinematics_final @ Configure the kinematics object. This consists of several configuration steps which correspond to individual procedures. In essence, we configure the structure-function part, the partonic phase-space part, and various NLO items. TODO wk 19-03-01: This includes some region-data setup within [[pcm]], hence [[pcm]] is intent(inout). This should be moved elsewhere, so [[pcm]] can become strictly intent(in). <>= procedure :: configure => kinematics_configure <>= subroutine kinematics_configure (kin, pcm, pcm_work, & sf_chain, beam_config, phs_config, nlo_type, is_i_sub) class(kinematics_t), intent(out) :: kin class(pcm_t), intent(inout) :: pcm class(pcm_workspace_t), intent(in) :: pcm_work type(sf_chain_t), intent(in), target :: sf_chain type(process_beam_config_t), intent(in), target :: beam_config class(phs_config_t), intent(in), target :: phs_config integer, intent(in) :: nlo_type logical, intent(in) :: is_i_sub logical :: extended_sf extended_sf = nlo_type == NLO_DGLAP .or. (nlo_type == NLO_REAL .and. is_i_sub) call kin%init_sf_chain (sf_chain, beam_config, & extended_sf = pcm%has_pdfs .and. extended_sf) !!! Add one for additional Born matrix element call kin%init_phs (phs_config) call kin%set_nlo_info (nlo_type) select type (phs => kin%phs) type is (phs_fks_t) call phs%allocate_momenta (phs_config, .not. (nlo_type == NLO_REAL)) select type (pcm) type is (pcm_nlo_t) call pcm%region_data%init_phs_identifiers (phs%phs_identifiers) !!! The triple select type pyramid of doom select type (pcm_work) type is (pcm_nlo_workspace_t) if (allocated (pcm_work%real_kinematics%alr_to_i_phs)) & call pcm%region_data%set_alr_to_i_phs (phs%phs_identifiers, & pcm_work%real_kinematics%alr_to_i_phs) end select end select end select end subroutine kinematics_configure @ %def kinematics_configure @ Set the flags indicating whether the phase space shall be set up for the calculation of the real contribution. For this case, also set the emitter. <>= procedure :: set_nlo_info => kinematics_set_nlo_info <>= subroutine kinematics_set_nlo_info (k, nlo_type) class(kinematics_t), intent(inout) :: k integer, intent(in) :: nlo_type if (nlo_type == NLO_VIRTUAL) k%only_cm_frame = .true. end subroutine kinematics_set_nlo_info @ %def kinematics_set_nlo_info @ <>= procedure :: set_threshold => kinematics_set_threshold <>= subroutine kinematics_set_threshold (kin, factorization_mode) class(kinematics_t), intent(inout) :: kin integer, intent(in) :: factorization_mode kin%threshold = factorization_mode == FACTORIZATION_THRESHOLD end subroutine kinematics_set_threshold @ %def kinematics_set_threshold @ Allocate the structure-function chain instance, initialize it as a copy of the [[sf_chain]] template, and prepare it for evaluation. The [[sf_chain]] remains a target because the (usually constant) beam momenta are taken from there. <>= procedure :: init_sf_chain => kinematics_init_sf_chain <>= subroutine kinematics_init_sf_chain (k, sf_chain, config, extended_sf) class(kinematics_t), intent(inout) :: k type(sf_chain_t), intent(in), target :: sf_chain type(process_beam_config_t), intent(in) :: config logical, intent(in), optional :: extended_sf integer :: n_strfun, n_channel integer :: c k%n_in = config%data%get_n_in () n_strfun = config%n_strfun n_channel = config%n_channel allocate (k%sf_chain) k%sf_chain_allocated = .true. call k%sf_chain%init (sf_chain, n_channel) if (n_strfun /= 0) then do c = 1, n_channel call k%sf_chain%set_channel (c, config%sf_channel(c)) end do end if call k%sf_chain%link_interactions () call k%sf_chain%exchange_mask () call k%sf_chain%init_evaluators (extended_sf = extended_sf) end subroutine kinematics_init_sf_chain @ %def kinematics_init_sf_chain @ Allocate and initialize the phase-space part and the array of Jacobian factors. <>= procedure :: init_phs => kinematics_init_phs <>= subroutine kinematics_init_phs (k, config) class(kinematics_t), intent(inout) :: k class(phs_config_t), intent(in), target :: config k%n_channel = config%get_n_channel () call config%allocate_instance (k%phs) call k%phs%init (config) k%phs_allocated = .true. allocate (k%f (k%n_channel)) k%f = 0 k%f_allocated = .true. end subroutine kinematics_init_phs @ %def kinematics_init_phs @ <>= procedure :: evaluate_radiation_kinematics => kinematics_evaluate_radiation_kinematics <>= subroutine kinematics_evaluate_radiation_kinematics (k, r_in) class(kinematics_t), intent(inout) :: k real(default), intent(in), dimension(:) :: r_in select type (phs => k%phs) type is (phs_fks_t) if (phs%mode == PHS_MODE_ADDITIONAL_PARTICLE) then call phs%generate_radiation_variables & (r_in(phs%n_r_born + 1 : phs%n_r_born + 3), threshold = k%threshold) call phs%compute_cms_energy () end if end select end subroutine kinematics_evaluate_radiation_kinematics @ %def kinematics_evaluate_radiation_kinematics @ <>= procedure :: generate_fsr_in => kinematics_generate_fsr_in <>= subroutine kinematics_generate_fsr_in (kin) class(kinematics_t), intent(inout) :: kin select type (phs => kin%phs) type is (phs_fks_t) call phs%generate_fsr_in () end select end subroutine kinematics_generate_fsr_in @ %def kinematics_generate_fsr_in @ <>= procedure :: compute_xi_ref_momenta => kinematics_compute_xi_ref_momenta <>= subroutine kinematics_compute_xi_ref_momenta (k, reg_data, nlo_type) class(kinematics_t), intent(inout) :: k type(region_data_t), intent(in) :: reg_data integer, intent(in) :: nlo_type logical :: use_contributors use_contributors = allocated (reg_data%alr_contributors) select type (phs => k%phs) type is (phs_fks_t) if (use_contributors) then call phs%compute_xi_ref_momenta (contributors = reg_data%alr_contributors) else if (k%threshold) then if (.not. is_subtraction_component (k%emitter, nlo_type)) & call phs%compute_xi_ref_momenta_threshold () else call phs%compute_xi_ref_momenta () end if end select end subroutine kinematics_compute_xi_ref_momenta @ %def kinematics_compute_xi_ref_momenta @ Generate kinematics, given a phase-space channel and a MC parameter set. The main result is the momentum array [[p]], but we also fill the momentum entries in the structure-function chain and the Jacobian-factor array [[f]]. Regarding phase space, we fill only the parameter arrays for the selected channel. <>= procedure :: compute_selected_channel => kinematics_compute_selected_channel <>= subroutine kinematics_compute_selected_channel & (k, mci_work, phs_channel, p, success) class(kinematics_t), intent(inout) :: k type(mci_work_t), intent(in) :: mci_work integer, intent(in) :: phs_channel type(vector4_t), dimension(:), intent(out) :: p logical, intent(out) :: success integer :: sf_channel k%selected_channel = phs_channel sf_channel = k%phs%config%get_sf_channel (phs_channel) call k%sf_chain%compute_kinematics (sf_channel, mci_work%get_x_strfun ()) call k%sf_chain%get_out_momenta (p(1:k%n_in)) call k%phs%set_incoming_momenta (p(1:k%n_in)) call k%phs%compute_flux () call k%phs%select_channel (phs_channel) call k%phs%evaluate_selected_channel (phs_channel, & mci_work%get_x_process ()) select type (phs => k%phs) type is (phs_fks_t) if (debug_on) call msg_debug2 (D_REAL, "phase space is phs_FKS") if (phs%q_defined) then call phs%get_born_momenta (p) if (debug_on) then call msg_debug2 (D_REAL, "q is defined") call msg_debug2 (D_REAL, "get_born_momenta called") end if k%phs_factor = phs%get_overall_factor () success = .true. else k%phs_factor = 0 success = .false. end if class default if (phs%q_defined) then call k%phs%get_outgoing_momenta (p(k%n_in + 1 :)) k%phs_factor = k%phs%get_overall_factor () success = .true. else k%phs_factor = 0 success = .false. end if end select end subroutine kinematics_compute_selected_channel @ %def kinematics_compute_selected_channel @ <>= procedure :: redo_sf_chain => kinematics_redo_sf_chain <>= subroutine kinematics_redo_sf_chain (kin, mci_work, phs_channel) class(kinematics_t), intent(inout) :: kin type(mci_work_t), intent(in) :: mci_work integer, intent(in) :: phs_channel real(default), dimension(:), allocatable :: x integer :: sf_channel, n real(default) :: xi, y n = size (mci_work%get_x_strfun ()) if (n > 0) then allocate (x(n)) x = mci_work%get_x_strfun () sf_channel = kin%phs%config%get_sf_channel (phs_channel) call kin%sf_chain%compute_kinematics (sf_channel, x) end if end subroutine kinematics_redo_sf_chain @ %def kinematics_redo_sf_chain @ Complete kinematics by filling the non-selected phase-space parameter arrays. <>= procedure :: compute_other_channels => kinematics_compute_other_channels <>= subroutine kinematics_compute_other_channels (k, mci_work, phs_channel) class(kinematics_t), intent(inout) :: k type(mci_work_t), intent(in) :: mci_work integer, intent(in) :: phs_channel integer :: c, c_sf call k%phs%evaluate_other_channels (phs_channel) do c = 1, k%n_channel c_sf = k%phs%config%get_sf_channel (c) k%f(c) = k%sf_chain%get_f (c_sf) * k%phs%get_f (c) end do end subroutine kinematics_compute_other_channels @ %def kinematics_compute_other_channels @ Just fetch the outgoing momenta of the [[sf_chain]] subobject, which become the incoming (seed) momenta of the hard interaction. This is a stripped down-version of the above which we use when recovering kinematics. Momenta are known, but no MC parameters yet. (We do not use the [[get_out_momenta]] method of the chain, since this relies on the structure-function interactions, which are not necessary filled here. We do rely on the momenta of the last evaluator in the chain, however.) <>= procedure :: get_incoming_momenta => kinematics_get_incoming_momenta <>= subroutine kinematics_get_incoming_momenta (k, p) class(kinematics_t), intent(in) :: k type(vector4_t), dimension(:), intent(out) :: p type(interaction_t), pointer :: int integer :: i int => k%sf_chain%get_out_int_ptr () do i = 1, k%n_in p(i) = int%get_momentum (k%sf_chain%get_out_i (i)) end do end subroutine kinematics_get_incoming_momenta @ %def kinematics_get_incoming_momenta @ <>= procedure :: get_boost_to_lab => kinematics_get_boost_to_lab <>= function kinematics_get_boost_to_lab (kin) result (lt) type(lorentz_transformation_t) :: lt class(kinematics_t), intent(in) :: kin lt = kin%phs%get_lorentz_transformation () end function kinematics_get_boost_to_lab @ %def kinematics_get_boost_to_lab @ <>= procedure :: get_boost_to_cms => kinematics_get_boost_to_cms <>= function kinematics_get_boost_to_cms (kin) result (lt) type(lorentz_transformation_t) :: lt class(kinematics_t), intent(in) :: kin lt = inverse (kin%phs%get_lorentz_transformation ()) end function kinematics_get_boost_to_cms @ %def kinematics_get_boost_to_cms @ This inverts the remainder of the above [[compute]] method. We know the momenta and recover the rest, as far as needed. If we select a channel, we can complete the inversion and reconstruct the MC parameter set. <>= procedure :: recover_mcpar => kinematics_recover_mcpar <>= subroutine kinematics_recover_mcpar (k, mci_work, phs_channel, p) class(kinematics_t), intent(inout) :: k type(mci_work_t), intent(inout) :: mci_work integer, intent(in) :: phs_channel type(vector4_t), dimension(:), intent(in) :: p integer :: c, c_sf real(default), dimension(:), allocatable :: x_sf, x_phs c = phs_channel c_sf = k%phs%config%get_sf_channel (c) k%selected_channel = c call k%sf_chain%recover_kinematics (c_sf) call k%phs%set_incoming_momenta (p(1:k%n_in)) call k%phs%compute_flux () call k%phs%set_outgoing_momenta (p(k%n_in+1:)) call k%phs%inverse () do c = 1, k%n_channel c_sf = k%phs%config%get_sf_channel (c) k%f(c) = k%sf_chain%get_f (c_sf) * k%phs%get_f (c) end do k%phs_factor = k%phs%get_overall_factor () c = phs_channel c_sf = k%phs%config%get_sf_channel (c) allocate (x_sf (k%sf_chain%config%get_n_bound ())) allocate (x_phs (k%phs%config%get_n_par ())) call k%phs%select_channel (c) call k%sf_chain%get_mcpar (c_sf, x_sf) call k%phs%get_mcpar (c, x_phs) call mci_work%set_x_strfun (x_sf) call mci_work%set_x_process (x_phs) end subroutine kinematics_recover_mcpar @ %def kinematics_recover_mcpar @ This first part of [[recover_mcpar]]: just handle the sfchain. <>= procedure :: recover_sfchain => kinematics_recover_sfchain <>= subroutine kinematics_recover_sfchain (k, channel, p) class(kinematics_t), intent(inout) :: k integer, intent(in) :: channel type(vector4_t), dimension(:), intent(in) :: p k%selected_channel = channel call k%sf_chain%recover_kinematics (channel) end subroutine kinematics_recover_sfchain @ %def kinematics_recover_sfchain @ Retrieve the MC input parameter array for a specific channel. We assume that the kinematics is complete, so this is known for all channels. <>= procedure :: get_mcpar => kinematics_get_mcpar <>= subroutine kinematics_get_mcpar (k, phs_channel, r) class(kinematics_t), intent(in) :: k integer, intent(in) :: phs_channel real(default), dimension(:), intent(out) :: r integer :: sf_channel, n_par_sf, n_par_phs sf_channel = k%phs%config%get_sf_channel (phs_channel) n_par_phs = k%phs%config%get_n_par () n_par_sf = k%sf_chain%config%get_n_bound () if (n_par_sf > 0) then call k%sf_chain%get_mcpar (sf_channel, r(1:n_par_sf)) end if if (n_par_phs > 0) then call k%phs%get_mcpar (phs_channel, r(n_par_sf+1:)) end if end subroutine kinematics_get_mcpar @ %def kinematics_get_mcpar @ Evaluate the structure function chain, assuming that kinematics is known. The status must be precisely [[SF_DONE_KINEMATICS]]. We thus avoid evaluating the chain twice via different pointers to the same target. <>= procedure :: evaluate_sf_chain => kinematics_evaluate_sf_chain <>= subroutine kinematics_evaluate_sf_chain (k, fac_scale, negative_sf, sf_rescale) class(kinematics_t), intent(inout) :: k real(default), intent(in) :: fac_scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(inout), optional :: sf_rescale select case (k%sf_chain%get_status ()) case (SF_DONE_KINEMATICS) call k%sf_chain%evaluate (fac_scale, negative_sf = negative_sf, sf_rescale = sf_rescale) end select end subroutine kinematics_evaluate_sf_chain @ %def kinematics_evaluate_sf_chain @ Recover beam momenta, i.e., return the beam momenta stored in the current [[sf_chain]] to their source. This is a side effect. <>= procedure :: return_beam_momenta => kinematics_return_beam_momenta <>= subroutine kinematics_return_beam_momenta (k) class(kinematics_t), intent(in) :: k call k%sf_chain%return_beam_momenta () end subroutine kinematics_return_beam_momenta @ %def kinematics_return_beam_momenta @ Check wether the phase space is configured in the center-of-mass frame. Relevant for using the proper momenta input for BLHA matrix elements. <>= procedure :: lab_is_cm => kinematics_lab_is_cm <>= function kinematics_lab_is_cm (k) result (lab_is_cm) logical :: lab_is_cm class(kinematics_t), intent(in) :: k lab_is_cm = k%phs%config%lab_is_cm end function kinematics_lab_is_cm @ %def kinematics_lab_is_cm @ <>= procedure :: modify_momenta_for_subtraction => kinematics_modify_momenta_for_subtraction <>= subroutine kinematics_modify_momenta_for_subtraction (k, p_in, p_out) class(kinematics_t), intent(inout) :: k type(vector4_t), intent(in), dimension(:) :: p_in type(vector4_t), intent(out), dimension(:), allocatable :: p_out allocate (p_out (size (p_in))) if (k%threshold) then select type (phs => k%phs) type is (phs_fks_t) p_out = phs%get_onshell_projected_momenta () end select else p_out = p_in end if end subroutine kinematics_modify_momenta_for_subtraction @ %def kinematics_modify_momenta_for_subtraction @ <>= procedure :: threshold_projection => kinematics_threshold_projection <>= subroutine kinematics_threshold_projection (k, pcm_work, nlo_type) class(kinematics_t), intent(inout) :: k type(pcm_nlo_workspace_t), intent(inout) :: pcm_work integer, intent(in) :: nlo_type real(default) :: sqrts, mtop type(lorentz_transformation_t) :: L_to_cms type(vector4_t), dimension(:), allocatable :: p_tot, p_onshell integer :: n_tot n_tot = k%phs%get_n_tot () allocate (p_tot (size (pcm_work%real_kinematics%p_born_cms%phs_point(1)))) select type (phs => k%phs) type is (phs_fks_t) p_tot = pcm_work%real_kinematics%p_born_cms%phs_point(1) class default p_tot(1 : k%n_in) = phs%p p_tot(k%n_in + 1 : n_tot) = phs%q end select sqrts = sum (p_tot (1:k%n_in))**1 mtop = m1s_to_mpole (sqrts) L_to_cms = get_boost_for_threshold_projection (p_tot, sqrts, mtop) call pcm_work%real_kinematics%p_born_cms%set_momenta (1, p_tot) p_onshell = pcm_work%real_kinematics%p_born_onshell%phs_point(1) call threshold_projection_born (mtop, L_to_cms, p_tot, p_onshell) pcm_work%real_kinematics%p_born_onshell%phs_point(1) = p_onshell if (debug2_active (D_THRESHOLD)) then print *, 'On-shell projected Born: ' call vector4_write_set (p_onshell) end if end subroutine kinematics_threshold_projection @ %def kinematics_threshold_projection @ <>= procedure :: evaluate_radiation => kinematics_evaluate_radiation <>= subroutine kinematics_evaluate_radiation (k, p_in, p_out, success) class(kinematics_t), intent(inout) :: k type(vector4_t), intent(in), dimension(:) :: p_in type(vector4_t), intent(out), dimension(:), allocatable :: p_out logical, intent(out) :: success type(vector4_t), dimension(:), allocatable :: p_real type(vector4_t), dimension(:), allocatable :: p_born real(default) :: xi_max_offshell, xi_offshell, y_offshell, jac_rand_dummy, phi select type (phs => k%phs) type is (phs_fks_t) allocate (p_born (size (p_in))) if (k%threshold) then p_born = phs%get_onshell_projected_momenta () else p_born = p_in end if if (.not. k%phs%lab_is_cm () .and. .not. k%threshold) then p_born = inverse (k%phs%lt_cm_to_lab) * p_born end if call phs%compute_xi_max (p_born, k%threshold) if (k%emitter >= 0) then allocate (p_real (size (p_born) + 1)) allocate (p_out (size (p_born) + 1)) if (k%emitter <= k%n_in) then call phs%generate_isr (k%i_phs, p_real) else if (k%threshold) then jac_rand_dummy = 1._default call compute_y_from_emitter (phs%generator%real_kinematics%x_rad (I_Y), & phs%generator%real_kinematics%p_born_cms%get_momenta(1), & k%n_in, k%emitter, .false., phs%generator%y_max, jac_rand_dummy, & y_offshell) call phs%compute_xi_max (k%emitter, k%i_phs, y_offshell, & phs%generator%real_kinematics%p_born_cms%get_momenta(1), & xi_max_offshell) xi_offshell = xi_max_offshell * phs%generator%real_kinematics%xi_tilde phi = phs%generator%real_kinematics%phi call phs%generate_fsr (k%emitter, k%i_phs, p_real, & xi_y_phi = [xi_offshell, y_offshell, phi], no_jacobians = .true.) call phs%generator%real_kinematics%p_real_cms%set_momenta (k%i_phs, p_real) call phs%generate_fsr_threshold (k%emitter, k%i_phs, p_real) if (debug2_active (D_SUBTRACTION)) & call generate_fsr_threshold_for_other_emitters (k%emitter, k%i_phs) else if (k%i_con > 0) then call phs%generate_fsr (k%emitter, k%i_phs, p_real, k%i_con) else call phs%generate_fsr (k%emitter, k%i_phs, p_real) end if end if success = check_scalar_products (p_real) if (debug2_active (D_SUBTRACTION)) then call msg_debug2 (D_SUBTRACTION, "Real phase-space: ") call vector4_write_set (p_real) end if p_out = p_real else allocate (p_out (size (p_in))); p_out = p_in success = .true. end if end select contains subroutine generate_fsr_threshold_for_other_emitters (emitter, i_phs) integer, intent(in) :: emitter, i_phs integer :: ii_phs, this_emitter select type (phs => k%phs) type is (phs_fks_t) do ii_phs = 1, size (phs%phs_identifiers) this_emitter = phs%phs_identifiers(ii_phs)%emitter if (ii_phs /= i_phs .and. this_emitter /= emitter) & call phs%generate_fsr_threshold (this_emitter, i_phs) end do end select end subroutine end subroutine kinematics_evaluate_radiation @ %def kinematics_evaluate_radiation @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Instances} <<[[instances.f90]]>>= <> module instances <> <> <> use io_units use format_utils, only: write_separator use constants use diagnostics use os_interface use numeric_utils use lorentz use mci_base use particles use sm_qcd, only: qcd_t use interactions use quantum_numbers use model_data use helicities use flavors use beam_structures use variables use pdg_arrays, only: is_quark use sf_base use physics_defs use process_constants use process_libraries use state_matrices use integration_results use phs_base use prc_core, only: prc_core_t, prc_core_state_t !!! We should depend less on these modules (move it to pcm_nlo_t e.g.) use phs_wood, only: phs_wood_t use phs_fks use blha_olp_interfaces, only: prc_blha_t use blha_config, only: BLHA_AMP_COLOR_C use prc_external, only: prc_external_t, prc_external_state_t use prc_threshold, only: prc_threshold_t use blha_olp_interfaces, only: blha_result_array_size use prc_openloops, only: prc_openloops_t, openloops_state_t use prc_recola, only: prc_recola_t use blha_olp_interfaces, only: blha_color_c_fill_offdiag, blha_color_c_fill_diag use ttv_formfactors, only: m1s_to_mpole !!! local modules use parton_states use process_counter use pcm_base use pcm use process_config use process_mci use process use kinematics <> <> <> <> contains <> end module instances @ %def instances @ \subsection{Term instance} A [[term_instance_t]] object contains all data that describe a term. Each process component consists of one or more distinct terms which may differ in kinematics, but whose squared transition matrices have to be added pointwise. The [[active]] flag is set when this term is connected to an active process component. Inactive terms are skipped for kinematics and evaluation. The [[amp]] array stores the amplitude values when we get them from evaluating the associated matrix-element code. The [[int_hard]] interaction describes the elementary hard process. It receives the momenta and the amplitude entries for each sampling point. The [[isolated]] object holds the effective parton state for the elementary interaction. The amplitude entries are computed from [[int_hard]]. The [[connected]] evaluator set convolutes this scattering matrix with the beam (and possibly structure-function) density matrix. The [[checked]] flag is set once we have applied cuts on this term. The result of this is stored in the [[passed]] flag. Although each [[term_instance]] carries a [[weight]], this currently always keeps the value $1$ and is only used to be given to routines to fulfill their signature. <>= type :: term_instance_t type(process_term_t), pointer :: config => null () class(pcm_t), pointer :: pcm => null () class(pcm_workspace_t), pointer :: pcm_work => null () logical :: active = .false. complex(default), dimension(:), allocatable :: amp type(interaction_t) :: int_hard type(isolated_state_t) :: isolated type(connected_state_t) :: connected class(prc_core_state_t), allocatable :: core_state logical :: checked = .false. logical :: passed = .false. real(default) :: scale = 0 real(default), allocatable :: fac_scale real(default), allocatable :: ren_scale real(default), allocatable :: es_scale real(default), allocatable :: alpha_qcd_forced real(default) :: weight = 1 type(vector4_t), dimension(:), allocatable :: p_seed type(vector4_t), dimension(:), allocatable :: p_hard integer :: nlo_type = BORN integer, dimension(:), allocatable :: same_kinematics logical :: negative_sf = .false. contains <> end type term_instance_t @ %def term_instance_t @ <>= procedure :: write => term_instance_write <>= subroutine term_instance_write (term, unit, kin, show_eff_state, testflag) class(term_instance_t), intent(in) :: term integer, intent(in), optional :: unit type(kinematics_t), intent(in), optional :: kin logical, intent(in), optional :: show_eff_state logical, intent(in), optional :: testflag real(default) :: fac_scale, ren_scale integer :: u logical :: state u = given_output_unit (unit) state = .true.; if (present (show_eff_state)) state = show_eff_state if (term%active) then if (associated (term%config)) then write (u, "(1x,A,I0,A,I0,A)") "Term #", term%config%i_term, & " (component #", term%config%i_component, ")" else write (u, "(1x,A)") "Term [undefined]" end if else write (u, "(1x,A,I0,A)") "Term #", term%config%i_term, & " [inactive]" end if if (term%checked) then write (u, "(3x,A,L1)") "passed cuts = ", term%passed end if if (term%passed) then write (u, "(3x,A,ES19.12)") "overall scale = ", term%scale write (u, "(3x,A,ES19.12)") "factorization scale = ", term%get_fac_scale () write (u, "(3x,A,ES19.12)") "renormalization scale = ", term%get_ren_scale () if (allocated (term%alpha_qcd_forced)) then write (u, "(3x,A,ES19.12)") "alpha(QCD) forced = ", & term%alpha_qcd_forced end if write (u, "(3x,A,ES19.12)") "reweighting factor = ", term%weight end if !!! This used to be a member of term_instance if (present (kin)) then call kin%write (u) end if call write_separator (u) write (u, "(1x,A)") "Amplitude (transition matrix of the & &hard interaction):" call write_separator (u) call term%int_hard%basic_write (u, testflag = testflag) if (state .and. term%isolated%has_trace) then call write_separator (u) write (u, "(1x,A)") "Evaluators for the hard interaction:" call term%isolated%write (u, testflag = testflag) end if if (state .and. term%connected%has_trace) then call write_separator (u) write (u, "(1x,A)") "Evaluators for the connected process:" call term%connected%write (u, testflag = testflag) end if end subroutine term_instance_write @ %def term_instance_write @ The interactions and evaluators must be finalized. <>= procedure :: final => term_instance_final <>= subroutine term_instance_final (term) class(term_instance_t), intent(inout) :: term if (allocated (term%amp)) deallocate (term%amp) if (allocated (term%core_state)) deallocate (term%core_state) if (allocated (term%ren_scale)) deallocate (term%ren_scale) if (allocated (term%fac_scale)) deallocate (term%fac_scale) if (allocated (term%es_scale)) deallocate (term%es_scale) if (allocated (term%alpha_qcd_forced)) & deallocate (term%alpha_qcd_forced) if (allocated (term%p_seed)) deallocate(term%p_seed) if (allocated (term%p_hard)) deallocate (term%p_hard) call term%connected%final () call term%isolated%final () call term%int_hard%final () term%pcm => null () term%pcm_work => null () end subroutine term_instance_final @ %def term_instance_final @ For a new term object, we configure the structure-function interface, the phase space, the matrix-element (interaction) interface, etc. <>= procedure :: configure => term_instance_configure <>= subroutine term_instance_configure (term_instance, process, i, pcm_work, sf_chain, kin) class(term_instance_t), intent(out), target :: term_instance type(process_t), intent(in), target :: process integer, intent(in) :: i class(pcm_workspace_t), intent(in), target :: pcm_work type(sf_chain_t), intent(in), target :: sf_chain type(kinematics_t), intent(inout), target :: kin type(process_term_t) :: term integer :: i_component logical :: requires_extended_sf term = process%get_term_ptr (i) i_component = term%i_component if (i_component /= 0) then call term_instance%init & (process%get_pcm_ptr (), pcm_work, process%get_nlo_type_component (i_component)) requires_extended_sf = term_instance%nlo_type == NLO_DGLAP .or. & (term_instance%nlo_type == NLO_REAL .and. process%get_i_sub (i) == i) call term_instance%setup_dynamics (process, i, kin, & real_finite = process%component_is_real_finite (i_component)) select type (phs => kin%phs) type is (phs_fks_t) call term_instance%set_emitter (kin) call term_instance%setup_fks_kinematics (kin, & process%get_var_list_ptr (), & process%get_beam_config_ptr ()) end select select type (pcm => term_instance%pcm) type is (pcm_nlo_t) call kin%set_threshold (pcm%settings%factorization_mode) end select call term_instance%setup_expressions (process%get_meta (), process%get_config ()) end if end subroutine term_instance_configure @ %def term_instance_configure @ First part of term-instance configuration: initialize by assigning pointers to the overall [[pcm]] and the associated [[pcm_workspace]] objects. <>= procedure :: init => term_instance_init <>= subroutine term_instance_init (term_instance, pcm, pcm_work, nlo_type) class(term_instance_t), intent(out) :: term_instance class(pcm_t), intent(in), target :: pcm class(pcm_workspace_t), intent(in), target :: pcm_work integer, intent(in) :: nlo_type term_instance%pcm => pcm term_instance%pcm_work => pcm_work term_instance%nlo_type = nlo_type end subroutine term_instance_init @ %def term_instance_init @ The second part of term-instance configuration concerns dynamics, i.e., the interface to the matrix-element (interaction), and the parton-state objects that combine all kinematics and matrix-element data for evaluation. The hard interaction (incoming momenta) is linked to the structure function instance. In the isolated state, we either set pointers to both, or we create modified copies ([[rearrange]]) as effective structure-function chain and interaction, respectively. Finally, we set up the [[subevt]] component that will be used for evaluating observables, collecting particles from the trace evaluator in the effective connected state. Their quantum numbers must be determined by following back source links and set explicitly, since they are already eliminated in that trace. The [[rearrange]] parts are still commented out; they could become relevant for a NLO algorithm. <>= procedure :: setup_dynamics => term_instance_setup_dynamics <>= subroutine term_instance_setup_dynamics (term, process, i_term, kin, real_finite) class(term_instance_t), intent(inout), target :: term type(process_t), intent(in), target:: process integer, intent(in) :: i_term type(kinematics_t), intent(in) :: kin logical, intent(in), optional :: real_finite class(prc_core_t), pointer :: core => null () type(process_beam_config_t) :: beam_config type(interaction_t), pointer :: sf_chain_int type(interaction_t), pointer :: src_int type(quantum_numbers_mask_t), dimension(:), allocatable :: mask_in type(state_matrix_t), pointer :: state_matrix type(flavor_t), dimension(:), allocatable :: flv_int, flv_src, f_in, f_out integer, dimension(:,:), allocatable :: flv_born, flv_real type(flavor_t), dimension(:,:), allocatable :: flv_pdf type(quantum_numbers_t), dimension(:,:), allocatable :: qn_pdf integer :: n_in, n_vir, n_out, n_tot, n_sub integer :: n_flv_born, n_flv_real, n_flv_total integer :: i, j logical :: me_already_squared, keep_fs_flavors logical :: decrease_n_tot logical :: requires_extended_sf me_already_squared = .false. keep_fs_flavors = .false. term%config => process%get_term_ptr (i_term) term%int_hard = term%config%int core => process%get_core_term (i_term) term%negative_sf = process%get_negative_sf () call core%allocate_workspace (term%core_state) select type (core) class is (prc_external_t) call reduce_interaction (term%int_hard, & core%includes_polarization (), .true., .false.) me_already_squared = .true. allocate (term%amp (term%int_hard%get_n_matrix_elements ())) class default allocate (term%amp (term%config%n_allowed)) end select if (allocated (term%core_state)) then select type (core_state => term%core_state) type is (openloops_state_t) call core_state%init_threshold (process%get_model_ptr ()) end select end if term%amp = cmplx (0, 0, default) decrease_n_tot = term%nlo_type == NLO_REAL .and. & term%config%i_term_global /= term%config%i_sub if (present (real_finite)) then if (real_finite) decrease_n_tot = .false. end if if (decrease_n_tot) then allocate (term%p_seed (term%int_hard%get_n_tot () - 1)) else allocate (term%p_seed (term%int_hard%get_n_tot ())) end if allocate (term%p_hard (term%int_hard%get_n_tot ())) sf_chain_int => kin%sf_chain%get_out_int_ptr () n_in = term%int_hard%get_n_in () do j = 1, n_in i = kin%sf_chain%get_out_i (j) call term%int_hard%set_source_link (j, sf_chain_int, i) end do call term%isolated%init (kin%sf_chain, term%int_hard) allocate (mask_in (n_in)) mask_in = kin%sf_chain%get_out_mask () select type (phs => kin%phs) type is (phs_wood_t) if (me_already_squared) then call term%isolated%setup_identity_trace & (core, mask_in, .true., .false.) else call term%isolated%setup_square_trace & (core, mask_in, term%config%col, .false.) end if type is (phs_fks_t) select case (phs%mode) case (PHS_MODE_ADDITIONAL_PARTICLE) if (me_already_squared) then call term%isolated%setup_identity_trace & (core, mask_in, .true., .false.) else keep_fs_flavors = term%config%data%n_flv > 1 call term%isolated%setup_square_trace & (core, mask_in, term%config%col, & keep_fs_flavors) end if case (PHS_MODE_COLLINEAR_REMNANT) if (me_already_squared) then call term%isolated%setup_identity_trace & (core, mask_in, .true., .false.) else call term%isolated%setup_square_trace & (core, mask_in, term%config%col, .false.) end if end select class default call term%isolated%setup_square_trace & (core, mask_in, term%config%col, .false.) end select if (term%nlo_type == NLO_VIRTUAL .or. (term%nlo_type == NLO_REAL .and. & term%config%i_term_global == term%config%i_sub) .or. & term%nlo_type == NLO_MISMATCH) then n_sub = term%get_n_sub () else if (term%nlo_type == NLO_DGLAP) then n_sub = n_beams_rescaled + term%get_n_sub () else !!! No integration of real subtraction in interactions yet n_sub = 0 end if keep_fs_flavors = keep_fs_flavors .or. me_already_squared requires_extended_sf = term%nlo_type == NLO_DGLAP .or. & (term%is_subtraction () .and. process%pcm_contains_pdfs ()) call term%connected%setup_connected_trace (term%isolated, & undo_helicities = undo_helicities (core, me_already_squared), & keep_fs_flavors = keep_fs_flavors, & requires_extended_sf = requires_extended_sf) associate (int_eff => term%isolated%int_eff) state_matrix => int_eff%get_state_matrix_ptr () n_tot = int_eff%get_n_tot () flv_int = quantum_numbers_get_flavor & (state_matrix%get_quantum_number (1)) allocate (f_in (n_in)) f_in = flv_int(1:n_in) deallocate (flv_int) end associate n_in = term%connected%trace%get_n_in () n_vir = term%connected%trace%get_n_vir () n_out = term%connected%trace%get_n_out () allocate (f_out (n_out)) do j = 1, n_out call term%connected%trace%find_source & (n_in + n_vir + j, src_int, i) if (associated (src_int)) then state_matrix => src_int%get_state_matrix_ptr () flv_src = quantum_numbers_get_flavor & (state_matrix%get_quantum_number (1)) f_out(j) = flv_src(i) deallocate (flv_src) end if end do beam_config = process%get_beam_config () call term%connected%setup_subevt (term%isolated%sf_chain_eff, & beam_config%data%flv, f_in, f_out) call term%connected%setup_var_list & (process%get_var_list_ptr (), beam_config%data) ! Does connected%trace never have any helicity qn? call term%init_interaction_qn_index (core, term%connected%trace, n_sub, & process%get_model_ptr (), is_polarized = .false.) call term%init_interaction_qn_index (core, term%int_hard, n_sub, process%get_model_ptr ()) if (requires_extended_sf) then select type (pcm => term%pcm) type is (pcm_nlo_t) n_in = pcm%region_data%get_n_in () flv_born = pcm%region_data%get_flv_states_born () flv_real = pcm%region_data%get_flv_states_real () n_flv_born = pcm%region_data%get_n_flv_born () n_flv_real = pcm%region_data%get_n_flv_real () n_flv_total = n_flv_born + n_flv_real allocate (flv_pdf(n_in, n_flv_total), & qn_pdf(n_in, n_flv_total)) call flv_pdf(:, :n_flv_born)%init (flv_born(:n_in, :)) call flv_pdf(:, n_flv_born + 1:n_flv_total)%init (flv_real(:n_in, :)) call qn_pdf%init (flv_pdf) call sf_chain_int%init_qn_index (qn_pdf, n_flv_born, n_flv_real) end select end if contains function undo_helicities (core, me_squared) result (val) logical :: val class(prc_core_t), intent(in) :: core logical, intent(in) :: me_squared select type (core) class is (prc_external_t) val = me_squared .and. .not. core%includes_polarization () class default val = .false. end select end function undo_helicities subroutine reduce_interaction (int, polarized_beams, keep_fs_flavors, & keep_colors) type(interaction_t), intent(inout) :: int logical, intent(in) :: polarized_beams logical, intent(in) :: keep_fs_flavors, keep_colors type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask logical, dimension(:), allocatable :: mask_f, mask_c, mask_h integer :: n_tot, n_in n_in = int%get_n_in (); n_tot = int%get_n_tot () allocate (qn_mask (n_tot)) allocate (mask_f (n_tot), mask_c (n_tot), mask_h (n_tot)) mask_c = .not. keep_colors mask_f (1 : n_in) = .false. if (keep_fs_flavors) then mask_f (n_in + 1 : ) = .false. else mask_f (n_in + 1 : ) = .true. end if if (polarized_beams) then mask_h (1 : n_in) = .false. else mask_h (1 : n_in) = .true. end if mask_h (n_in + 1 : ) = .true. call qn_mask%init (mask_f, mask_c, mask_h) call int%reduce_state_matrix (qn_mask, keep_order = .true.) end subroutine reduce_interaction end subroutine term_instance_setup_dynamics @ %def term_instance_setup_dynamics @ Set up index mapping from state matrix to index pair [[i_flv]], [[i_sub]]. <>= public :: setup_interaction_qn_index <>= subroutine setup_interaction_qn_index (int, data, qn_config, n_sub, is_polarized) class(interaction_t), intent(inout) :: int class(process_constants_t), intent(in) :: data type(quantum_numbers_t), dimension(:, :), intent(in) :: qn_config integer, intent(in) :: n_sub logical, intent(in) :: is_polarized integer :: i type(quantum_numbers_t), dimension(:, :), allocatable :: qn_hel if (is_polarized) then call setup_interaction_qn_hel (int, data, qn_hel) call int%init_qn_index (qn_config, n_sub, qn_hel) call int%set_qn_index_helicity_flip (.true.) else call int%init_qn_index (qn_config, n_sub) end if end subroutine setup_interaction_qn_index @ %def setup_interaction_qn_index @ Set up beam polarisation quantum numbers, if beam polarisation is required. We retrieve the full helicity information from [[term%config%data]] and reduce the information only to the inital state. Afterwards, we uniquify the initial state polarization by a applying an index (hash) table. The helicity information is fed into an array of quantum numbers to assign flavor, helicity and subtraction indices correctly to their matrix element. <>= public :: setup_interaction_qn_hel <>= subroutine setup_interaction_qn_hel (int, data, qn_hel) class(interaction_t), intent(in) :: int class(process_constants_t), intent(in) :: data type(quantum_numbers_t), dimension(:, :), allocatable, intent(out) :: qn_hel type(helicity_t), dimension(:), allocatable :: hel integer, dimension(:), allocatable :: index_table integer, dimension(:, :), allocatable :: hel_state integer :: i, j, n_hel_unique associate (n_in => int%get_n_in (), n_tot => int%get_n_tot ()) allocate (hel_state (n_tot, data%get_n_hel ()), & source = data%hel_state) allocate (index_table (data%get_n_hel ()), & source = 0) forall (j=1:data%get_n_hel (), i=n_in+1:n_tot) hel_state(i, j) = 0 n_hel_unique = 0 HELICITY: do i = 1, data%get_n_hel () do j = 1, data%get_n_hel () if (index_table (j) == 0) then index_table(j) = i; n_hel_unique = n_hel_unique + 1 cycle HELICITY else if (all (hel_state(:, i) == & hel_state(:, index_table(j)))) then cycle HELICITY end if end do end do HELICITY allocate (qn_hel (n_tot, n_hel_unique)) allocate (hel (n_tot)) do j = 1, n_hel_unique call hel%init (hel_state(:, index_table(j))) call qn_hel(:, j)%init (hel) end do end associate end subroutine setup_interaction_qn_hel @ %def setup_interaction_qn_hel @ <>= procedure :: init_interaction_qn_index => term_instance_init_interaction_qn_index <>= subroutine term_instance_init_interaction_qn_index (term, core, int, n_sub, & model, is_polarized) class(term_instance_t), intent(inout), target :: term class(prc_core_t), intent(in) :: core class(interaction_t), intent(inout) :: int integer, intent(in) :: n_sub class(model_data_t), intent(in) :: model logical, intent(in), optional :: is_polarized logical :: polarized type(quantum_numbers_t), dimension(:, :), allocatable :: qn_config integer, dimension(:,:), allocatable :: flv_born type(flavor_t), dimension(:), allocatable :: flv integer :: i select type (core) class is (prc_external_t) if (present (is_polarized)) then polarized = is_polarized else polarized = core%includes_polarization () end if select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) associate (is_born => .not. (term%nlo_type == NLO_REAL .and. & .not. term%is_subtraction ())) select type (pcm => term%pcm) type is (pcm_nlo_t) qn_config = pcm%get_qn (is_born) end select call setup_interaction_qn_index (int, term%config%data, & qn_config, n_sub, polarized) end associate class default call term%config%data%get_flv_state (flv_born) allocate (flv (size (flv_born, dim = 1))) allocate (qn_config (size (flv_born, dim = 1), size (flv_born, dim = 2))) do i = 1, core%data%n_flv call flv%init (flv_born(:,i), model) call qn_config(:, i)%init (flv) end do call setup_interaction_qn_index (int, term%config%data, & qn_config, n_sub, polarized) end select class default call int%init_qn_index () end select end subroutine term_instance_init_interaction_qn_index @ %def term_instance_init_interaction_qn_index @ <>= procedure :: setup_fks_kinematics => term_instance_setup_fks_kinematics <>= subroutine term_instance_setup_fks_kinematics (term, kin, var_list, beam_config) class(term_instance_t), intent(inout), target :: term type(kinematics_t), intent(inout) :: kin type(var_list_t), intent(in) :: var_list type(process_beam_config_t), intent(in) :: beam_config integer :: mode logical :: singular_jacobian if (.not. (term%nlo_type == NLO_REAL .or. term%nlo_type == NLO_DGLAP .or. & term%nlo_type == NLO_MISMATCH)) return singular_jacobian = var_list%get_lval (var_str ("?powheg_use_singular_jacobian")) if (term%nlo_type == NLO_REAL) then mode = check_generator_mode (GEN_REAL_PHASE_SPACE) else if (term%nlo_type == NLO_MISMATCH) then mode = check_generator_mode (GEN_SOFT_MISMATCH) else mode = PHS_MODE_UNDEFINED end if select type (phs => kin%phs) type is (phs_fks_t) select type (pcm => term%pcm) type is (pcm_nlo_t) select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) call pcm%setup_phs_generator (pcm_work, & phs%generator, phs%config%sqrts, mode, singular_jacobian) if (beam_config%has_structure_function ()) then pcm_work%isr_kinematics%isr_mode = SQRTS_VAR else pcm_work%isr_kinematics%isr_mode = SQRTS_FIXED end if if (debug_on) call msg_debug (D_PHASESPACE, "isr_mode: ", pcm_work%isr_kinematics%isr_mode) end select end select class default call msg_fatal ("Phase space should be an FKS phase space!") end select contains function check_generator_mode (gen_mode_default) result (gen_mode) integer :: gen_mode integer, intent(in) :: gen_mode_default select type (pcm => term%pcm) type is (pcm_nlo_t) associate (settings => pcm%settings) if (settings%test_coll_limit .and. settings%test_anti_coll_limit) & call msg_fatal ("You cannot check the collinear and anti-collinear limit "& &"at the same time!") if (settings%test_soft_limit .and. .not. settings%test_coll_limit & .and. .not. settings%test_anti_coll_limit) then gen_mode = GEN_SOFT_LIMIT_TEST else if (.not. settings%test_soft_limit .and. settings%test_coll_limit) then gen_mode = GEN_COLL_LIMIT_TEST else if (.not. settings%test_soft_limit .and. settings%test_anti_coll_limit) then gen_mode = GEN_ANTI_COLL_LIMIT_TEST else if (settings%test_soft_limit .and. settings%test_coll_limit) then gen_mode = GEN_SOFT_COLL_LIMIT_TEST else if (settings%test_soft_limit .and. settings%test_anti_coll_limit) then gen_mode = GEN_SOFT_ANTI_COLL_LIMIT_TEST else gen_mode = gen_mode_default end if end associate end select end function check_generator_mode end subroutine term_instance_setup_fks_kinematics @ %def term_instance_setup_fks_kinematics @ Set up seed kinematics, starting from the MC parameter set given as argument. As a result, the [[k_seed]] kinematics object is evaluated (except for the structure-function matrix-element evaluation, which we postpone until we know the factorization scale), and we have a valid [[p_seed]] momentum array. <>= procedure :: compute_seed_kinematics => term_instance_compute_seed_kinematics <>= subroutine term_instance_compute_seed_kinematics & (term, kin, mci_work, phs_channel, success) class(term_instance_t), intent(inout), target :: term type(kinematics_t), intent(inout) :: kin type(mci_work_t), intent(in) :: mci_work integer, intent(in) :: phs_channel logical, intent(out) :: success call kin%compute_selected_channel & (mci_work, phs_channel, term%p_seed, success) end subroutine term_instance_compute_seed_kinematics @ %def term_instance_compute_seed_kinematics @ <>= procedure :: evaluate_projections => term_instance_evaluate_projections <>= subroutine term_instance_evaluate_projections (term, kin) class(term_instance_t), intent(inout) :: term type(kinematics_t), intent(inout) :: kin if (kin%threshold .and. term%nlo_type > BORN) then if (debug2_active (D_THRESHOLD)) & print *, 'Evaluate on-shell projection: ', & char (component_status (term%nlo_type)) select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) call kin%threshold_projection (pcm_work, term%nlo_type) end select end if end subroutine term_instance_evaluate_projections @ %def term_instance_evaluate_projections @ Compute the momenta in the hard interactions, one for each term that constitutes this process component. In simple cases this amounts to just copying momenta. In more advanced cases, we may generate distinct sets of momenta from the seed kinematics. The interactions in the term instances are accessed individually. We may choose to calculate all terms at once together with the seed kinematics, use [[component%core_state]] for storage, and just fill the interactions here. <>= procedure :: compute_hard_kinematics => & term_instance_compute_hard_kinematics <>= subroutine term_instance_compute_hard_kinematics & (term, kin, recover, skip_term, success) class(term_instance_t), intent(inout) :: term type(kinematics_t), intent(inout) :: kin integer, intent(in), optional :: skip_term logical, intent(in), optional :: recover logical, intent(out) :: success type(vector4_t), dimension(:), allocatable :: p if (allocated (term%core_state)) & call term%core_state%reset_new_kinematics () if (present (skip_term)) then if (term%config%i_term_global == skip_term) return end if if (present (recover)) then if (recover) return end if if (term%nlo_type == NLO_REAL .and. kin%emitter >= 0) then call kin%evaluate_radiation (term%p_seed, p, success) select type (pcm => term%pcm) type is (pcm_nlo_t) if (pcm%dalitz_plot%active) then if (kin%emitter > kin%n_in) then if (p(kin%emitter)**2 > tiny_07) & call pcm%register_dalitz_plot (kin%emitter, p) end if end if end select else if (is_subtraction_component (kin%emitter, term%nlo_type)) then call kin%modify_momenta_for_subtraction (term%p_seed, p) success = .true. else allocate (p (size (term%p_seed))); p = term%p_seed success = .true. end if call term%int_hard%set_momenta (p) if (debug_on) then call msg_debug2 (D_REAL, "inside compute_hard_kinematics") if (debug2_active (D_REAL)) call vector4_write_set (p) end if end subroutine term_instance_compute_hard_kinematics @ %def term_instance_compute_hard_kinematics @ Here, we invert this. We fetch the incoming momenta which reside in the appropriate [[sf_chain]] object, stored within the [[k_seed]] subobject. On the other hand, we have the outgoing momenta of the effective interaction. We rely on the process core to compute the remaining seed momenta and to fill the momenta within the hard interaction. (The latter is trivial if hard and effective interaction coincide.) After this is done, the incoming momenta in the trace evaluator that corresponds to the hard (effective) interaction, are still left undefined. We remedy this by calling [[receive_kinematics]] once. <>= procedure :: recover_seed_kinematics => & term_instance_recover_seed_kinematics <>= subroutine term_instance_recover_seed_kinematics (term, kin, p_seed_ref) class(term_instance_t), intent(inout) :: term type(kinematics_t), intent(in) :: kin integer :: n_in type(vector4_t), dimension(:), intent(in), optional :: p_seed_ref n_in = kin%n_in call kin%get_incoming_momenta (term%p_seed(1:n_in)) associate (int_eff => term%isolated%int_eff) call int_eff%set_momenta (term%p_seed(1:n_in), outgoing = .false.) if (present (p_seed_ref)) then term%p_seed(n_in + 1 : ) = p_seed_ref else term%p_seed(n_in + 1 : ) = int_eff%get_momenta (outgoing = .true.) end if end associate call term%isolated%receive_kinematics () end subroutine term_instance_recover_seed_kinematics @ %def term_instance_recover_seed_kinematics @ Compute the integration parameters for all channels except the selected one. JRR: Obsolete now. <>= procedure :: compute_other_channels => & term_instance_compute_other_channels <>= subroutine term_instance_compute_other_channels & (term, mci_work, phs_channel) class(term_instance_t), intent(inout), target :: term type(mci_work_t), intent(in) :: mci_work integer, intent(in) :: phs_channel call term%k_term%compute_other_channels (mci_work, phs_channel) end subroutine term_instance_compute_other_channels @ %def term_instance_compute_other_channels @ Recover beam momenta, i.e., return the beam momenta as currently stored in the kinematics subobject to their source. This is a side effect. JRR: Obsolete now. <>= procedure :: return_beam_momenta => term_instance_return_beam_momenta <>= subroutine term_instance_return_beam_momenta (term) class(term_instance_t), intent(in) :: term call term%k_term%return_beam_momenta () end subroutine term_instance_return_beam_momenta @ %def term_instance_return_beam_momenta @ Applies the real partition by computing the real partition function $F(\Phi)$ and multiplying either $\mathcal{R}_\text{sin} = \mathcal{R} \cdot F$ or $\mathcal{R}_\text{fin} = \mathcal{R} \cdot (1-F)$. <>= procedure :: apply_real_partition => term_instance_apply_real_partition <>= subroutine term_instance_apply_real_partition (term, kin, process) class(term_instance_t), intent(inout) :: term type(kinematics_t), intent(in) :: kin type(process_t), intent(in) :: process real(default) :: f, sqme integer :: i_component integer :: i_amp, n_amps, qn_index logical :: is_subtraction i_component = term%config%i_component if (process%component_is_selected (i_component) .and. & process%get_component_nlo_type (i_component) == NLO_REAL) then is_subtraction = process%get_component_type (i_component) == COMP_REAL_SING & .and. kin%emitter < 0 if (is_subtraction) return select case (process%get_component_type (i_component)) case (COMP_REAL_FIN) call term%connected%trace%set_duplicate_flv_zero() end select select type (pcm => process%get_pcm_ptr ()) type is (pcm_nlo_t) f = pcm%real_partition%get_f (term%p_hard) end select n_amps = term%connected%trace%get_n_matrix_elements () do i_amp = 1, n_amps qn_index = term%connected%trace%get_qn_index (i_amp, i_sub = 0) sqme = real (term%connected%trace%get_matrix_element (qn_index)) if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "term_instance_apply_real_partition") select type (pcm => term%pcm) type is (pcm_nlo_t) select case (process%get_component_type (i_component)) case (COMP_REAL_FIN, COMP_REAL_SING) select case (process%get_component_type (i_component)) case (COMP_REAL_FIN) if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "Real finite") sqme = sqme * (one - f) case (COMP_REAL_SING) if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "Real singular") sqme = sqme * f end select end select end select if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "apply_damping: sqme", sqme) call term%connected%trace%set_matrix_element (qn_index, cmplx (sqme, zero, default)) end do end if end subroutine term_instance_apply_real_partition @ %def term_instance_apply_real_partition @ <>= procedure :: get_p_hard => term_instance_get_p_hard <>= pure function term_instance_get_p_hard (term_instance) result (p_hard) type(vector4_t), dimension(:), allocatable :: p_hard class(term_instance_t), intent(in) :: term_instance allocate (p_hard (size (term_instance%p_hard))) p_hard = term_instance%p_hard end function term_instance_get_p_hard @ %def term_instance_get_p_hard @ <>= procedure :: set_emitter => term_instance_set_emitter <>= subroutine term_instance_set_emitter (term, kin) class(term_instance_t), intent(inout) :: term type(kinematics_t), intent(inout) :: kin integer :: i_phs logical :: set_emitter select type (pcm => term%pcm) type is (pcm_nlo_t) select type (phs => kin%phs) type is (phs_fks_t) !!! Without resonances, i_alr = i_phs i_phs = term%config%i_term kin%i_phs = i_phs set_emitter = i_phs <= pcm%region_data%n_phs .and. term%nlo_type == NLO_REAL if (set_emitter) then kin%emitter = phs%phs_identifiers(i_phs)%emitter select type (pcm => term%pcm) type is (pcm_nlo_t) if (allocated (pcm%region_data%i_phs_to_i_con)) & kin%i_con = pcm%region_data%i_phs_to_i_con (i_phs) end select end if end select end select end subroutine term_instance_set_emitter @ %def term_instance_set_emitter @ For initializing the expressions, we need the local variable list and the parse trees. <>= procedure :: setup_expressions => term_instance_setup_expressions <>= subroutine term_instance_setup_expressions (term, meta, config) class(term_instance_t), intent(inout), target :: term type(process_metadata_t), intent(in), target :: meta type(process_config_data_t), intent(in) :: config if (allocated (config%ef_cuts)) & call term%connected%setup_cuts (config%ef_cuts) if (allocated (config%ef_scale)) & call term%connected%setup_scale (config%ef_scale) if (allocated (config%ef_fac_scale)) & call term%connected%setup_fac_scale (config%ef_fac_scale) if (allocated (config%ef_ren_scale)) & call term%connected%setup_ren_scale (config%ef_ren_scale) if (allocated (config%ef_weight)) & call term%connected%setup_weight (config%ef_weight) end subroutine term_instance_setup_expressions @ %def term_instance_setup_expressions @ Prepare the extra evaluators that we need for processing events. The matrix elements we get from OpenLoops and GoSam are already squared and summed over color and helicity. They should not be squared again. <>= procedure :: setup_event_data => term_instance_setup_event_data <>= subroutine term_instance_setup_event_data (term, kin, core, model) class(term_instance_t), intent(inout), target :: term type(kinematics_t), intent(in) :: kin class(prc_core_t), intent(in) :: core class(model_data_t), intent(in), target :: model integer :: n_in logical :: mask_color type(quantum_numbers_mask_t), dimension(:), allocatable :: mask_in n_in = term%int_hard%get_n_in () allocate (mask_in (n_in)) mask_in = kin%sf_chain%get_out_mask () call setup_isolated (term%isolated, core, model, mask_in, term%config%col) select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) mask_color = pcm_work%is_fixed_order_nlo_events () class default mask_color = .false. end select call setup_connected (term%connected, term%isolated, core, & term%nlo_type, mask_color) contains subroutine setup_isolated (isolated, core, model, mask, color) type(isolated_state_t), intent(inout), target :: isolated class(prc_core_t), intent(in) :: core class(model_data_t), intent(in), target :: model type(quantum_numbers_mask_t), intent(in), dimension(:) :: mask integer, intent(in), dimension(:) :: color select type (core) class is (prc_blha_t) call isolated%matrix%init_identity(isolated%int_eff) isolated%has_matrix = .true. class default call isolated%setup_square_matrix (core, model, mask, color) end select !!! TODO (PS-09-10-20) We should not square the flows !!! if they come from BLHA either call isolated%setup_square_flows (core, model, mask) end subroutine setup_isolated subroutine setup_connected (connected, isolated, core, nlo_type, mask_color) type(connected_state_t), intent(inout), target :: connected type(isolated_state_t), intent(in), target :: isolated class(prc_core_t), intent(in) :: core integer, intent(in) :: nlo_type logical, intent(in) :: mask_color type(quantum_numbers_mask_t), dimension(:), allocatable :: mask call connected%setup_connected_matrix (isolated) if (term%nlo_type == NLO_VIRTUAL .or. (term%nlo_type == NLO_REAL & .and. term%config%i_term_global == term%config%i_sub) & .or. term%nlo_type == NLO_DGLAP) then !!! We do not care about the subtraction matrix elements in !!! connected%matrix, because all entries there are supposed !!! to be squared. To be able to match with flavor quantum numbers, !!! we remove the subtraction quantum entries from the state matrix. allocate (mask (connected%matrix%get_n_tot())) call mask%set_sub (1) call connected%matrix%reduce_state_matrix (mask, keep_order = .true.) end if call term%init_interaction_qn_index (core, connected%matrix, 0, model, & is_polarized = .false.) select type (core) class is (prc_blha_t) call connected%setup_connected_flows & (isolated, mask_color = mask_color) class default call connected%setup_connected_flows (isolated) end select call connected%setup_state_flv (isolated%get_n_out ()) end subroutine setup_connected end subroutine term_instance_setup_event_data @ %def term_instance_setup_event_data @ Color-correlated matrix elements should be obtained from the external BLHA provider. According to the standard, the matrix elements output is a one-dimensional array. For FKS subtraction, we require the matrix $B_{ij}$. BLHA prescribes a mapping $(i, j) \to k$, where $k$ is the index of the matrix element in the output array. It focusses on the off-diagonal entries, i.e. $i \neq j$. The subroutine [[blha_color_c_fill_offdiag]] realizes this mapping. The diagonal entries can simply be obtained as the product of the Born matrix element and either $C_A$ or $C_F$, which is achieved by [[blha_color_c_fill_diag]]. For simple processes, i.e. those with only one color line, it is $B_{ij} = C_F \cdot B$. For those, we keep the possibility of computing color correlations by a multiplication of the Born matrix element with $C_F$. It is triggered by the [[use_internal_color_correlations]] flag and should be used only for testing purposes. However, it is also used for the threshold computation where the process is well-defined and fixed. <>= procedure :: evaluate_color_correlations => & term_instance_evaluate_color_correlations <>= subroutine term_instance_evaluate_color_correlations (term, core) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(inout) :: core integer :: i_flv_born select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) select type (pcm => term%pcm) type is (pcm_nlo_t) if (debug_on) call msg_debug2 (D_SUBTRACTION, & "term_instance_evaluate_color_correlations: " // & "use_internal_color_correlations:", & pcm%settings%use_internal_color_correlations) if (debug_on) call msg_debug2 (D_SUBTRACTION, "fac_scale", term%get_fac_scale ()) do i_flv_born = 1, pcm%region_data%n_flv_born select case (term%nlo_type) case (NLO_REAL) call transfer_me_array_to_bij (pcm, i_flv_born, & pcm_work%real_sub%sqme_born (i_flv_born), & pcm_work%real_sub%sqme_born_color_c (:, :, i_flv_born)) case (NLO_MISMATCH) call transfer_me_array_to_bij (pcm, i_flv_born, & pcm_work%soft_mismatch%sqme_born (i_flv_born), & pcm_work%soft_mismatch%sqme_born_color_c (:, :, i_flv_born)) case (NLO_VIRTUAL) !!! This is just a copy of the above with a different offset and can for sure be unified call transfer_me_array_to_bij (pcm, i_flv_born, & -one, pcm_work%virtual%sqme_color_c (:, :, i_flv_born)) case (NLO_DGLAP) call transfer_me_array_to_bij (pcm, i_flv_born, & pcm_work%dglap_remnant%sqme_born (i_flv_born), & pcm_work%dglap_remnant%sqme_color_c_extra (:, :, i_flv_born)) end select end do end select end select contains function get_trivial_cf_factors (n_tot, flv, factorization_mode) result (beta_ij) integer, intent(in) :: n_tot, factorization_mode integer, intent(in), dimension(:) :: flv real(default), dimension(n_tot, n_tot) :: beta_ij if (factorization_mode == NO_FACTORIZATION) then beta_ij = get_trivial_cf_factors_default (n_tot, flv) else beta_ij = get_trivial_cf_factors_threshold (n_tot, flv) end if end function get_trivial_cf_factors function get_trivial_cf_factors_default (n_tot, flv) result (beta_ij) integer, intent(in) :: n_tot integer, intent(in), dimension(:) :: flv real(default), dimension(n_tot, n_tot) :: beta_ij integer :: i, j beta_ij = zero if (count (is_quark (flv)) == 2) then do i = 1, n_tot do j = 1, n_tot if (is_quark(flv(i)) .and. is_quark(flv(j))) then if (i == j) then beta_ij(i,j)= -cf else beta_ij(i,j) = cf end if end if end do end do end if end function get_trivial_cf_factors_default function get_trivial_cf_factors_threshold (n_tot, flv) result (beta_ij) integer, intent(in) :: n_tot integer, intent(in), dimension(:) :: flv real(default), dimension(n_tot, n_tot) :: beta_ij integer :: i beta_ij = zero do i = 1, 4 beta_ij(i,i) = -cf end do beta_ij(1,2) = cf; beta_ij(2,1) = cf beta_ij(3,4) = cf; beta_ij(4,3) = cf end function get_trivial_cf_factors_threshold subroutine transfer_me_array_to_bij (pcm, i_flv, & sqme_born, sqme_color_c) type(pcm_nlo_t), intent(in) :: pcm integer, intent(in) :: i_flv real(default), intent(in) :: sqme_born real(default), dimension(:,:), intent(inout) :: sqme_color_c logical :: special_case_interferences integer :: i_color_c, i_sub, n_offset real(default), dimension(:), allocatable :: sqme if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "transfer_me_array_to_bij") if (pcm%settings%use_internal_color_correlations) then !!! A negative value for sqme_born indicates that the Born matrix !!! element is multiplied at a different place, e.g. in the case !!! of the virtual component sqme_color_c = get_trivial_cf_factors & (pcm%region_data%get_n_legs_born (), & pcm%region_data%get_flv_states_born (i_flv), & pcm%settings%factorization_mode) if (sqme_born > zero) then sqme_color_c = sqme_born * sqme_color_c else if (sqme_born == zero) then sqme_color_c = zero end if else special_case_interferences = pcm%region_data%nlo_correction_type == "EW" n_offset = 0 if (term%nlo_type == NLO_VIRTUAL) then n_offset = 1 else if (pcm%has_pdfs .and. (term%is_subtraction () & .or. term%nlo_type == NLO_DGLAP)) then n_offset = n_beams_rescaled end if allocate (sqme (term%get_n_sub_color ()), source = zero) do i_sub = 1, term%get_n_sub_color () sqme(i_sub) = real(term%connected%trace%get_matrix_element ( & term%connected%trace%get_qn_index (i_flv, i_sub = i_sub + n_offset)), & default) end do call blha_color_c_fill_offdiag (pcm%region_data%n_legs_born, & sqme, sqme_color_c) call blha_color_c_fill_diag (real(term%connected%trace%get_matrix_element ( & term%connected%trace%get_qn_index (i_flv, i_sub = 0)), default), & pcm%region_data%get_flv_states_born (i_flv), & sqme_color_c, special_case_interferences) end if end subroutine transfer_me_array_to_bij end subroutine term_instance_evaluate_color_correlations @ %def term_instance_evaluate_color_correlations @ <>= procedure :: evaluate_charge_correlations => & term_instance_evaluate_charge_correlations <>= subroutine term_instance_evaluate_charge_correlations (term, core) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(inout) :: core integer :: i_flv_born select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) select type (pcm => term%pcm) type is (pcm_nlo_t) do i_flv_born = 1, pcm%region_data%n_flv_born select case (term%nlo_type) case (NLO_REAL) call transfer_me_array_to_bij (pcm, i_flv_born, & pcm_work%real_sub%sqme_born (i_flv_born), & pcm_work%real_sub%sqme_born_charge_c (:, :, i_flv_born)) case (NLO_MISMATCH) call transfer_me_array_to_bij (pcm, i_flv_born, & pcm_work%soft_mismatch%sqme_born (i_flv_born), & pcm_work%soft_mismatch%sqme_born_charge_c (:, :, i_flv_born)) case (NLO_VIRTUAL) call transfer_me_array_to_bij (pcm, i_flv_born, & one, pcm_work%virtual%sqme_charge_c (:, :, i_flv_born)) end select end do end select end select contains subroutine transfer_me_array_to_bij (pcm, i_flv, sqme_born, sqme_charge_c) type(pcm_nlo_t), intent(in) :: pcm integer, intent(in) :: i_flv real(default), intent(in) :: sqme_born real(default), dimension(:,:), intent(inout) :: sqme_charge_c integer :: n_legs_born, i, j real(default), dimension(:), allocatable :: sigma real(default), dimension(:), allocatable :: Q n_legs_born = pcm%region_data%n_legs_born associate (flv_born => pcm%region_data%flv_born(i_flv)) allocate (sigma (n_legs_born), Q (size (flv_born%charge))) Q = flv_born%charge sigma(1:flv_born%n_in) = -one sigma(flv_born%n_in + 1: ) = one end associate do i = 1, n_legs_born do j = 1, n_legs_born sqme_charge_c(i, j) = sigma(i) * sigma(j) * Q(i) * Q(j) * (-one) end do end do sqme_charge_c = sqme_charge_c * sqme_born end subroutine transfer_me_array_to_bij end subroutine term_instance_evaluate_charge_correlations @ %def term_instance_evaluate_charge_correlations @ The information about spin correlations is not stored in the [[nlo_settings]] because it is only available after the [[fks_regions]] have been created. <>= procedure :: evaluate_spin_correlations => term_instance_evaluate_spin_correlations <>= subroutine term_instance_evaluate_spin_correlations (term, core) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(inout) :: core integer :: i_flv, i_sub, i_emitter, emitter integer :: n_flv, n_sub_color, n_sub_spin, n_offset,i,j real(default), dimension(1:3, 1:3) :: sqme_spin_c real(default), dimension(:), allocatable :: sqme_spin_c_all real(default), dimension(:), allocatable :: sqme_spin_c_arr if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, & "term_instance_evaluate_spin_correlations") select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) if (pcm_work%real_sub%requires_spin_correlations () & .and. term%nlo_type == NLO_REAL) then select type (core) type is (prc_openloops_t) select type (pcm => term%pcm) type is (pcm_nlo_t) n_flv = term%connected%trace%get_qn_index_n_flv () n_sub_color = term%get_n_sub_color () n_sub_spin = term%get_n_sub_spin () n_offset = 0; if(pcm%has_pdfs) n_offset = n_beams_rescaled allocate (sqme_spin_c_arr(6)) do i_flv = 1, n_flv allocate (sqme_spin_c_all(n_sub_spin)) do i_sub = 1, n_sub_spin sqme_spin_c_all(i_sub) = real(term%connected%trace%get_matrix_element & (term%connected%trace%get_qn_index (i_flv, & i_sub = i_sub + n_offset + n_sub_color)), default) end do do i_emitter = 1, pcm%region_data%n_emitters emitter = pcm%region_data%emitters(i_emitter) if (emitter > 0) then call split_array (sqme_spin_c_all, sqme_spin_c_arr) do j = 1, size (sqme_spin_c, dim=2) do i = j, size (sqme_spin_c, dim=1) !!! Restoring the symmetric matrix packed into a 1-dim array !!! c.f. [[prc_openloops_compute_sqme_spin_c]] sqme_spin_c(i,j) = sqme_spin_c_arr(j + i * (i - 1) / 2) if (i /= j) sqme_spin_c(j,i) = sqme_spin_c(i,j) end do end do pcm_work%real_sub%sqme_born_spin_c(:,:,emitter,i_flv) = sqme_spin_c end if end do deallocate (sqme_spin_c_all) end do end select class default call msg_fatal ("Spin correlations so far only supported by OpenLoops.") end select end if end select end subroutine term_instance_evaluate_spin_correlations @ %def term_instance_evaluate_spin_correlations @@ <>= procedure :: apply_fks => term_instance_apply_fks <>= subroutine term_instance_apply_fks (term, kin, alpha_s_sub, alpha_qed_sub) class(term_instance_t), intent(inout) :: term class(kinematics_t), intent(inout) :: kin real(default), intent(in) :: alpha_s_sub, alpha_qed_sub real(default), dimension(:), allocatable :: sqme integer :: i, i_phs, emitter logical :: is_subtraction select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) select type (pcm => term%pcm) type is (pcm_nlo_t) if (term%connected%has_matrix) then allocate (sqme (pcm%get_n_alr ())) else allocate (sqme (1)) end if sqme = zero select type (phs => kin%phs) type is (phs_fks_t) if (pcm%has_pdfs .and. & pcm%settings%use_internal_color_correlations) then call msg_fatal ("Color correlations for proton processes " // & "so far only supported by OpenLoops.") end if call pcm_work%set_real_and_isr_kinematics & (phs%phs_identifiers, kin%phs%get_sqrts ()) if (kin%emitter < 0) then call pcm_work%set_subtraction_event () do i_phs = 1, pcm%region_data%n_phs emitter = phs%phs_identifiers(i_phs)%emitter call pcm_work%real_sub%compute (emitter, & i_phs, alpha_s_sub, alpha_qed_sub, term%connected%has_matrix, sqme) end do else call pcm_work%set_radiation_event () emitter = kin%emitter; i_phs = kin%i_phs do i = 1, term%connected%trace%get_qn_index_n_flv () pcm_work%real_sub%sqme_real_non_sub (i, i_phs) = & real (term%connected%trace%get_matrix_element ( & term%connected%trace%get_qn_index (i))) end do call pcm_work%real_sub%compute (emitter, i_phs, alpha_s_sub, & alpha_qed_sub, term%connected%has_matrix, sqme) end if end select end select end select if (term%connected%has_trace) & call term%connected%trace%set_only_matrix_element & (1, cmplx (sum(sqme), 0, default)) select type (pcm => term%pcm) type is (pcm_nlo_t) is_subtraction = kin%emitter < 0 if (term%connected%has_matrix) & call refill_evaluator (cmplx (sqme * term%weight, 0, default), & pcm%get_qn (is_subtraction), & pcm%region_data%get_flavor_indices (is_subtraction), & term%connected%matrix) if (term%connected%has_flows) & call refill_evaluator (cmplx (sqme * term%weight, 0, default), & pcm%get_qn (is_subtraction), & pcm%region_data%get_flavor_indices (is_subtraction), & term%connected%flows) end select end subroutine term_instance_apply_fks @ %def term_instance_apply_fks @ <>= procedure :: evaluate_sqme_virt => term_instance_evaluate_sqme_virt <>= subroutine term_instance_evaluate_sqme_virt (term, alpha_s, alpha_qed) class(term_instance_t), intent(inout) :: term real(default), intent(in) :: alpha_s, alpha_qed real(default), dimension(2) :: alpha_coupling type(vector4_t), dimension(:), allocatable :: p_born real(default), dimension(:), allocatable :: sqme_virt integer :: i_flv if (term%nlo_type /= NLO_VIRTUAL) call msg_fatal & ("Trying to evaluate virtual matrix element with unsuited term_instance.") if (debug2_active (D_VIRTUAL)) then call msg_debug2 (D_VIRTUAL, "Evaluating virtual-subtracted matrix elements") print *, 'ren_scale: ', term%get_ren_scale () print *, 'fac_scale: ', term%get_fac_scale () if (allocated (term%es_scale)) then print *, 'ES scale: ', term%es_scale else print *, 'ES scale: ', term%get_ren_scale () end if end if select type (pcm => term%pcm) type is (pcm_nlo_t) select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) alpha_coupling = [alpha_s, alpha_qed] if (debug2_active (D_VIRTUAL)) then print *, 'alpha_s: ', alpha_coupling (1) print *, 'alpha_qed: ', alpha_coupling (2) end if allocate (p_born (pcm%region_data%n_legs_born)) if (pcm%settings%factorization_mode == FACTORIZATION_THRESHOLD) then p_born = pcm_work%real_kinematics%p_born_onshell%get_momenta(1) else p_born = term%int_hard%get_momenta () end if call pcm_work%set_momenta_and_scales_virtual & (p_born, term%ren_scale, term%get_fac_scale (), & term%es_scale) select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) associate (virtual => pcm_work%virtual) do i_flv = 1, term%connected%trace%get_qn_index_n_flv () virtual%sqme_born(i_flv) = & real (term%connected%trace%get_matrix_element ( & term%connected%trace%get_qn_index (i_flv, i_sub = 0))) virtual%sqme_virt_fin(i_flv) = & real (term%connected%trace%get_matrix_element ( & term%connected%trace%get_qn_index (i_flv, i_sub = 1))) end do end associate end select call pcm_work%compute_sqme_virt (term%pcm, term%p_hard, alpha_coupling, & term%connected%has_matrix, sqme_virt) call term%connected%trace%set_only_matrix_element & (1, cmplx (sum(sqme_virt), 0, default)) if (term%connected%has_matrix) & call refill_evaluator (cmplx (sqme_virt * term%weight, 0, default), & pcm%get_qn (.true.), & remove_duplicates_from_int_array ( & pcm%region_data%get_flavor_indices (.true.)), & term%connected%matrix) if (term%connected%has_flows) & call refill_evaluator (cmplx (sqme_virt * term%weight, 0, default), & pcm%get_qn (.true.), & remove_duplicates_from_int_array ( & pcm%region_data%get_flavor_indices (.true.)), & term%connected%flows) end select end select end subroutine term_instance_evaluate_sqme_virt @ %def term_instance_evaluate_sqme_virt @ Needs generalization to electroweak corrections. <>= procedure :: evaluate_sqme_mismatch => term_instance_evaluate_sqme_mismatch <>= subroutine term_instance_evaluate_sqme_mismatch (term, alpha_s) class(term_instance_t), intent(inout) :: term real(default), intent(in) :: alpha_s real(default), dimension(:), allocatable :: sqme_mism if (term%nlo_type /= NLO_MISMATCH) call msg_fatal & ("Trying to evaluate soft mismatch with unsuited term_instance.") select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) call pcm_work%compute_sqme_mismatch & (term%pcm, alpha_s, term%connected%has_matrix, sqme_mism) end select call term%connected%trace%set_only_matrix_element & (1, cmplx (sum (sqme_mism) * term%weight, 0, default)) if (term%connected%has_matrix) then select type (pcm => term%pcm) type is (pcm_nlo_t) if (term%connected%has_matrix) & call refill_evaluator (cmplx (sqme_mism * term%weight, 0, default), & pcm%get_qn (.true.), & remove_duplicates_from_int_array ( & pcm%region_data%get_flavor_indices (.true.)), & term%connected%matrix) if (term%connected%has_flows) & call refill_evaluator (cmplx (sqme_mism * term%weight, 0, default), & pcm%get_qn (.true.), & remove_duplicates_from_int_array ( & pcm%region_data%get_flavor_indices (.true.)), & term%connected%flows) end select end if end subroutine term_instance_evaluate_sqme_mismatch @ %def term_instance_evaluate_sqme_mismatch @ <>= procedure :: evaluate_sqme_dglap => term_instance_evaluate_sqme_dglap <>= subroutine term_instance_evaluate_sqme_dglap (term, alpha_s, alpha_qed) class(term_instance_t), intent(inout) :: term real(default), intent(in) :: alpha_s, alpha_qed real(default), dimension(2) :: alpha_coupling real(default), dimension(:), allocatable :: sqme_dglap integer :: i_flv if (term%nlo_type /= NLO_DGLAP) call msg_fatal & ("Trying to evaluate DGLAP remnant with unsuited term_instance.") if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "term_instance_evaluate_sqme_dglap") select type (pcm => term%pcm) type is (pcm_nlo_t) select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) alpha_coupling = [alpha_s,alpha_qed] if (debug2_active (D_PROCESS_INTEGRATION)) then associate (n_flv => pcm_work%dglap_remnant%reg_data%n_flv_born) print *, "size(sqme_born) = ", size (pcm_work%dglap_remnant%sqme_born) call term%connected%trace%write () end associate end if call pcm_work%compute_sqme_dglap_remnant (pcm, alpha_coupling, & term%connected%has_matrix, sqme_dglap) end select end select call term%connected%trace%set_only_matrix_element & (1, cmplx (sum (sqme_dglap) * term%weight, 0, default)) if (term%connected%has_matrix) then select type (pcm => term%pcm) type is (pcm_nlo_t) call refill_evaluator (cmplx (sqme_dglap * term%weight, 0, default), & pcm%get_qn (.true.), & remove_duplicates_from_int_array ( & pcm%region_data%get_flavor_indices (.true.)), & term%connected%matrix) if (term%connected%has_flows) then call refill_evaluator (cmplx (sqme_dglap * term%weight, 0, default), & pcm%get_qn (.true.), & remove_duplicates_from_int_array ( & pcm%region_data%get_flavor_indices (.true.)), & term%connected%flows) end if end select end if end subroutine term_instance_evaluate_sqme_dglap @ %def term_instance_evaluate_sqme_dglap @ Reset the term instance: clear the parton-state expressions and deactivate. <>= procedure :: reset => term_instance_reset <>= subroutine term_instance_reset (term) class(term_instance_t), intent(inout) :: term call term%connected%reset_expressions () if (allocated (term%alpha_qcd_forced)) deallocate (term%alpha_qcd_forced) term%active = .false. end subroutine term_instance_reset @ %def term_instance_reset @ Force an $\alpha_s$ value that should be used in the matrix-element calculation. <>= procedure :: set_alpha_qcd_forced => term_instance_set_alpha_qcd_forced <>= subroutine term_instance_set_alpha_qcd_forced (term, alpha_qcd) class(term_instance_t), intent(inout) :: term real(default), intent(in) :: alpha_qcd if (allocated (term%alpha_qcd_forced)) then term%alpha_qcd_forced = alpha_qcd else allocate (term%alpha_qcd_forced, source = alpha_qcd) end if end subroutine term_instance_set_alpha_qcd_forced @ %def term_instance_set_alpha_qcd_forced @ Complete the kinematics computation for the effective parton states. We assume that the [[compute_hard_kinematics]] method of the process component instance has already been called, so the [[int_hard]] contains the correct hard kinematics. The duty of this procedure is first to compute the effective kinematics and store this in the [[int_eff]] effective interaction inside the [[isolated]] parton state. The effective kinematics may differ from the kinematics in the hard interaction. It may involve parton recombination or parton splitting. The [[rearrange_partons]] method is responsible for this part. We may also call a method to compute the effective structure-function chain at this point. This is not implemented yet. In the simple case that no rearrangement is necessary, as indicated by the [[rearrange]] flag, the effective interaction is a pointer to the hard interaction, and we can skip the rearrangement method. Similarly for the effective structure-function chain. The final step of kinematics setup is to transfer the effective kinematics to the evaluators and to the [[subevt]]. <>= procedure :: compute_eff_kinematics => & term_instance_compute_eff_kinematics <>= subroutine term_instance_compute_eff_kinematics (term) class(term_instance_t), intent(inout) :: term term%checked = .false. term%passed = .false. call term%isolated%receive_kinematics () call term%connected%receive_kinematics () end subroutine term_instance_compute_eff_kinematics @ %def term_instance_compute_eff_kinematics @ Inverse. Reconstruct the connected state from the momenta in the trace evaluator (which we assume to be set), then reconstruct the isolated state as far as possible. The second part finalizes the momentum configuration, using the incoming seed momenta <>= procedure :: recover_hard_kinematics => & term_instance_recover_hard_kinematics <>= subroutine term_instance_recover_hard_kinematics (term) class(term_instance_t), intent(inout) :: term term%checked = .false. term%passed = .false. call term%connected%send_kinematics () call term%isolated%send_kinematics () end subroutine term_instance_recover_hard_kinematics @ %def term_instance_recover_hard_kinematics @ Check the term whether it passes cuts and, if successful, evaluate scales and weights. The factorization scale is also given to the term kinematics, enabling structure-function evaluation. <>= procedure :: evaluate_expressions => & term_instance_evaluate_expressions <>= subroutine term_instance_evaluate_expressions (term, scale_forced) class(term_instance_t), intent(inout) :: term real(default), intent(in), allocatable, optional :: scale_forced call term%connected%evaluate_expressions (term%passed, & term%scale, term%fac_scale, term%ren_scale, term%weight, & scale_forced, force_evaluation = .true.) term%checked = .true. end subroutine term_instance_evaluate_expressions @ %def term_instance_evaluate_expressions @ Evaluate the trace: first evaluate the hard interaction, then the trace evaluator. We use the [[evaluate_interaction]] method of the process component which generated this term. The [[subevt]] and cut expressions are not yet filled. The [[component]] argument is intent(inout) because the [[compute_amplitude]] method may modify the [[core_state]] workspace object. <>= procedure :: evaluate_interaction => term_instance_evaluate_interaction <>= subroutine term_instance_evaluate_interaction (term, core, kin) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(in), pointer :: core type(kinematics_t), intent(inout) :: kin if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, & "term_instance_evaluate_interaction") if (kin%only_cm_frame .and. (.not. kin%lab_is_cm())) then term%p_hard = kin%get_boost_to_cms () * term%int_hard%get_momenta () else term%p_hard = term%int_hard%get_momenta () end if select type (core) class is (prc_external_t) call term%evaluate_interaction_userdef (core, kin) class default call term%evaluate_interaction_default (core) end select call term%int_hard%set_matrix_element (term%amp) end subroutine term_instance_evaluate_interaction @ %def term_instance_evaluate_interaction @ <>= procedure :: evaluate_interaction_default & => term_instance_evaluate_interaction_default <>= subroutine term_instance_evaluate_interaction_default (term, core) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(in) :: core real(default) :: fac_scale, ren_scale integer :: i if (allocated (term%fac_scale)) then fac_scale = term%fac_scale else fac_scale = term%scale end if if (allocated (term%ren_scale)) then ren_scale = term%ren_scale else ren_scale = term%scale end if do i = 1, term%config%n_allowed term%amp(i) = core%compute_amplitude (term%config%i_term, term%p_hard, & term%config%flv(i), term%config%hel(i), term%config%col(i), & fac_scale, ren_scale, term%alpha_qcd_forced, & term%core_state) end do select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) call pcm_work%set_fac_scale (fac_scale) end select end subroutine term_instance_evaluate_interaction_default @ %def term_instance_evaluate_interaction_default @ <>= procedure :: evaluate_interaction_userdef & => term_instance_evaluate_interaction_userdef <>= subroutine term_instance_evaluate_interaction_userdef (term, core, kin) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(inout) :: core type(kinematics_t), intent(inout) :: kin if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, & "term_instance_evaluate_interaction_userdef") select type (core_state => term%core_state) type is (openloops_state_t) select type (core) type is (prc_openloops_t) call core%compute_alpha_s (core_state, term%get_ren_scale ()) if (allocated (core_state%threshold_data)) & call evaluate_threshold_parameters (core_state, core, kin%phs%get_sqrts ()) end select class is (prc_external_state_t) select type (core) class is (prc_external_t) call core%compute_alpha_s (core_state, term%get_ren_scale ()) end select end select call evaluate_threshold_interaction () if (term%nlo_type == NLO_VIRTUAL) then call term%evaluate_interaction_userdef_loop (core) else call term%evaluate_interaction_userdef_tree (core) end if select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) call pcm_work%set_fac_scale (term%get_fac_scale ()) end select contains subroutine evaluate_threshold_parameters (core_state, core, sqrts) type(openloops_state_t), intent(inout) :: core_state type(prc_openloops_t), intent(inout) :: core real(default), intent(in) :: sqrts real(default) :: mtop, wtop mtop = m1s_to_mpole (sqrts) wtop = core_state%threshold_data%compute_top_width & (mtop, core_state%alpha_qcd) call core%set_mass_and_width (6, mtop, wtop) end subroutine subroutine evaluate_threshold_interaction () integer :: leg select type (core) type is (prc_threshold_t) if (term%nlo_type > BORN) then select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) if (kin%emitter >= 0) then call core%set_offshell_momenta & (pcm_work%real_kinematics%p_real_cms%get_momenta(term%config%i_term)) leg = thr_leg (kin%emitter) call core%set_leg (leg) call core%set_onshell_momenta & (pcm_work%real_kinematics%p_real_onshell(leg)%get_momenta(term%config%i_term)) else call core%set_leg (0) call core%set_offshell_momenta & (pcm_work%real_kinematics%p_born_cms%get_momenta(1)) end if end select else call core%set_leg (-1) call core%set_offshell_momenta (term%p_hard) end if end select end subroutine evaluate_threshold_interaction end subroutine term_instance_evaluate_interaction_userdef @ %def term_instance_evaluate_interaction_userdef @ Retrieve the matrix elements from a matrix element provider and place them into [[term%amp]]. For the handling of NLO calculations, FKS applies a book keeping handling flavor and/or particle type (e.g. for QCD: quark/gluon and quark flavor) in order to calculate the subtraction terms. Therefore, we have to insert the calculated matrix elements correctly into the state matrix where each entry corresponds to a set of quantum numbers. We apply a mapping [[hard_qn_ind]] from a list of quantum numbers provided by FKS to the hard process [[int_hard]]. The calculated matrix elements are insert into [[term%amp]] in the following way. The first [[n_born]] particles are the matrix element of the hard process. In non-trivial beams, we store another [[n_beams_rescaled]] copies of these matrix elements as the first [[n_beams_rescaled]] subtractions. This is a remnant from times before the method [[term_instance_set_sf_factors]] and these entries are not used anymore. However, eliminating these entries involves deeper changes in how the connection tables for the evaluator product are set up and should therefore be part of a larger refactoring of the interactions \& state matrices. The next $n_{\text{born}}\times n_{sub_color}$ are color-correlated Born matrix elements, with then again the next $n_{\text{born}}\times n_{emitters}\times n_{sub_spin}$ being spin-correlated Born matrix elements. If two or more flavor structures would produce the same amplitude we only compute one and use the [[eqv_index]] determined by the [[prc_core]] and just copy the result to improve performance. <>= procedure :: evaluate_interaction_userdef_tree & => term_instance_evaluate_interaction_userdef_tree <>= subroutine term_instance_evaluate_interaction_userdef_tree (term, core) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(inout) :: core real(default) :: sqme real(default), dimension(:), allocatable :: sqme_color_c real(default), dimension(:), allocatable :: sqme_spin_c real(default), dimension(6) :: sqme_spin_c_tmp integer :: n_flv, n_hel, n_sub_color, n_sub_spin, n_pdf_off integer :: i_flv, i_hel, i_sub, i_color_c, i_color_c_eqv, i_spin_c, i_spin_c_eqv integer :: i_flv_eqv, i_hel_eqv integer :: emitter, i_emitter logical :: bad_point, bp logical, dimension(:,:), allocatable :: eqv_me_evaluated if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, & "term_instance_evaluate_interaction_userdef_tree") allocate (sqme_color_c (blha_result_array_size & (term%int_hard%get_n_tot (), BLHA_AMP_COLOR_C))) n_flv = term%int_hard%get_qn_index_n_flv () n_hel = term%int_hard%get_qn_index_n_hel () n_sub_color = term%get_n_sub_color () n_sub_spin = term%get_n_sub_spin () allocate (eqv_me_evaluated(n_flv,n_hel)) eqv_me_evaluated = .false. do i_flv = 1, n_flv do i_hel = 1, n_hel i_flv_eqv = core%data%eqv_flv_index(i_flv) i_hel_eqv = core%data%eqv_hel_index(i_hel) if (.not. eqv_me_evaluated(i_flv_eqv, i_hel_eqv)) then select type (core) class is (prc_external_t) call core%update_alpha_s (term%core_state, term%get_ren_scale ()) call core%compute_sqme (i_flv, i_hel, term%p_hard, & term%get_ren_scale (), sqme, bad_point) call term%pcm_work%set_bad_point (bad_point) associate (i_int => term%int_hard%get_qn_index & (i_flv = i_flv, i_hel = i_hel, i_sub = 0)) term%amp(i_int) = cmplx (sqme, 0, default) end associate end select n_pdf_off = 0 if (term%pcm%has_pdfs .and. & (term%is_subtraction () .or. term%nlo_type == NLO_DGLAP)) then n_pdf_off = n_pdf_off + n_beams_rescaled do i_sub = 1, n_pdf_off term%amp(term%int_hard%get_qn_index (i_flv, i_hel, i_sub)) = & term%amp(term%int_hard%get_qn_index (i_flv, i_hel, i_sub = 0)) end do end if if (term%pcm%has_pdfs .and. term%nlo_type == NLO_DGLAP) then sqme_color_c = zero select type (pcm => term%pcm) type is (pcm_nlo_t) if (pcm%settings%nlo_correction_type == "EW" .and. & pcm%region_data%alphas_power > 0) then select type (core) class is (prc_blha_t) call core%compute_sqme_color_c_raw (i_flv, i_hel, & term%p_hard, term%get_ren_scale (), sqme_color_c, & bad_point) call term%pcm_work%set_bad_point (bad_point) class is (prc_recola_t) call core%compute_sqme_color_c_raw (i_flv, i_hel, & term%p_hard, term%get_ren_scale (), sqme_color_c, & bad_point) call term%pcm_work%set_bad_point (bad_point) end select end if end select do i_sub = 1, n_sub_color i_color_c = term%int_hard%get_qn_index & (i_flv, i_hel, i_sub + n_pdf_off) term%amp(i_color_c) = cmplx (sqme_color_c(i_sub), 0, default) end do end if if ((term%nlo_type == NLO_REAL .and. term%is_subtraction ()) .or. & term%nlo_type == NLO_MISMATCH) then sqme_color_c = zero select type (core) class is (prc_blha_t) call core%compute_sqme_color_c_raw (i_flv, i_hel, & term%p_hard, term%get_ren_scale (), sqme_color_c, bad_point) call term%pcm_work%set_bad_point (bad_point) class is (prc_recola_t) call core%compute_sqme_color_c_raw (i_flv, i_hel, & term%p_hard, term%get_ren_scale (), sqme_color_c, bad_point) call term%pcm_work%set_bad_point (bad_point) end select do i_sub = 1, n_sub_color i_color_c = term%int_hard%get_qn_index & (i_flv, i_hel, i_sub + n_pdf_off) term%amp(i_color_c) = cmplx (sqme_color_c(i_sub), 0, default) end do if (n_sub_spin > 0) then bad_point = .false. allocate (sqme_spin_c(0)) select type (core) type is (prc_openloops_t) select type (pcm => term%pcm) type is (pcm_nlo_t) do i_emitter = 1, pcm%region_data%n_emitters emitter = pcm%region_data%emitters(i_emitter) if (emitter > 0) then call core%compute_sqme_spin_c & (i_flv, & i_hel, & emitter, & term%p_hard, & term%get_ren_scale (), & sqme_spin_c_tmp, & bp) sqme_spin_c = [sqme_spin_c, sqme_spin_c_tmp] bad_point = bad_point .or. bp end if end do end select do i_sub = 1, n_sub_spin i_spin_c = term%int_hard%get_qn_index (i_flv, i_hel, & i_sub + n_pdf_off + n_sub_color) term%amp(i_spin_c) = cmplx & (sqme_spin_c(i_sub), 0, default) end do end select deallocate (sqme_spin_c) end if end if eqv_me_evaluated(i_flv_eqv, i_hel_eqv) = .true. else associate (i_int => term%int_hard%get_qn_index & (i_flv = i_flv, i_hel = i_hel, i_sub = 0), & i_int_eqv => term%int_hard%get_qn_index & (i_flv = i_flv_eqv, i_hel = i_hel_eqv, i_sub = 0)) term%amp(i_int) = term%amp(i_int_eqv) end associate n_pdf_off = 0 if (term%pcm%has_pdfs .and. & (term%is_subtraction () .or. term%nlo_type == NLO_DGLAP)) then n_pdf_off = n_pdf_off + n_beams_rescaled do i_sub = 1, n_pdf_off term%amp(term%int_hard%get_qn_index (i_flv, i_hel, i_sub)) = & term%amp(term%int_hard%get_qn_index (i_flv, i_hel, i_sub = 0)) end do end if if (term%pcm%has_pdfs .and. term%nlo_type == NLO_DGLAP) then do i_sub = 1, n_sub_color i_color_c = term%int_hard%get_qn_index & (i_flv, i_hel, i_sub + n_pdf_off) i_color_c_eqv = term%int_hard%get_qn_index & (i_flv_eqv, i_hel_eqv, i_sub + n_pdf_off) term%amp(i_color_c) = term%amp(i_color_c_eqv) end do end if if ((term%nlo_type == NLO_REAL .and. term%is_subtraction ()) .or. & term%nlo_type == NLO_MISMATCH) then do i_sub = 1, n_sub_color i_color_c = term%int_hard%get_qn_index & (i_flv, i_hel, i_sub + n_pdf_off) i_color_c_eqv = term%int_hard%get_qn_index & (i_flv_eqv, i_hel_eqv, i_sub + n_pdf_off) term%amp(i_color_c) = term%amp(i_color_c_eqv) end do do i_sub = 1, n_sub_spin i_spin_c = term%int_hard%get_qn_index (i_flv, i_hel, & i_sub + n_pdf_off + n_sub_color) i_spin_c_eqv = term%int_hard%get_qn_index (i_flv_eqv, i_hel_eqv, & i_sub + n_pdf_off + n_sub_color) term%amp(i_spin_c) = term%amp(i_spin_c_eqv) end do end if end if end do end do end subroutine term_instance_evaluate_interaction_userdef_tree @ %def term_instance_evaluate_interaction_userdef_tree @ Same as for [[term_instance_evaluate_interaction_userdef_tree]], but for the integrated-subtraction and finite one-loop terms. We only need color-correlated Born matrix elements, but an additional entry per flavor structure for the finite one-loop contribution. We thus have $2+n_{sub_color}$ entries in the [[term%amp]] for each [[i_flv]] and [[i_hel]] combination. If two or more flavor structures would produce the same amplitude we only compute one and use the [[eqv_index]] determined by the [[prc_core]] and just copy the result to improve performance. <>= procedure :: evaluate_interaction_userdef_loop & => term_instance_evaluate_interaction_userdef_loop <>= subroutine term_instance_evaluate_interaction_userdef_loop (term, core) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(in) :: core integer :: n_hel, n_sub, n_flv integer :: i, i_flv, i_hel, i_sub, i_virt, i_color_c, i_color_c_eqv integer :: i_flv_eqv, i_hel_eqv real(default), dimension(4) :: sqme_virt real(default), dimension(:), allocatable :: sqme_color_c real(default) :: es_scale logical :: bad_point logical, dimension(:,:), allocatable :: eqv_me_evaluated if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, & "term_instance_evaluate_interaction_userdef_loop") allocate (sqme_color_c (blha_result_array_size & (term%int_hard%get_n_tot (), BLHA_AMP_COLOR_C))) n_flv = term%int_hard%get_qn_index_n_flv () n_hel = term%int_hard%get_qn_index_n_hel () n_sub = term%int_hard%get_qn_index_n_sub () allocate (eqv_me_evaluated(n_flv,n_hel)) eqv_me_evaluated = .false. i_virt = 1 do i_flv = 1, n_flv do i_hel = 1, n_hel i_flv_eqv = core%data%eqv_flv_index(i_flv) i_hel_eqv = core%data%eqv_hel_index(i_hel) if (.not. eqv_me_evaluated(i_flv_eqv, i_hel_eqv)) then select type (core) class is (prc_external_t) if (allocated (term%es_scale)) then es_scale = term%es_scale else es_scale = term%get_ren_scale () end if call core%compute_sqme_virt (i_flv, i_hel, term%p_hard, & term%get_ren_scale (), es_scale, & term%pcm%blha_defaults%loop_method, & sqme_virt, bad_point) call term%pcm_work%set_bad_point (bad_point) end select associate (i_born => term%int_hard%get_qn_index (i_flv, i_hel = i_hel, i_sub = 0), & i_loop => term%int_hard%get_qn_index (i_flv, i_hel = i_hel, i_sub = i_virt)) term%amp(i_loop) = cmplx (sqme_virt(3), 0, default) term%amp(i_born) = cmplx (sqme_virt(4), 0, default) end associate select type (pcm => term%pcm) type is (pcm_nlo_t) select type (core) class is (prc_blha_t) call core%compute_sqme_color_c_raw (i_flv, i_hel, & term%p_hard, term%get_ren_scale (), & sqme_color_c, bad_point) call term%pcm_work%set_bad_point (bad_point) do i_sub = 1 + i_virt, n_sub i_color_c = term%int_hard%get_qn_index & (i_flv, i_hel = i_hel, i_sub = i_sub) ! Index shift: i_sub - i_virt term%amp(i_color_c) = & cmplx (sqme_color_c(i_sub - i_virt), 0, default) end do type is (prc_recola_t) call core%compute_sqme_color_c_raw (i_flv, i_hel, & term%p_hard, term%get_ren_scale (), sqme_color_c, bad_point) call term%pcm_work%set_bad_point (bad_point) do i_sub = 1 + i_virt, n_sub i_color_c = term%int_hard%get_qn_index & (i_flv, i_hel = i_hel, i_sub = i_sub) ! Index shift: i_sub - i_virt term%amp(i_color_c) = & cmplx (sqme_color_c(i_sub - i_virt), 0, default) end do end select end select eqv_me_evaluated(i_flv_eqv, i_hel_eqv) = .true. else associate (i_born => term%int_hard%get_qn_index (i_flv, i_hel = i_hel, i_sub = 0), & i_loop => term%int_hard%get_qn_index (i_flv, i_hel = i_hel, i_sub = i_virt), & i_born_eqv => term%int_hard%get_qn_index & (i_flv_eqv, i_hel = i_hel_eqv, i_sub = 0), & i_loop_eqv => term%int_hard%get_qn_index & (i_flv_eqv, i_hel = i_hel_eqv, i_sub = 1)) term%amp(i_loop) = term%amp(i_loop_eqv) term%amp(i_born) = term%amp(i_born_eqv) end associate do i_sub = 1 + i_virt, n_sub i_color_c = term%int_hard%get_qn_index & (i_flv, i_hel = i_hel, i_sub = i_sub) i_color_c_eqv = term%int_hard%get_qn_index & (i_flv_eqv, i_hel = i_hel_eqv, i_sub = i_sub) ! Index shift: i_sub - i_virt term%amp(i_color_c) = term%amp(i_color_c_eqv) end do end if end do end do end subroutine term_instance_evaluate_interaction_userdef_loop @ %def term_instance_evaluate_interaction_userdef_loop @ Evaluate the trace. First evaluate the structure-function chain (i.e., the density matrix of the incoming partons). Do this twice, in case the sf-chain instances within [[kin]] and [[isolated]] differ. Next, evaluate the hard interaction, then compute the convolution with the initial state. <>= procedure :: evaluate_trace => term_instance_evaluate_trace <>= subroutine term_instance_evaluate_trace (term, kin) class(term_instance_t), intent(inout) :: term type(kinematics_t), intent(inout) :: kin real(default) :: fac_scale if (allocated (term%fac_scale)) then fac_scale = term%fac_scale else fac_scale = term%scale end if call kin%evaluate_sf_chain (fac_scale, term%negative_sf) call term%evaluate_scaled_sf_chains (kin) call term%isolated%evaluate_sf_chain (fac_scale) call term%isolated%evaluate_trace () call term%connected%evaluate_trace () end subroutine term_instance_evaluate_trace @ %def term_instance_evaluate_trace @ Include rescaled structure functions due to NLO calculation. We rescale the structure function for the real subtraction [[sf_rescale_collinear]], the collinear counter terms [[sf_rescale_dglap_t]] and for the case, in which we have an emitter in the initial state, we rescale the kinematics for it using [[sf_rescale_real_t]].\\ References: arXiv:0709.2092, (2.35)-(2.42).\\ Obviously, it is completely irrelevant, which beam is treated. It becomes problematic when handling [[e, p]]-beams. <>= procedure :: evaluate_scaled_sf_chains => term_instance_evaluate_scaled_sf_chains <>= subroutine term_instance_evaluate_scaled_sf_chains (term, kin) class(term_instance_t), intent(inout) :: term type(kinematics_t), intent(inout) :: kin class(sf_rescale_t), allocatable :: sf_rescale if (.not. term%pcm%has_pdfs) return if (term%nlo_type == NLO_REAL) then if (term%is_subtraction ()) then allocate (sf_rescale_collinear_t :: sf_rescale) select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) select type (sf_rescale) type is (sf_rescale_collinear_t) call sf_rescale%set (pcm_work%real_kinematics%xi_tilde) end select end select call kin%sf_chain%evaluate (term%get_fac_scale (), & term%negative_sf, sf_rescale) deallocate (sf_rescale) else if (kin%emitter >= 0 .and. kin%emitter <= kin%n_in) then allocate (sf_rescale_real_t :: sf_rescale) select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) select type (sf_rescale) type is (sf_rescale_real_t) call sf_rescale%set (pcm_work%real_kinematics%xi_tilde * & pcm_work%real_kinematics%xi_max (kin%i_phs), & pcm_work%real_kinematics%y (kin%i_phs)) end select end select call kin%sf_chain%evaluate (term%get_fac_scale (), & term%negative_sf, sf_rescale) deallocate (sf_rescale) else call kin%sf_chain%evaluate (term%get_fac_scale (), term%negative_sf) end if else if (term%nlo_type == NLO_DGLAP) then allocate (sf_rescale_dglap_t :: sf_rescale) select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) select type (sf_rescale) type is (sf_rescale_dglap_t) call sf_rescale%set (pcm_work%isr_kinematics%z) end select end select call kin%sf_chain%evaluate (term%get_fac_scale (), & term%negative_sf, sf_rescale) deallocate (sf_rescale) end if end subroutine term_instance_evaluate_scaled_sf_chains @ %def term_instance_evaluate_scaled_sf_chains @ Evaluate the extra data that we need for processing the object as a physical event. <>= procedure :: evaluate_event_data => term_instance_evaluate_event_data <>= subroutine term_instance_evaluate_event_data (term) class(term_instance_t), intent(inout) :: term logical :: only_momenta only_momenta = term%nlo_type > BORN call term%isolated%evaluate_event_data (only_momenta) call term%connected%evaluate_event_data (only_momenta) end subroutine term_instance_evaluate_event_data @ %def term_instance_evaluate_event_data @ <>= procedure :: set_fac_scale => term_instance_set_fac_scale <>= subroutine term_instance_set_fac_scale (term, fac_scale) class(term_instance_t), intent(inout) :: term real(default), intent(in) :: fac_scale term%fac_scale = fac_scale end subroutine term_instance_set_fac_scale @ %def term_instance_set_fac_scale @ Return data that might be useful for external processing. The factorization scale and renormalization scale are identical to the general scale if not explicitly set: <>= procedure :: get_fac_scale => term_instance_get_fac_scale procedure :: get_ren_scale => term_instance_get_ren_scale <>= function term_instance_get_fac_scale (term) result (fac_scale) class(term_instance_t), intent(in) :: term real(default) :: fac_scale if (allocated (term%fac_scale)) then fac_scale = term%fac_scale else fac_scale = term%scale end if end function term_instance_get_fac_scale function term_instance_get_ren_scale (term) result (ren_scale) class(term_instance_t), intent(in) :: term real(default) :: ren_scale if (allocated (term%ren_scale)) then ren_scale = term%ren_scale else ren_scale = term%scale end if end function term_instance_get_ren_scale @ %def term_instance_get_fac_scale term_instance_get_ren_scale @ We take the strong coupling from the process core. The value is calculated when a new event is requested, so we should call it only after the event has been evaluated. If it is not available there (a negative number is returned), we take the value stored in the term configuration, which should be determined by the model. If the model does not provide a value, the result is zero. <>= procedure :: get_alpha_s => term_instance_get_alpha_s <>= function term_instance_get_alpha_s (term, core) result (alpha_s) class(term_instance_t), intent(in) :: term class(prc_core_t), intent(in) :: core real(default) :: alpha_s alpha_s = core%get_alpha_s (term%core_state) if (alpha_s < zero) alpha_s = term%config%alpha_s end function term_instance_get_alpha_s @ %def term_instance_get_alpha_s @ The second helicity for [[helicities]] comes with a minus sign because OpenLoops inverts the helicity index of antiparticles. <>= procedure :: get_helicities_for_openloops => term_instance_get_helicities_for_openloops <>= subroutine term_instance_get_helicities_for_openloops (term, helicities) class(term_instance_t), intent(in) :: term integer, dimension(:,:), allocatable, intent(out) :: helicities type(helicity_t), dimension(:), allocatable :: hel type(quantum_numbers_t), dimension(:,:), allocatable :: qn type(quantum_numbers_mask_t) :: qn_mask integer :: h, i, j, n_in call qn_mask%set_sub (1) call term%isolated%trace%get_quantum_numbers_mask (qn_mask, qn) n_in = term%int_hard%get_n_in () allocate (helicities (size (qn, dim=1), n_in)) allocate (hel (n_in)) do i = 1, size (qn, dim=1) do j = 1, n_in hel(j) = qn(i, j)%get_helicity () call hel(j)%diagonalize () call hel(j)%get_indices (h, h) helicities (i, j) = h end do end do end subroutine term_instance_get_helicities_for_openloops @ %def term_instance_get_helicities_for_openloops @ <>= procedure :: get_i_term_global => term_instance_get_i_term_global <>= elemental function term_instance_get_i_term_global (term) result (i_term) integer :: i_term class(term_instance_t), intent(in) :: term i_term = term%config%i_term_global end function term_instance_get_i_term_global @ %def term_instance_get_i_term_global @ <>= procedure :: is_subtraction => term_instance_is_subtraction <>= elemental function term_instance_is_subtraction (term) result (sub) logical :: sub class(term_instance_t), intent(in) :: term sub = term%config%i_term_global == term%config%i_sub end function term_instance_is_subtraction @ %def term_instance_is_subtraction @ Retrieve [[n_sub]] which was calculated in [[process_term_setup_interaction]]. <>= procedure :: get_n_sub => term_instance_get_n_sub procedure :: get_n_sub_color => term_instance_get_n_sub_color procedure :: get_n_sub_spin => term_instance_get_n_sub_spin <>= function term_instance_get_n_sub (term) result (n_sub) integer :: n_sub class(term_instance_t), intent(in) :: term n_sub = term%config%n_sub end function term_instance_get_n_sub function term_instance_get_n_sub_color (term) result (n_sub_color) integer :: n_sub_color class(term_instance_t), intent(in) :: term n_sub_color = term%config%n_sub_color end function term_instance_get_n_sub_color function term_instance_get_n_sub_spin (term) result (n_sub_spin) integer :: n_sub_spin class(term_instance_t), intent(in) :: term n_sub_spin = term%config%n_sub_spin end function term_instance_get_n_sub_spin @ %def term_instance_get_n_sub @ %def term_instance_get_n_sub_color @ %def term_instance_get_n_sub_spin @ \subsection{The process instance} NOTE: The description below represents the intended structure after refactoring and disentangling the FKS-NLO vs. LO algorithm dependencies. A process instance contains all process data that depend on the sampling point and thus change often. In essence, it is an event record at the elementary (parton) level. We do not call it such, to avoid confusion with the actual event records. If decays are involved, the latter are compositions of several elementary processes (i.e., their instances). We implement the process instance as an extension of the [[mci_sampler_t]] that we need for computing integrals and generate events. The base type contains: the [[integrand]], the [[selected_channel]], the two-dimensional array [[x]] of parameters, and the one-dimensional array [[f]] of Jacobians. These subobjects are public and used for communicating with the multi-channel integrator. The [[process]] pointer accesses the process of which this record is an instance. It is required whenever the calculation needs invariant configuration data, therefore the process should stay in memory for the whole lifetime of its instances. The [[pcm]] pointer is a shortcut to the [[pcm]] (process-component manager) component of the associated process, which we need wherever the calculation depends on the overall algorithm. The [[pcm_work]] component is the workspace for the [[pcm]] object referenced above. The [[evaluation_status]] code is used to check the current status. In particular, failure at various stages is recorded there. The [[count]] object records process evaluations, broken down according to status. The [[sqme]] value is the single real number that results from evaluating and tracing the kinematics and matrix elements. This is the number that is handed over to an integration routine. The [[weight]] value is the event weight. It is defined when an event has been generated from the process instance, either weighted or unweighted. The value is the [[sqme]] value times Jacobian weights from the integration, or unity, respectively. The [[i_mci]] index chooses a subset of components that are associated with a common parameter set and integrator, i.e., that are added coherently. The [[sf_chain]] subobject is a realization of the beam and structure-function configuration in the [[process]] object. It is not used for calculation directly but serves as the template for the sf-chain instances that are contained in the [[component]] objects. The [[kinematics]] array contains the set of phase-space points that are associated with the current calculation. The entries may correspond to different process components and terms. (TODO wk 19-02-22: Not implemented yet.) TODO wk 19-02-22: May include extra arrays for storing (squared) amplitude data. The [[term]] data set may be reduced to just results, or be removed altogether. The [[term]] subobjects are workspace for evaluating kinematics, matrix elements, cuts etc. The array entries correspond to the [[term]] configuration entries in the associated process object. The [[mci_work]] subobject contains the array of real input parameters (random numbers) that generates the kinematical point. It also contains the workspace for the MC integrators. The active entry of the [[mci_work]] array is selected by the [[i_mci]] index above. The [[hook]] pointer accesses a list of after evaluate objects which are evalutated after the matrix element. <>= public :: process_instance_t <>= type, extends (mci_sampler_t) :: process_instance_t type(process_t), pointer :: process => null () class(pcm_t), pointer :: pcm => null () class(pcm_workspace_t), allocatable :: pcm_work integer :: evaluation_status = STAT_UNDEFINED real(default) :: sqme = 0 real(default) :: weight = 0 real(default) :: excess = 0 integer :: n_dropped = 0 integer :: i_mci = 0 integer :: selected_channel = 0 type(sf_chain_t) :: sf_chain type(kinematics_t), dimension(:), allocatable :: kin type(term_instance_t), dimension(:), allocatable :: term type(mci_work_t), dimension(:), allocatable :: mci_work class(process_instance_hook_t), pointer :: hook => null () contains <> end type process_instance_t @ %def process_instance @ Wrapper type for storing pointers to process instance objects in arrays. <>= public :: process_instance_ptr_t <>= type :: process_instance_ptr_t type(process_instance_t), pointer :: p => null () end type process_instance_ptr_t @ %def process_instance_ptr_t @ The process hooks are first-in-last-out list of objects which are evaluated after the phase space and matrixelement are evaluated. It is possible to retrieve the sampler object and read the sampler information. The hook object are part of the [[process_instance]] and therefore, share a common lifetime. A data transfer, after the usual lifetime of the [[process_instance]], is not provided, as such the finalisation procedure has to take care of this! E.g. write the object to file from which later the collected information can then be retrieved. <>= public :: process_instance_hook_t <>= type, abstract :: process_instance_hook_t class(process_instance_hook_t), pointer :: next => null () contains procedure(process_instance_hook_init), deferred :: init procedure(process_instance_hook_final), deferred :: final procedure(process_instance_hook_evaluate), deferred :: evaluate end type process_instance_hook_t @ %def process_instance_hook_t @ We have to provide a [[init]], a [[final]] procedure and, for after evaluation, the [[evaluate]] procedure. The [[init]] procedures accesses [[var_list]] and current [[instance]] object. <>= public :: process_instance_hook_final, process_instance_hook_evaluate <>= abstract interface subroutine process_instance_hook_init (hook, var_list, instance) import :: process_instance_hook_t, var_list_t, process_instance_t class(process_instance_hook_t), intent(inout), target :: hook type(var_list_t), intent(in) :: var_list class(process_instance_t), intent(in), target :: instance end subroutine process_instance_hook_init subroutine process_instance_hook_final (hook) import :: process_instance_hook_t class(process_instance_hook_t), intent(inout) :: hook end subroutine process_instance_hook_final subroutine process_instance_hook_evaluate (hook, instance) import :: process_instance_hook_t, process_instance_t class(process_instance_hook_t), intent(inout) :: hook class(process_instance_t), intent(in), target :: instance end subroutine process_instance_hook_evaluate end interface @ %def process_instance_hook_final, process_instance_hook_evaluate @ The output routine contains a header with the most relevant information about the process, copied from [[process_metadata_write]]. We mark the active components by an asterisk. The next section is the MC parameter input. The following sections are written only if the evaluation status is beyond setting the parameters, or if the [[verbose]] option is set. <>= procedure :: write_header => process_instance_write_header procedure :: write => process_instance_write <>= subroutine process_instance_write_header (object, unit, testflag) class(process_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) call write_separator (u, 2) if (associated (object%process)) then call object%process%write_meta (u, testflag) else write (u, "(1x,A)") "Process instance [undefined process]" return end if write (u, "(3x,A)", advance = "no") "status = " select case (object%evaluation_status) case (STAT_INITIAL); write (u, "(A)") "initialized" case (STAT_ACTIVATED); write (u, "(A)") "activated" case (STAT_BEAM_MOMENTA); write (u, "(A)") "beam momenta set" case (STAT_FAILED_KINEMATICS); write (u, "(A)") "failed kinematics" case (STAT_SEED_KINEMATICS); write (u, "(A)") "seed kinematics" case (STAT_HARD_KINEMATICS); write (u, "(A)") "hard kinematics" case (STAT_EFF_KINEMATICS); write (u, "(A)") "effective kinematics" case (STAT_FAILED_CUTS); write (u, "(A)") "failed cuts" case (STAT_PASSED_CUTS); write (u, "(A)") "passed cuts" case (STAT_EVALUATED_TRACE); write (u, "(A)") "evaluated trace" call write_separator (u) write (u, "(3x,A,ES19.12)") "sqme = ", object%sqme case (STAT_EVENT_COMPLETE); write (u, "(A)") "event complete" call write_separator (u) write (u, "(3x,A,ES19.12)") "sqme = ", object%sqme write (u, "(3x,A,ES19.12)") "weight = ", object%weight if (.not. vanishes (object%excess)) & write (u, "(3x,A,ES19.12)") "excess = ", object%excess case default; write (u, "(A)") "undefined" end select if (object%i_mci /= 0) then call write_separator (u) call object%mci_work(object%i_mci)%write (u, testflag) end if call write_separator (u, 2) end subroutine process_instance_write_header subroutine process_instance_write (object, unit, testflag) class(process_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u, i u = given_output_unit (unit) call object%write_header (u) if (object%evaluation_status >= STAT_BEAM_MOMENTA) then call object%sf_chain%write (u) call write_separator (u, 2) if (object%evaluation_status >= STAT_SEED_KINEMATICS) then if (object%evaluation_status >= STAT_HARD_KINEMATICS) then call write_separator (u, 2) write (u, "(1x,A)") "Active terms:" if (any (object%term%active)) then do i = 1, size (object%term) if (object%term(i)%active) then call write_separator (u) call object%term(i)%write (u, & kin = object%kin(i), & show_eff_state = & object%evaluation_status >= STAT_EFF_KINEMATICS, & testflag = testflag) end if end do end if end if call write_separator (u, 2) end if end if end subroutine process_instance_write @ %def process_instance_write_header @ %def process_instance_write @ Initialization connects the instance with a process. All initial information is transferred from the process object. The process object contains templates for the interaction subobjects (beam and term), but no evaluators. The initialization routine creates evaluators for the matrix element trace, other evaluators are left untouched. Before we start generating, we double-check if the process library has been updated after the process was initializated ([[check_library_sanity]]). This may happen if between integration and event generation the library has been recompiled, so all links become broken. The [[instance]] object must have the [[target]] attribute (also in any caller) since the initialization routine assigns various pointers to subobject of [[instance]]. <>= procedure :: init => process_instance_init <>= subroutine process_instance_init (instance, process) class(process_instance_t), intent(out), target :: instance type(process_t), intent(inout), target :: process integer :: i class(pcm_t), pointer :: pcm type(process_term_t), pointer :: term type(var_list_t), pointer :: var_list integer :: i_born, i_real, i_real_fin, i_component if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "process_instance_init") instance%process => process instance%pcm => process%get_pcm_ptr () call instance%process%check_library_sanity () call instance%setup_sf_chain (process%get_beam_config_ptr ()) allocate (instance%mci_work (process%get_n_mci ())) do i = 1, size (instance%mci_work) call instance%process%init_mci_work (instance%mci_work(i), i) end do call instance%process%reset_selected_cores () pcm => instance%process%get_pcm_ptr () call pcm%allocate_workspace (instance%pcm_work) select type (pcm) type is (pcm_nlo_t) !!! The process is kept when the integration is finalized, but not the !!! process_instance. Thus, we check whether pcm has been initialized !!! but set up the pcm_work each time. i_real_fin = process%get_associated_real_fin (1) if (.not. pcm%initialized) then i_born = pcm%get_i_core (pcm%i_born) i_real = pcm%get_i_core (pcm%i_real) call pcm%init_qn (process%get_model_ptr ()) if (i_real_fin > 0) call pcm%allocate_ps_matching () var_list => process%get_var_list_ptr () if (var_list%get_sval (var_str ("$dalitz_plot")) /= var_str ('')) & call pcm%activate_dalitz_plot (var_list%get_sval (var_str ("$dalitz_plot"))) end if pcm%initialized = .true. select type (pcm_work => instance%pcm_work) type is (pcm_nlo_workspace_t) call pcm_work%init_config (pcm, & process%component_can_be_integrated (), & process%get_nlo_type_component (), process%get_energy (), & i_real_fin, process%get_model_ptr ()) end select end select ! TODO wk-03-01 n_terms will eventually acquire a different meaning allocate (instance%kin (process%get_n_terms ())) do i = 1, process%get_n_terms () term => process%get_term_ptr (i) i_component = term%i_component call instance%kin(i)%configure (pcm, instance%pcm_work, & instance%sf_chain, & process%get_beam_config_ptr (), & process%get_phs_config (i_component), & process%get_nlo_type_component (i_component), & term%i_sub == i) end do ! TODO wk-03-01 n_terms will eventually acquire a different meaning allocate (instance%term (process%get_n_terms ())) do i = 1, process%get_n_terms () call instance%term(i)%configure (process, i, instance%pcm_work, & instance%sf_chain, instance%kin(i)) end do call instance%set_i_mci_to_real_component () call instance%find_same_kinematics () instance%evaluation_status = STAT_INITIAL end subroutine process_instance_init @ %def process_instance_init @ @ Finalize all subobjects that may contain allocated pointers. <>= procedure :: final => process_instance_final <>= subroutine process_instance_final (instance) class(process_instance_t), intent(inout) :: instance class(process_instance_hook_t), pointer :: current integer :: i instance%process => null () if (allocated (instance%mci_work)) then do i = 1, size (instance%mci_work) call instance%mci_work(i)%final () end do deallocate (instance%mci_work) end if call instance%sf_chain%final () if (allocated (instance%kin)) then do i = 1, size (instance%kin) call instance%kin(i)%final () end do deallocate (instance%kin) end if if (allocated (instance%term)) then do i = 1, size (instance%term) call instance%term(i)%final () end do deallocate (instance%term) end if call instance%pcm_work%final () instance%evaluation_status = STAT_UNDEFINED do while (associated (instance%hook)) current => instance%hook call current%final () instance%hook => current%next deallocate (current) end do instance%hook => null () end subroutine process_instance_final @ %def process_instance_final @ Revert the process instance to initial state. We do not deallocate anything, just reset the state index and deactivate all components and terms. We do not reset the choice of the MCI set [[i_mci]] unless this is required explicitly. <>= procedure :: reset => process_instance_reset <>= subroutine process_instance_reset (instance, reset_mci) class(process_instance_t), intent(inout), target :: instance logical, intent(in), optional :: reset_mci integer :: i call instance%process%reset_selected_cores () do i = 1, size (instance%term) call instance%term(i)%reset () end do instance%term%checked = .false. instance%term%passed = .false. instance%kin%new_seed = .true. if (present (reset_mci)) then if (reset_mci) instance%i_mci = 0 end if instance%selected_channel = 0 instance%evaluation_status = STAT_INITIAL end subroutine process_instance_reset @ %def process_instance_reset @ \subsubsection{Integration and event generation} The sampler test should just evaluate the squared matrix element [[n_calls]] times, discarding the results, and return. This can be done before integration, e.g., for timing estimates. <>= procedure :: sampler_test => process_instance_sampler_test <>= subroutine process_instance_sampler_test (instance, i_mci, n_calls) class(process_instance_t), intent(inout), target :: instance integer, intent(in) :: i_mci integer, intent(in) :: n_calls integer :: i_mci_work i_mci_work = instance%process%get_i_mci_work (i_mci) call instance%choose_mci (i_mci_work) call instance%reset_counter () call instance%process%sampler_test (instance, n_calls, i_mci_work) call instance%process%set_counter_mci_entry (i_mci_work, instance%get_counter ()) end subroutine process_instance_sampler_test @ %def process_instance_sampler_test @ Generate a weighted event. We select one of the available MCI integrators by its index [[i_mci]] and thus generate an event for the associated (group of) process component(s). The arguments exactly correspond to the initializer and finalizer above. The resulting event is stored in the [[process_instance]] object, which also holds the workspace of the integrator. Note: The [[process]] object contains the random-number state, which changes for each event. Otherwise, all volatile data are inside the [[instance]] object. <>= procedure :: generate_weighted_event => process_instance_generate_weighted_event <>= subroutine process_instance_generate_weighted_event (instance, i_mci) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_mci integer :: i_mci_work i_mci_work = instance%process%get_i_mci_work (i_mci) call instance%choose_mci (i_mci_work) associate (mci_work => instance%mci_work(i_mci_work)) call instance%process%generate_weighted_event & (i_mci_work, mci_work, instance, & instance%keep_failed_events ()) end associate end subroutine process_instance_generate_weighted_event @ %def process_instance_generate_weighted_event @ <>= procedure :: generate_unweighted_event => process_instance_generate_unweighted_event <>= subroutine process_instance_generate_unweighted_event (instance, i_mci) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_mci integer :: i_mci_work i_mci_work = instance%process%get_i_mci_work (i_mci) call instance%choose_mci (i_mci_work) associate (mci_work => instance%mci_work(i_mci_work)) call instance%process%generate_unweighted_event & (i_mci_work, mci_work, instance) end associate end subroutine process_instance_generate_unweighted_event @ %def process_instance_generate_unweighted_event @ This replaces the event generation methods for the situation that the process instance object has been filled by other means (i.e., reading and/or recalculating its contents). We just have to fill in missing MCI data, especially the event weight. <>= procedure :: recover_event => process_instance_recover_event <>= subroutine process_instance_recover_event (instance) class(process_instance_t), intent(inout) :: instance integer :: i_mci i_mci = instance%i_mci call instance%process%set_i_mci_work (i_mci) associate (mci_instance => instance%mci_work(i_mci)%mci) call mci_instance%fetch (instance, instance%selected_channel) end associate end subroutine process_instance_recover_event @ %def process_instance_recover_event @ @ Activate the components and terms that correspond to a currently selected MCI parameter set. <>= procedure :: activate => process_instance_activate <>= subroutine process_instance_activate (instance) class(process_instance_t), intent(inout) :: instance integer :: i, j integer, dimension(:), allocatable :: i_term associate (mci_work => instance%mci_work(instance%i_mci)) call instance%process%select_components (mci_work%get_active_components ()) end associate associate (process => instance%process) do i = 1, instance%process%get_n_components () if (instance%process%component_is_selected (i)) then allocate (i_term (size (process%get_component_i_terms (i)))) i_term = process%get_component_i_terms (i) do j = 1, size (i_term) instance%term(i_term(j))%active = .true. end do end if if (allocated (i_term)) deallocate (i_term) end do end associate instance%evaluation_status = STAT_ACTIVATED end subroutine process_instance_activate @ %def process_instance_activate @ <>= procedure :: find_same_kinematics => process_instance_find_same_kinematics <>= subroutine process_instance_find_same_kinematics (instance) class(process_instance_t), intent(inout) :: instance integer :: i_term1, i_term2, k, n_same do i_term1 = 1, size (instance%term) if (.not. allocated (instance%term(i_term1)%same_kinematics)) then n_same = 1 !!! Index group includes the index of its term_instance do i_term2 = 1, size (instance%term) if (i_term1 == i_term2) cycle if (compare_md5s (i_term1, i_term2)) n_same = n_same + 1 end do allocate (instance%term(i_term1)%same_kinematics (n_same)) associate (same_kinematics1 => instance%term(i_term1)%same_kinematics) same_kinematics1 = 0 k = 1 do i_term2 = 1, size (instance%term) if (compare_md5s (i_term1, i_term2)) then same_kinematics1(k) = i_term2 k = k + 1 end if end do do k = 1, size (same_kinematics1) if (same_kinematics1(k) == i_term1) cycle i_term2 = same_kinematics1(k) allocate (instance%term(i_term2)%same_kinematics (n_same)) instance%term(i_term2)%same_kinematics = same_kinematics1 end do end associate end if end do contains function compare_md5s (i, j) result (same) logical :: same integer, intent(in) :: i, j character(32) :: md5sum_1, md5sum_2 integer :: mode_1, mode_2 mode_1 = 0; mode_2 = 0 select type (phs => instance%kin(i)%phs%config) type is (phs_fks_config_t) md5sum_1 = phs%md5sum_born_config mode_1 = phs%mode class default md5sum_1 = phs%md5sum_phs_config end select select type (phs => instance%kin(j)%phs%config) type is (phs_fks_config_t) md5sum_2 = phs%md5sum_born_config mode_2 = phs%mode class default md5sum_2 = phs%md5sum_phs_config end select same = (md5sum_1 == md5sum_2) .and. (mode_1 == mode_2) end function compare_md5s end subroutine process_instance_find_same_kinematics @ %def process_instance_find_same_kinematics @ <>= procedure :: transfer_same_kinematics => process_instance_transfer_same_kinematics <>= subroutine process_instance_transfer_same_kinematics (instance, i_term) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_term integer :: i, i_term_same associate (same_kinematics => instance%term(i_term)%same_kinematics) do i = 1, size (same_kinematics) i_term_same = same_kinematics(i) instance%term(i_term_same)%p_seed = instance%term(i_term)%p_seed associate (phs => instance%kin(i_term_same)%phs) call phs%set_lorentz_transformation & (instance%kin(i_term)%phs%get_lorentz_transformation ()) select type (phs) type is (phs_fks_t) call phs%set_momenta (instance%term(i_term_same)%p_seed) if (i_term_same /= i_term) then call phs%set_reference_frames (.false.) end if end select end associate instance%kin(i_term_same)%new_seed = .false. end do end associate end subroutine process_instance_transfer_same_kinematics @ %def process_instance_transfer_same_kinematics @ <>= procedure :: redo_sf_chains => process_instance_redo_sf_chains <>= subroutine process_instance_redo_sf_chains (instance, i_term, phs_channel) class(process_instance_t), intent(inout) :: instance integer, intent(in), dimension(:) :: i_term integer, intent(in) :: phs_channel integer :: i do i = 1, size (i_term) call instance%kin(i_term(i))%redo_sf_chain & (instance%mci_work(instance%i_mci), phs_channel) end do end subroutine process_instance_redo_sf_chains @ %def process_instance_redo_sf_chains @ Integrate the process, using a previously initialized process instance. We select one of the available MCI integrators by its index [[i_mci]] and thus integrate over (structure functions and) phase space for the associated (group of) process component(s). <>= procedure :: integrate => process_instance_integrate <>= subroutine process_instance_integrate (instance, i_mci, n_it, n_calls, & adapt_grids, adapt_weights, final, pacify) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_mci integer, intent(in) :: n_it integer, intent(in) :: n_calls logical, intent(in), optional :: adapt_grids logical, intent(in), optional :: adapt_weights logical, intent(in), optional :: final, pacify integer :: nlo_type, i_mci_work nlo_type = instance%process%get_component_nlo_type (i_mci) i_mci_work = instance%process%get_i_mci_work (i_mci) call instance%choose_mci (i_mci_work) call instance%reset_counter () associate (mci_work => instance%mci_work(i_mci_work), & process => instance%process) call process%integrate (i_mci_work, mci_work, & instance, n_it, n_calls, adapt_grids, adapt_weights, & final, pacify, nlo_type = nlo_type) call process%set_counter_mci_entry (i_mci_work, instance%get_counter ()) end associate end subroutine process_instance_integrate @ %def process_instance_integrate @ Subroutine of the initialization above: initialize the beam and structure-function chain template. We establish pointers to the configuration data, so [[beam_config]] must have a [[target]] attribute. The resulting chain is not used directly for calculation. It will acquire instances which are stored in the process-component instance objects. <>= procedure :: setup_sf_chain => process_instance_setup_sf_chain <>= subroutine process_instance_setup_sf_chain (instance, config) class(process_instance_t), intent(inout) :: instance type(process_beam_config_t), intent(in), target :: config integer :: n_strfun n_strfun = config%n_strfun if (n_strfun /= 0) then call instance%sf_chain%init (config%data, config%sf) else call instance%sf_chain%init (config%data) end if if (config%sf_trace) then call instance%sf_chain%setup_tracing (config%sf_trace_file) end if end subroutine process_instance_setup_sf_chain @ %def process_instance_setup_sf_chain @ This initialization routine should be called only for process instances which we intend as a source for physical events. It initializes the evaluators in the parton states of the terms. They describe the (semi-)exclusive transition matrix and the distribution of color flow for the partonic process, convoluted with the beam and structure-function chain. If the model is not provided explicitly, we may use the model instance that belongs to the process. However, an explicit model allows us to override particle settings. <>= procedure :: setup_event_data => process_instance_setup_event_data <>= subroutine process_instance_setup_event_data (instance, model, i_core) class(process_instance_t), intent(inout), target :: instance class(model_data_t), intent(in), optional, target :: model integer, intent(in), optional :: i_core class(model_data_t), pointer :: current_model integer :: i class(prc_core_t), pointer :: core => null () if (present (model)) then current_model => model else current_model => instance%process%get_model_ptr () end if do i = 1, size (instance%term) associate (term => instance%term(i), kin => instance%kin(i)) if (associated (term%config)) then core => instance%process%get_core_term (i) call term%setup_event_data (kin, core, current_model) end if end associate end do core => null () end subroutine process_instance_setup_event_data @ %def process_instance_setup_event_data @ Choose a MC parameter set and the corresponding integrator. The choice persists beyond calls of the [[reset]] method above. This method is automatically called here. <>= procedure :: choose_mci => process_instance_choose_mci <>= subroutine process_instance_choose_mci (instance, i_mci) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_mci instance%i_mci = i_mci call instance%reset () end subroutine process_instance_choose_mci @ %def process_instance_choose_mci @ Explicitly set a MC parameter set. Works only if we are in initial state. We assume that the length of the parameter set is correct. After setting the parameters, activate the components and terms that correspond to the chosen MC parameter set. The [[warmup_flag]] is used when a dummy phase-space point is computed for the warmup of e.g. OpenLoops helicities. The setting of the the [[evaluation_status]] has to be avoided then. <>= procedure :: set_mcpar => process_instance_set_mcpar <>= subroutine process_instance_set_mcpar (instance, x, warmup_flag) class(process_instance_t), intent(inout) :: instance real(default), dimension(:), intent(in) :: x logical, intent(in), optional :: warmup_flag logical :: activate activate = .true.; if (present (warmup_flag)) activate = .not. warmup_flag if (instance%evaluation_status == STAT_INITIAL) then associate (mci_work => instance%mci_work(instance%i_mci)) call mci_work%set (x) end associate if (activate) call instance%activate () end if end subroutine process_instance_set_mcpar @ %def process_instance_set_mcpar @ Receive the beam momentum/momenta from a source interaction. This applies to a cascade decay process instance, where the `beam' momentum varies event by event. The master beam momentum array is contained in the main structure function chain subobject [[sf_chain]]. The sf-chain instance that reside in the components will take their beam momenta from there. The procedure transforms the instance status into [[STAT_BEAM_MOMENTA]]. For process instance with fixed beam, this intermediate status is skipped. <>= procedure :: receive_beam_momenta => process_instance_receive_beam_momenta <>= subroutine process_instance_receive_beam_momenta (instance) class(process_instance_t), intent(inout) :: instance if (instance%evaluation_status >= STAT_INITIAL) then call instance%sf_chain%receive_beam_momenta () instance%evaluation_status = STAT_BEAM_MOMENTA end if end subroutine process_instance_receive_beam_momenta @ %def process_instance_receive_beam_momenta @ Set the beam momentum/momenta explicitly. Otherwise, analogous to the previous procedure. <>= procedure :: set_beam_momenta => process_instance_set_beam_momenta <>= subroutine process_instance_set_beam_momenta (instance, p) class(process_instance_t), intent(inout) :: instance type(vector4_t), dimension(:), intent(in) :: p if (instance%evaluation_status >= STAT_INITIAL) then call instance%sf_chain%set_beam_momenta (p) instance%evaluation_status = STAT_BEAM_MOMENTA end if end subroutine process_instance_set_beam_momenta @ %def process_instance_set_beam_momenta @ Recover the initial beam momenta (those in the [[sf_chain]] component), given a valid (recovered) [[sf_chain_instance]] in one of the active components. We need to do this only if the lab frame is not the c.m.\ frame, otherwise those beams would be fixed anyway. <>= procedure :: recover_beam_momenta => process_instance_recover_beam_momenta <>= subroutine process_instance_recover_beam_momenta (instance, i_term) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_term if (.not. instance%process%lab_is_cm ()) then if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then call instance%kin(i_term)%return_beam_momenta () end if end if end subroutine process_instance_recover_beam_momenta @ %def process_instance_recover_beam_momenta @ Explicitly choose MC integration channel. We assume here that the channel count is identical for all active components. <>= procedure :: select_channel => process_instance_select_channel <>= subroutine process_instance_select_channel (instance, channel) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: channel instance%selected_channel = channel end subroutine process_instance_select_channel @ %def process_instance_select_channel @ First step of process evaluation: set up seed kinematics. That is, for each active process component, compute a momentum array from the MC input parameters. If [[skip_term]] is set, we skip the component that accesses this term. We can assume that the associated data have already been recovered, and we are just computing the rest. <>= procedure :: compute_seed_kinematics => & process_instance_compute_seed_kinematics <>= subroutine process_instance_compute_seed_kinematics & (instance, recover, skip_term) class(process_instance_t), intent(inout) :: instance logical, intent(in), optional :: recover integer, intent(in), optional :: skip_term integer :: channel, skip_component, i, j logical :: success integer, dimension(:), allocatable :: i_term channel = instance%selected_channel if (channel == 0) then call msg_bug ("Compute seed kinematics: undefined integration channel") end if if (present (skip_term)) then skip_component = instance%term(skip_term)%config%i_component else skip_component = 0 end if if (present (recover)) then if (recover) return end if if (instance%evaluation_status >= STAT_ACTIVATED) then success = .true. do i = 1, instance%process%get_n_components () if (i == skip_component) cycle if (instance%process%component_is_selected (i)) then allocate (i_term (size (instance%process%get_component_i_terms (i)))) i_term = instance%process%get_component_i_terms (i) do j = 1, size (i_term) associate (term => instance%term(i_term(j)), kin => instance%kin(i_term(j))) if (kin%new_seed) then call term%compute_seed_kinematics (kin, & instance%mci_work(instance%i_mci), channel, success) call instance%transfer_same_kinematics (i_term(j)) end if if (.not. success) exit select type (pcm => instance%pcm) class is (pcm_nlo_t) call term%evaluate_projections (kin) call kin%evaluate_radiation_kinematics & (instance%mci_work(instance%i_mci)%get_x_process ()) call kin%generate_fsr_in () call kin%compute_xi_ref_momenta (pcm%region_data, term%nlo_type) end select end associate end do end if if (allocated (i_term)) deallocate (i_term) end do if (success) then instance%evaluation_status = STAT_SEED_KINEMATICS else instance%evaluation_status = STAT_FAILED_KINEMATICS end if end if associate (mci_work => instance%mci_work(instance%i_mci)) select type (pcm_work => instance%pcm_work) class is (pcm_nlo_workspace_t) call pcm_work%set_x_rad (mci_work%get_x_process ()) end select end associate end subroutine process_instance_compute_seed_kinematics @ %def process_instance_compute_seed_kinematics @ <>= procedure :: get_x_process => process_instance_get_x_process <>= pure function process_instance_get_x_process (instance) result (x) real(default), dimension(:), allocatable :: x class(process_instance_t), intent(in) :: instance allocate (x(size (instance%mci_work(instance%i_mci)%get_x_process ()))) x = instance%mci_work(instance%i_mci)%get_x_process () end function process_instance_get_x_process @ %def process_instance_get_x_process @ <>= procedure :: get_active_component_type => process_instance_get_active_component_type <>= pure function process_instance_get_active_component_type (instance) & result (nlo_type) integer :: nlo_type class(process_instance_t), intent(in) :: instance nlo_type = instance%process%get_component_nlo_type (instance%i_mci) end function process_instance_get_active_component_type @ %def process_instance_get_active_component_type @ Inverse: recover missing parts of the kinematics from the momentum configuration, which we know for a single term and component. Given a channel, reconstruct the MC parameter set. <>= procedure :: recover_mcpar => process_instance_recover_mcpar <>= subroutine process_instance_recover_mcpar (instance, i_term) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_term integer :: channel, i if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then channel = instance%selected_channel if (channel == 0) then call msg_bug ("Recover MC parameters: undefined integration channel") end if call instance%kin(i_term)%recover_mcpar & (instance%mci_work(instance%i_mci), channel, instance%term(i_term)%p_seed) if (instance%term(i_term)%nlo_type == NLO_REAL) then do i = 1, size (instance%term) if (i /= i_term .and. instance%term(i)%nlo_type == NLO_REAL) then if (instance%term(i)%active) then call instance%kin(i)%recover_mcpar & (instance%mci_work(instance%i_mci), channel, & instance%term(i)%p_seed) end if end if end do end if end if end subroutine process_instance_recover_mcpar @ %def process_instance_recover_mcpar @ This is part of [[recover_mcpar]], extracted for the case when there is no phase space and parameters to recover, but we still need the structure function kinematics for evaluation. <>= procedure :: recover_sfchain => process_instance_recover_sfchain <>= subroutine process_instance_recover_sfchain (instance, i_term) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_term integer :: channel if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then channel = instance%selected_channel if (channel == 0) then call msg_bug ("Recover sfchain: undefined integration channel") end if call instance%kin(i_term)%recover_sfchain (channel, instance%term(i_term)%p_seed) end if end subroutine process_instance_recover_sfchain @ %def process_instance_recover_sfchain @ Second step of process evaluation: compute all momenta, for all active components, from the seed kinematics. <>= procedure :: compute_hard_kinematics => & process_instance_compute_hard_kinematics <>= subroutine process_instance_compute_hard_kinematics (instance, recover, skip_term) class(process_instance_t), intent(inout) :: instance integer, intent(in), optional :: skip_term logical, intent(in), optional :: recover integer :: i logical :: success success = .true. if (instance%evaluation_status >= STAT_SEED_KINEMATICS) then do i = 1, size (instance%term) associate (term => instance%term(i), kin => instance%kin(i)) if (term%active) then call term%compute_hard_kinematics & (kin, recover, skip_term, success) if (.not. success) exit !!! Ren scale is zero when this is commented out! Understand! if (term%nlo_type == NLO_REAL) & call kin%redo_sf_chain (instance%mci_work(instance%i_mci), & instance%selected_channel) end if end associate end do if (success) then instance%evaluation_status = STAT_HARD_KINEMATICS else instance%evaluation_status = STAT_FAILED_KINEMATICS end if end if end subroutine process_instance_compute_hard_kinematics @ %def process_instance_setup_compute_hard_kinematics @ Inverse: recover seed kinematics. We know the beam momentum configuration and the outgoing momenta of the effective interaction, for one specific term. <>= procedure :: recover_seed_kinematics => & process_instance_recover_seed_kinematics <>= subroutine process_instance_recover_seed_kinematics (instance, i_term) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_term type(vector4_t), dimension(:), allocatable :: p_seed_ref integer :: i if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then call instance%term(i_term)%recover_seed_kinematics (instance%kin(i_term)) if (instance%term(i_term)%nlo_type == NLO_REAL) then allocate (p_seed_ref (instance%term(i_term)%isolated%int_eff%get_n_out ())) p_seed_ref = instance%term(i_term)%isolated%int_eff%get_momenta & (outgoing = .true.) do i = 1, size (instance%term) if (i /= i_term .and. instance%term(i)%nlo_type == NLO_REAL) then if (instance%term(i)%active) then call instance%term(i)%recover_seed_kinematics & (instance%kin(i), p_seed_ref) end if end if end do end if end if end subroutine process_instance_recover_seed_kinematics @ %def process_instance_recover_seed_kinematics @ Third step of process evaluation: compute the effective momentum configurations, for all active terms, from the hard kinematics. <>= procedure :: compute_eff_kinematics => & process_instance_compute_eff_kinematics <>= subroutine process_instance_compute_eff_kinematics (instance, skip_term) class(process_instance_t), intent(inout) :: instance integer, intent(in), optional :: skip_term integer :: i if (instance%evaluation_status >= STAT_HARD_KINEMATICS) then do i = 1, size (instance%term) if (present (skip_term)) then if (i == skip_term) cycle end if if (instance%term(i)%active) then call instance%term(i)%compute_eff_kinematics () end if end do instance%evaluation_status = STAT_EFF_KINEMATICS end if end subroutine process_instance_compute_eff_kinematics @ %def process_instance_setup_compute_eff_kinematics @ Inverse: recover the hard kinematics from effective kinematics for one term, then compute effective kinematics for the other terms. <>= procedure :: recover_hard_kinematics => & process_instance_recover_hard_kinematics <>= subroutine process_instance_recover_hard_kinematics (instance, i_term) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_term integer :: i if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then call instance%term(i_term)%recover_hard_kinematics () do i = 1, size (instance%term) if (i /= i_term) then if (instance%term(i)%active) then call instance%term(i)%compute_eff_kinematics () end if end if end do instance%evaluation_status = STAT_EFF_KINEMATICS end if end subroutine process_instance_recover_hard_kinematics @ %def recover_hard_kinematics @ Fourth step of process evaluation: check cuts for all terms. Where successful, compute any scales and weights. Otherwise, deactive the term. If any of the terms has passed, set the state to [[STAT_PASSED_CUTS]]. The argument [[scale_forced]], if present, will override the scale calculation in the term expressions. <>= procedure :: evaluate_expressions => & process_instance_evaluate_expressions <>= subroutine process_instance_evaluate_expressions (instance, scale_forced) class(process_instance_t), intent(inout) :: instance real(default), intent(in), allocatable, optional :: scale_forced integer :: i logical :: passed_real if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then do i = 1, size (instance%term) if (instance%term(i)%active) then call instance%term(i)%evaluate_expressions (scale_forced) end if end do call evaluate_real_scales_and_cuts () call set_ellis_sexton_scale () if (.not. passed_real) then instance%evaluation_status = STAT_FAILED_CUTS else if (any (instance%term%passed)) then instance%evaluation_status = STAT_PASSED_CUTS else instance%evaluation_status = STAT_FAILED_CUTS end if end if end if contains subroutine evaluate_real_scales_and_cuts () integer :: i passed_real = .true. select type (pcm => instance%pcm) type is (pcm_nlo_t) do i = 1, size (instance%term) if (instance%term(i)%active .and. instance%term(i)%nlo_type == NLO_REAL) then if (pcm%settings%cut_all_real_sqmes) & passed_real = passed_real .and. instance%term(i)%passed if (pcm%settings%use_born_scale) & call replace_scales (instance%term(i)) end if end do end select end subroutine evaluate_real_scales_and_cuts subroutine replace_scales (this_term) type(term_instance_t), intent(inout) :: this_term integer :: i_sub i_sub = this_term%config%i_sub if (this_term%config%i_term_global /= i_sub .and. i_sub > 0) then this_term%ren_scale = instance%term(i_sub)%ren_scale this_term%fac_scale = instance%term(i_sub)%fac_scale end if end subroutine replace_scales subroutine set_ellis_sexton_scale () real(default) :: es_scale type(var_list_t), pointer :: var_list integer :: i var_list => instance%process%get_var_list_ptr () es_scale = var_list%get_rval (var_str ("ellis_sexton_scale")) do i = 1, size (instance%term) if (instance%term(i)%active .and. instance%term(i)%nlo_type == NLO_VIRTUAL) then if (es_scale > zero) then if (allocated (instance%term(i)%es_scale)) then instance%term(i)%es_scale = es_scale else allocate (instance%term(i)%es_scale, source=es_scale) end if end if end if end do end subroutine set_ellis_sexton_scale end subroutine process_instance_evaluate_expressions @ %def process_instance_evaluate_expressions @ Fifth step of process evaluation: fill the parameters for the non-selected channels, that have not been used for seeding. We should do this after evaluating cuts, since we may save some expensive calculations if the phase space point fails the cuts. If [[skip_term]] is set, we skip the component that accesses this term. We can assume that the associated data have already been recovered, and we are just computing the rest. <>= procedure :: compute_other_channels => & process_instance_compute_other_channels <>= subroutine process_instance_compute_other_channels (instance, skip_term) class(process_instance_t), intent(inout) :: instance integer, intent(in), optional :: skip_term integer :: channel, skip_component, i, j integer, dimension(:), allocatable :: i_term channel = instance%selected_channel if (channel == 0) then call msg_bug ("Compute other channels: undefined integration channel") end if if (present (skip_term)) then skip_component = instance%term(skip_term)%config%i_component else skip_component = 0 end if if (instance%evaluation_status >= STAT_PASSED_CUTS) then do i = 1, instance%process%get_n_components () if (i == skip_component) cycle if (instance%process%component_is_selected (i)) then allocate (i_term (size (instance%process%get_component_i_terms (i)))) i_term = instance%process%get_component_i_terms (i) do j = 1, size (i_term) call instance%kin(i_term(j))%compute_other_channels & (instance%mci_work(instance%i_mci), channel) end do end if if (allocated (i_term)) deallocate (i_term) end do end if end subroutine process_instance_compute_other_channels @ %def process_instance_compute_other_channels @ If not done otherwise, we flag the kinematics as new for the core state, such that the routine below will actually compute the matrix element and not just look it up. <>= procedure :: reset_core_kinematics => process_instance_reset_core_kinematics <>= subroutine process_instance_reset_core_kinematics (instance) class(process_instance_t), intent(inout) :: instance integer :: i if (instance%evaluation_status >= STAT_PASSED_CUTS) then do i = 1, size (instance%term) associate (term => instance%term(i)) if (term%active .and. term%passed) then if (allocated (term%core_state)) & call term%core_state%reset_new_kinematics () end if end associate end do end if end subroutine process_instance_reset_core_kinematics @ %def process_instance_reset_core_kinematics @ Sixth step of process evaluation: evaluate the matrix elements, and compute the trace (summed over quantum numbers) for all terms. Finally, sum up the terms, iterating over all active process components. <>= procedure :: evaluate_trace => process_instance_evaluate_trace <>= subroutine process_instance_evaluate_trace (instance, recover) class(process_instance_t), intent(inout) :: instance logical, intent(in), optional :: recover class(prc_core_t), pointer :: core => null () integer :: i, i_real_fin, i_core real(default) :: alpha_s, alpha_qed class(prc_core_t), pointer :: core_sub => null () class(model_data_t), pointer :: model => null () logical :: has_pdfs if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "process_instance_evaluate_trace") has_pdfs = instance%process%pcm_contains_pdfs () instance%sqme = zero call instance%reset_matrix_elements () if (instance%evaluation_status >= STAT_PASSED_CUTS) then do i = 1, size (instance%term) associate (term => instance%term(i), kin => instance%kin(i)) if (term%active .and. term%passed) then core => instance%process%get_core_term (i) select type (pcm => instance%process%get_pcm_ptr ()) class is (pcm_nlo_t) i_core = pcm%get_i_core (pcm%i_sub) core_sub => instance%process%get_core_ptr (i_core) end select call term%evaluate_interaction (core, kin) call term%evaluate_trace (kin) i_real_fin = instance%process%get_associated_real_fin (1) if (instance%process%uses_real_partition ()) & call term%apply_real_partition (kin, instance%process) if (term%config%i_component /= i_real_fin) then if ((term%nlo_type == NLO_REAL .and. kin%emitter < 0) & .or. term%nlo_type == NLO_MISMATCH & .or. term%nlo_type == NLO_DGLAP) & call term%set_born_sqmes (core) if (term%is_subtraction () .or. & term%nlo_type == NLO_DGLAP) & call term%set_sf_factors (kin, has_pdfs) if (term%nlo_type > BORN) then if (.not. (term%nlo_type == NLO_REAL .and. & kin%emitter >= 0)) then select type (pcm => term%pcm) type is (pcm_nlo_t) if (char (pcm%settings%nlo_correction_type) == "QCD" .or. & char (pcm%settings%nlo_correction_type) == "Full") & call term%evaluate_color_correlations (core_sub) if (char (pcm%settings%nlo_correction_type) == "EW" .or. & char (pcm%settings%nlo_correction_type) == "Full") then call term%evaluate_charge_correlations (core_sub) select type (pcm => term%pcm) type is (pcm_nlo_t) associate (reg_data => pcm%region_data) if (reg_data%alphas_power > 0) & call term%evaluate_color_correlations (core_sub) end associate end select end if end select end if if (term%is_subtraction ()) then call term%evaluate_spin_correlations (core_sub) end if end if alpha_s = core%get_alpha_s (term%core_state) alpha_qed = core%get_alpha_qed (term%core_state) if (term%nlo_type > BORN) then select type (pcm => term%pcm) type is (pcm_nlo_t) if (alpha_qed == -1 .and. (& char (pcm%settings%nlo_correction_type) == "EW" .or. & char (pcm%settings%nlo_correction_type) == "Full")) then call msg_bug("Attempting to compute EW corrections with alpha_qed = -1") end if end select end if if (present (recover)) then if (recover) return end if select case (term%nlo_type) case (NLO_REAL) call term%apply_fks (kin, alpha_s, alpha_qed) case (NLO_VIRTUAL) call term%evaluate_sqme_virt (alpha_s, alpha_qed) case (NLO_MISMATCH) call term%evaluate_sqme_mismatch (alpha_s) case (NLO_DGLAP) call term%evaluate_sqme_dglap (alpha_s, alpha_qed) end select end if end if core_sub => null () instance%sqme = instance%sqme + real (sum (& term%connected%trace%get_matrix_element () * & term%weight)) end associate end do core => null () if (instance%pcm_work%is_valid ()) then instance%evaluation_status = STAT_EVALUATED_TRACE else instance%evaluation_status = STAT_FAILED_KINEMATICS end if else !!! Failed kinematics or failed cuts: set sqme to zero instance%sqme = zero end if end subroutine process_instance_evaluate_trace @ %def process_instance_evaluate_trace <>= procedure :: set_born_sqmes => term_instance_set_born_sqmes <>= subroutine term_instance_set_born_sqmes (term, core) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(in) :: core integer :: i_flv, ii_flv real(default) :: sqme select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) do i_flv = 1, term%connected%trace%get_qn_index_n_flv () ii_flv = term%connected%trace%get_qn_index (i_flv, i_sub = 0) sqme = real (term%connected%trace%get_matrix_element (ii_flv)) select case (term%nlo_type) case (NLO_REAL) pcm_work%real_sub%sqme_born(i_flv) = sqme case (NLO_MISMATCH) pcm_work%soft_mismatch%sqme_born(i_flv) = sqme case (NLO_DGLAP) pcm_work%dglap_remnant%sqme_born(i_flv) = sqme end select end do end select end subroutine term_instance_set_born_sqmes @ %def term_instance_set_born_sqmes @ Calculates and then saves the ratio of the value of the (rescaled) real structure function chain of each ISR alpha region over the value of the corresponding underlying born flavor structure. In the case of emitter 0 we also need the rescaled ratio for emitter 1 and 2 in that region for the (soft-)collinear limits. If the emitter is 1 or 2 in some cases, e. g. for EW corrections where a photon in the proton is required, there can be the possibility of soft radiation off the initial state. For that purpose the unrescaled ratio is needed and as a default we always save these numbers in [[sf_factors(:, 0)]]. Altough this procedure is implying functionality for general structure functions, it should be reviewed for anything else besides PDFs, as there might be complications in the details. The general idea of getting the ratio in this way should hold up in these cases as well, however. <>= procedure :: set_sf_factors => term_instance_set_sf_factors <>= subroutine term_instance_set_sf_factors (term, kin, has_pdfs) class(term_instance_t), intent(inout) :: term type(kinematics_t), intent(inout) :: kin logical, intent(in) :: has_pdfs type(interaction_t), pointer :: sf_chain_int real(default) :: factor_born, factor_real integer :: n_in, alr, em integer :: i_born, i_real select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) if (.not. has_pdfs) then pcm_work%real_sub%sf_factors = one return end if select type (pcm => term%pcm) type is (pcm_nlo_t) sf_chain_int => kin%sf_chain%get_out_int_ptr () associate (reg_data => pcm%region_data) n_in = reg_data%get_n_in () do alr = 1, reg_data%n_regions em = reg_data%regions(alr)%emitter if (em <= n_in) then i_born = reg_data%regions(alr)%uborn_index i_real = reg_data%regions(alr)%real_index factor_born = sf_chain_int%get_matrix_element & (sf_chain_int%get_sf_qn_index_born (i_born, i_sub = 0)) factor_real = sf_chain_int%get_matrix_element & (sf_chain_int%get_sf_qn_index_real (i_real, i_sub = em)) call set_factor (pcm_work, alr, em, factor_born, factor_real) if (em == 0) then do em = 1, 2 factor_real = sf_chain_int%get_matrix_element & (sf_chain_int%get_sf_qn_index_real (i_real, i_sub = em)) call set_factor (pcm_work, alr, em, factor_born, factor_real) end do else factor_real = sf_chain_int%get_matrix_element & (sf_chain_int%get_sf_qn_index_real (i_real, i_sub = 0)) call set_factor (pcm_work, alr, 0, factor_born, factor_real) end if end if end do end associate end select end select contains subroutine set_factor (pcm_work, alr, em, factor_born, factor_real) type(pcm_nlo_workspace_t), intent(inout), target :: pcm_work integer, intent(in) :: alr, em real(default), intent(in) :: factor_born, factor_real real(default) :: factor if (any (vanishes ([factor_real, factor_born], tiny(1._default), tiny(1._default)))) then factor = zero else factor = factor_real / factor_born end if select case (term%nlo_type) case (NLO_REAL) pcm_work%real_sub%sf_factors(alr, em) = factor case (NLO_DGLAP) pcm_work%dglap_remnant%sf_factors(alr, em) = factor end select end subroutine end subroutine term_instance_set_sf_factors @ %def term_instance_set_sf_factors @ <>= procedure :: apply_real_partition => process_instance_apply_real_partition <>= subroutine process_instance_apply_real_partition (instance) class(process_instance_t), intent(inout) :: instance integer :: i_component, i_term integer, dimension(:), allocatable :: i_terms associate (process => instance%process) i_component = process%get_first_real_component () if (process%component_is_selected (i_component) .and. & process%get_component_nlo_type (i_component) == NLO_REAL) then allocate (i_terms (size (process%get_component_i_terms (i_component)))) i_terms = process%get_component_i_terms (i_component) do i_term = 1, size (i_terms) call instance%term(i_terms(i_term))%apply_real_partition ( & instance%kin(i_terms(i_term)), & process) end do end if if (allocated (i_terms)) deallocate (i_terms) end associate end subroutine process_instance_apply_real_partition @ %def process_instance_apply_real_partition @ <>= procedure :: set_i_mci_to_real_component => process_instance_set_i_mci_to_real_component <>= subroutine process_instance_set_i_mci_to_real_component (instance) class(process_instance_t), intent(inout) :: instance integer :: i_mci, i_component type(process_component_t), pointer :: component => null () select type (pcm_work => instance%pcm_work) type is (pcm_nlo_workspace_t) if (allocated (pcm_work%i_mci_to_real_component)) then call msg_warning ("i_mci_to_real_component already allocated - replace it") deallocate (pcm_work%i_mci_to_real_component) end if allocate (pcm_work%i_mci_to_real_component (size (instance%mci_work))) do i_mci = 1, size (instance%mci_work) do i_component = 1, instance%process%get_n_components () component => instance%process%get_component_ptr (i_component) if (component%i_mci /= i_mci) cycle select case (component%component_type) case (COMP_MASTER, COMP_REAL) pcm_work%i_mci_to_real_component (i_mci) = & component%config%get_associated_real () case (COMP_REAL_FIN) pcm_work%i_mci_to_real_component (i_mci) = & component%config%get_associated_real_fin () case (COMP_REAL_SING) pcm_work%i_mci_to_real_component (i_mci) = & component%config%get_associated_real_sing () end select end do end do component => null () end select end subroutine process_instance_set_i_mci_to_real_component @ %def process_instance_set_i_mci_to_real_component @ Final step of process evaluation: evaluate the matrix elements, and compute the trace (summed over quantum numbers) for all terms. Finally, sum up the terms, iterating over all active process components. If [[weight]] is provided, we already know the kinematical event weight (the MCI weight which depends on the kinematics sampling algorithm, but not on the matrix element), so we do not need to take it from the MCI record. <>= procedure :: evaluate_event_data => process_instance_evaluate_event_data <>= subroutine process_instance_evaluate_event_data (instance, weight) class(process_instance_t), intent(inout) :: instance real(default), intent(in), optional :: weight integer :: i if (instance%evaluation_status >= STAT_EVALUATED_TRACE) then do i = 1, size (instance%term) associate (term => instance%term(i)) if (term%active) then call term%evaluate_event_data () end if end associate end do if (present (weight)) then instance%weight = weight else instance%weight = & instance%mci_work(instance%i_mci)%mci%get_event_weight () instance%excess = & instance%mci_work(instance%i_mci)%mci%get_event_excess () end if instance%n_dropped = & instance%mci_work(instance%i_mci)%mci%get_n_event_dropped () instance%evaluation_status = STAT_EVENT_COMPLETE else !!! failed kinematics etc.: set weight to zero instance%weight = zero !!! Maybe we want to process and keep the event nevertheless if (instance%keep_failed_events ()) then do i = 1, size (instance%term) associate (term => instance%term(i)) if (term%active) then call term%evaluate_event_data () end if end associate end do ! do i = 1, size (instance%term) ! instance%term(i)%fac_scale = zero ! end do instance%evaluation_status = STAT_EVENT_COMPLETE end if end if end subroutine process_instance_evaluate_event_data @ %def process_instance_evaluate_event_data @ Computes the real-emission matrix element for externally supplied momenta for the term instance with index [[i_term]] and a phase space point set with index [[i_phs]]. In addition, for the real emission, each term instance corresponds to one emitter. Also, e.g. for Powheg, there is the possibility to supply an external $\alpha_s$. <>= procedure :: compute_sqme_rad => process_instance_compute_sqme_rad <>= subroutine process_instance_compute_sqme_rad & (instance, i_term, i_phs, is_subtraction, alpha_s_external) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_term, i_phs logical, intent(in) :: is_subtraction real(default), intent(in), optional :: alpha_s_external class(prc_core_t), pointer :: core integer :: i_real_fin logical :: has_pdfs has_pdfs = instance%process%pcm_contains_pdfs () if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "process_instance_compute_sqme_rad") select type (pcm_work => instance%pcm_work) type is (pcm_nlo_workspace_t) associate (term => instance%term(i_term), kin => instance%kin(i_term)) core => instance%process%get_core_term (i_term) if (is_subtraction) then call pcm_work%set_subtraction_event () else call pcm_work%set_radiation_event () end if call term%int_hard%set_momenta (pcm_work%get_momenta & (term%pcm, i_phs = i_phs, born_phsp = is_subtraction)) if (allocated (term%core_state)) & call term%core_state%reset_new_kinematics () if (present (alpha_s_external)) & call term%set_alpha_qcd_forced (alpha_s_external) call term%compute_eff_kinematics () call term%evaluate_expressions () call term%evaluate_interaction (core, kin) call term%evaluate_trace (kin) if (term%is_subtraction ()) then call term%set_sf_factors (kin, has_pdfs) select type (pcm => instance%pcm) type is (pcm_nlo_t) if (char (pcm%settings%nlo_correction_type) == "QCD" .or. & char (pcm%settings%nlo_correction_type) == "Full") & call term%evaluate_color_correlations (core) if (char (pcm%settings%nlo_correction_type) == "EW" .or. & char (pcm%settings%nlo_correction_type) == "Full") & call term%evaluate_charge_correlations (core) end select call term%evaluate_spin_correlations (core) end if i_real_fin = instance%process%get_associated_real_fin (1) if (term%config%i_component /= i_real_fin) & call term%apply_fks (kin, core%get_alpha_s (term%core_state), & core%get_alpha_qed (term%core_state)) if (instance%process%uses_real_partition ()) & call instance%apply_real_partition () end associate end select core => null () end subroutine process_instance_compute_sqme_rad @ %def process_instance_compute_sqme_rad @ For unweighted event generation, we should reset the reported event weight to unity (signed) or zero. The latter case is appropriate for an event which failed for whatever reason. <>= procedure :: normalize_weight => process_instance_normalize_weight <>= subroutine process_instance_normalize_weight (instance) class(process_instance_t), intent(inout) :: instance if (.not. vanishes (instance%weight)) then instance%weight = sign (1._default, instance%weight) end if end subroutine process_instance_normalize_weight @ %def process_instance_normalize_weight @ This is a convenience routine that performs the computations of the steps 1 to 5 in a single step. The arguments are the input for [[set_mcpar]]. After this, the evaluation status should be either [[STAT_FAILED_KINEMATICS]], [[STAT_FAILED_CUTS]] or [[STAT_EVALUATED_TRACE]]. Before calling this, we should call [[choose_mci]]. <>= procedure :: evaluate_sqme => process_instance_evaluate_sqme <>= subroutine process_instance_evaluate_sqme (instance, channel, x) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: channel real(default), dimension(:), intent(in) :: x call instance%reset () call instance%set_mcpar (x) call instance%select_channel (channel) call instance%compute_seed_kinematics () call instance%compute_hard_kinematics () call instance%compute_eff_kinematics () call instance%evaluate_expressions () call instance%compute_other_channels () call instance%evaluate_trace () end subroutine process_instance_evaluate_sqme @ %def process_instance_evaluate_sqme @ This is the inverse. Assuming that the final trace evaluator contains a valid momentum configuration, recover kinematics and recalculate the matrix elements and their trace. To be precise, we first recover kinematics for the given term and associated component, then recalculate from that all other terms and active components. The [[channel]] is not really required to obtain the matrix element, but it allows us to reconstruct the exact MC parameter set that corresponds to the given phase space point. Before calling this, we should call [[choose_mci]]. <>= procedure :: recover => process_instance_recover <>= subroutine process_instance_recover & (instance, channel, i_term, update_sqme, recover_phs, scale_forced) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: channel integer, intent(in) :: i_term logical, intent(in) :: update_sqme logical, intent(in) :: recover_phs real(default), intent(in), allocatable, optional :: scale_forced logical :: skip_phs, recover call instance%activate () instance%evaluation_status = STAT_EFF_KINEMATICS call instance%recover_hard_kinematics (i_term) call instance%recover_seed_kinematics (i_term) call instance%select_channel (channel) recover = instance%pcm_work%is_nlo () if (recover_phs) then call instance%recover_mcpar (i_term) call instance%recover_beam_momenta (i_term) call instance%compute_seed_kinematics & (recover = recover, skip_term = i_term) call instance%compute_hard_kinematics & (recover = recover, skip_term = i_term) call instance%compute_eff_kinematics (i_term) call instance%compute_other_channels (i_term) else call instance%recover_sfchain (i_term) end if call instance%evaluate_expressions (scale_forced) if (update_sqme) then call instance%reset_core_kinematics () call instance%evaluate_trace (recover) end if end subroutine process_instance_recover @ %def process_instance_recover @ The [[evaluate]] method is required by the [[sampler_t]] base type of which the process instance is an extension. The requirement is that after the process instance is evaluated, the integrand, the selected channel, the $x$ array, and the $f$ Jacobian array are exposed by the [[sampler_t]] object. We allow for the additional [[hook]] to be called, if associated, for outlying object to access information from the current state of the [[sampler]]. <>= procedure :: evaluate => process_instance_evaluate <>= subroutine process_instance_evaluate (sampler, c, x_in, val, x, f) class(process_instance_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f call sampler%evaluate_sqme (c, x_in) if (sampler%is_valid ()) then call sampler%fetch (val, x, f) end if call sampler%record_call () call sampler%evaluate_after_hook () end subroutine process_instance_evaluate @ %def process_instance_evaluate @ The phase-space point is valid if the event has valid kinematics and has passed the cuts. <>= procedure :: is_valid => process_instance_is_valid <>= function process_instance_is_valid (sampler) result (valid) class(process_instance_t), intent(in) :: sampler logical :: valid valid = sampler%evaluation_status >= STAT_PASSED_CUTS end function process_instance_is_valid @ %def process_instance_is_valid @ Add a [[process_instance_hook]] object.. <>= procedure :: append_after_hook => process_instance_append_after_hook <>= subroutine process_instance_append_after_hook (sampler, new_hook) class(process_instance_t), intent(inout), target :: sampler class(process_instance_hook_t), intent(inout), target :: new_hook class(process_instance_hook_t), pointer :: last if (associated (new_hook%next)) then call msg_bug ("process_instance_append_after_hook: reuse of SAME hook object is forbidden.") end if if (associated (sampler%hook)) then last => sampler%hook do while (associated (last%next)) last => last%next end do last%next => new_hook else sampler%hook => new_hook end if end subroutine process_instance_append_after_hook @ %def process_instance_append_after_evaluate_hook @ Evaluate the after hook as first in, last out. <>= procedure :: evaluate_after_hook => process_instance_evaluate_after_hook <>= subroutine process_instance_evaluate_after_hook (sampler) class(process_instance_t), intent(in) :: sampler class(process_instance_hook_t), pointer :: current current => sampler%hook do while (associated(current)) call current%evaluate (sampler) current => current%next end do end subroutine process_instance_evaluate_after_hook @ %def process_instance_evaluate_after_hook @ The [[rebuild]] method should rebuild the kinematics section out of the [[x_in]] parameter set. The integrand value [[val]] should not be computed, but is provided as input. <>= procedure :: rebuild => process_instance_rebuild <>= subroutine process_instance_rebuild (sampler, c, x_in, val, x, f) class(process_instance_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f call msg_bug ("process_instance_rebuild not implemented yet") x = 0 f = 0 end subroutine process_instance_rebuild @ %def process_instance_rebuild @ This is another method required by the [[sampler_t]] base type: fetch the data that are relevant for the MCI record. <>= procedure :: fetch => process_instance_fetch <>= subroutine process_instance_fetch (sampler, val, x, f) class(process_instance_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f integer, dimension(:), allocatable :: i_terms integer :: i, i_term_base, cc integer :: n_channel val = 0 associate (process => sampler%process) FIND_COMPONENT: do i = 1, process%get_n_components () if (sampler%process%component_is_selected (i)) then allocate (i_terms (size (process%get_component_i_terms (i)))) i_terms = process%get_component_i_terms (i) i_term_base = i_terms(1) associate (k => sampler%kin(i_term_base)) n_channel = k%n_channel do cc = 1, n_channel call k%get_mcpar (cc, x(:,cc)) end do f = k%f val = sampler%sqme * k%phs_factor end associate if (allocated (i_terms)) deallocate (i_terms) exit FIND_COMPONENT end if end do FIND_COMPONENT end associate end subroutine process_instance_fetch @ %def process_instance_fetch @ Initialize and finalize event generation for the specified MCI entry. <>= procedure :: init_simulation => process_instance_init_simulation procedure :: final_simulation => process_instance_final_simulation <>= subroutine process_instance_init_simulation (instance, i_mci, & safety_factor, keep_failed_events) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_mci real(default), intent(in), optional :: safety_factor logical, intent(in), optional :: keep_failed_events call instance%mci_work(i_mci)%init_simulation (safety_factor, keep_failed_events) end subroutine process_instance_init_simulation subroutine process_instance_final_simulation (instance, i_mci) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_mci call instance%mci_work(i_mci)%final_simulation () end subroutine process_instance_final_simulation @ %def process_instance_init_simulation @ %def process_instance_final_simulation @ \subsubsection{Accessing the process instance} Once the seed kinematics is complete, we can retrieve the MC input parameters for all channels, not just the seed channel. Note: We choose the first active component. This makes sense only if the seed kinematics is identical for all active components. <>= procedure :: get_mcpar => process_instance_get_mcpar <>= subroutine process_instance_get_mcpar (instance, channel, x) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: channel real(default), dimension(:), intent(out) :: x integer :: i if (instance%evaluation_status >= STAT_SEED_KINEMATICS) then do i = 1, size (instance%term) if (instance%term(i)%active) then call instance%kin(i)%get_mcpar (channel, x) return end if end do call msg_bug ("Process instance: get_mcpar: no active channels") else call msg_bug ("Process instance: get_mcpar: no seed kinematics") end if end subroutine process_instance_get_mcpar @ %def process_instance_get_mcpar @ Return true if the [[sqme]] value is known. This also implies that the event is kinematically valid and has passed all cuts. <>= procedure :: has_evaluated_trace => process_instance_has_evaluated_trace <>= function process_instance_has_evaluated_trace (instance) result (flag) class(process_instance_t), intent(in) :: instance logical :: flag flag = instance%evaluation_status >= STAT_EVALUATED_TRACE end function process_instance_has_evaluated_trace @ %def process_instance_has_evaluated_trace @ Return true if the event is complete. In particular, the event must be kinematically valid, passed all cuts, and the event data have been computed. <>= procedure :: is_complete_event => process_instance_is_complete_event <>= function process_instance_is_complete_event (instance) result (flag) class(process_instance_t), intent(in) :: instance logical :: flag flag = instance%evaluation_status >= STAT_EVENT_COMPLETE end function process_instance_is_complete_event @ %def process_instance_is_complete_event @ Select the term for the process instance that will provide the basic event record (used in [[evt_trivial_make_particle_set]]). It might be necessary to write out additional events corresponding to other terms (done in [[evt_nlo]]). <>= procedure :: select_i_term => process_instance_select_i_term <>= function process_instance_select_i_term (instance) result (i_term) integer :: i_term class(process_instance_t), intent(in) :: instance integer :: i_mci i_mci = instance%i_mci i_term = instance%process%select_i_term (i_mci) end function process_instance_select_i_term @ %def process_instance_select_i_term @ Return pointer to the master beam interaction. <>= procedure :: get_beam_int_ptr => process_instance_get_beam_int_ptr <>= function process_instance_get_beam_int_ptr (instance) result (ptr) class(process_instance_t), intent(in), target :: instance type(interaction_t), pointer :: ptr ptr => instance%sf_chain%get_beam_int_ptr () end function process_instance_get_beam_int_ptr @ %def process_instance_get_beam_int_ptr @ Return pointers to the matrix and flows interactions, given a term index. <>= procedure :: get_trace_int_ptr => process_instance_get_trace_int_ptr procedure :: get_matrix_int_ptr => process_instance_get_matrix_int_ptr procedure :: get_flows_int_ptr => process_instance_get_flows_int_ptr <>= function process_instance_get_trace_int_ptr (instance, i_term) result (ptr) class(process_instance_t), intent(in), target :: instance integer, intent(in) :: i_term type(interaction_t), pointer :: ptr ptr => instance%term(i_term)%connected%get_trace_int_ptr () end function process_instance_get_trace_int_ptr function process_instance_get_matrix_int_ptr (instance, i_term) result (ptr) class(process_instance_t), intent(in), target :: instance integer, intent(in) :: i_term type(interaction_t), pointer :: ptr ptr => instance%term(i_term)%connected%get_matrix_int_ptr () end function process_instance_get_matrix_int_ptr function process_instance_get_flows_int_ptr (instance, i_term) result (ptr) class(process_instance_t), intent(in), target :: instance integer, intent(in) :: i_term type(interaction_t), pointer :: ptr ptr => instance%term(i_term)%connected%get_flows_int_ptr () end function process_instance_get_flows_int_ptr @ %def process_instance_get_trace_int_ptr @ %def process_instance_get_matrix_int_ptr @ %def process_instance_get_flows_int_ptr @ Return the complete account of flavor combinations in the underlying interaction object, including beams, radiation, and hard interaction. <>= procedure :: get_state_flv => process_instance_get_state_flv <>= function process_instance_get_state_flv (instance, i_term) result (state_flv) class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term type(state_flv_content_t) :: state_flv state_flv = instance%term(i_term)%connected%get_state_flv () end function process_instance_get_state_flv @ %def process_instance_get_state_flv @ Return pointers to the parton states of a selected term. <>= procedure :: get_isolated_state_ptr => & process_instance_get_isolated_state_ptr procedure :: get_connected_state_ptr => & process_instance_get_connected_state_ptr <>= function process_instance_get_isolated_state_ptr (instance, i_term) & result (ptr) class(process_instance_t), intent(in), target :: instance integer, intent(in) :: i_term type(isolated_state_t), pointer :: ptr ptr => instance%term(i_term)%isolated end function process_instance_get_isolated_state_ptr function process_instance_get_connected_state_ptr (instance, i_term) & result (ptr) class(process_instance_t), intent(in), target :: instance integer, intent(in) :: i_term type(connected_state_t), pointer :: ptr ptr => instance%term(i_term)%connected end function process_instance_get_connected_state_ptr @ %def process_instance_get_isolated_state_ptr @ %def process_instance_get_connected_state_ptr @ Return the indices of the beam particles and incoming partons within the currently active state matrix, respectively. <>= procedure :: get_beam_index => process_instance_get_beam_index procedure :: get_in_index => process_instance_get_in_index <>= subroutine process_instance_get_beam_index (instance, i_term, i_beam) class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term integer, dimension(:), intent(out) :: i_beam call instance%term(i_term)%connected%get_beam_index (i_beam) end subroutine process_instance_get_beam_index subroutine process_instance_get_in_index (instance, i_term, i_in) class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term integer, dimension(:), intent(out) :: i_in call instance%term(i_term)%connected%get_in_index (i_in) end subroutine process_instance_get_in_index @ %def process_instance_get_beam_index @ %def process_instance_get_in_index @ Return squared matrix element and event weight, and event weight excess where applicable. [[n_dropped]] is a number that can be nonzero when a weighted event has been generated, dropping events with zero weight (failed cuts) on the fly. <>= procedure :: get_sqme => process_instance_get_sqme procedure :: get_weight => process_instance_get_weight procedure :: get_excess => process_instance_get_excess procedure :: get_n_dropped => process_instance_get_n_dropped <>= function process_instance_get_sqme (instance, i_term) result (sqme) real(default) :: sqme class(process_instance_t), intent(in) :: instance integer, intent(in), optional :: i_term if (instance%evaluation_status >= STAT_EVALUATED_TRACE) then if (present (i_term)) then sqme = instance%term(i_term)%connected%trace%get_matrix_element (1) else sqme = instance%sqme end if else sqme = 0 end if end function process_instance_get_sqme function process_instance_get_weight (instance) result (weight) real(default) :: weight class(process_instance_t), intent(in) :: instance if (instance%evaluation_status >= STAT_EVENT_COMPLETE) then weight = instance%weight else weight = 0 end if end function process_instance_get_weight function process_instance_get_excess (instance) result (excess) real(default) :: excess class(process_instance_t), intent(in) :: instance if (instance%evaluation_status >= STAT_EVENT_COMPLETE) then excess = instance%excess else excess = 0 end if end function process_instance_get_excess function process_instance_get_n_dropped (instance) result (n_dropped) integer :: n_dropped class(process_instance_t), intent(in) :: instance if (instance%evaluation_status >= STAT_EVENT_COMPLETE) then n_dropped = instance%n_dropped else n_dropped = 0 end if end function process_instance_get_n_dropped @ %def process_instance_get_sqme @ %def process_instance_get_weight @ %def process_instance_get_excess @ %def process_instance_get_n_dropped @ Return the currently selected MCI channel. <>= procedure :: get_channel => process_instance_get_channel <>= function process_instance_get_channel (instance) result (channel) integer :: channel class(process_instance_t), intent(in) :: instance channel = instance%selected_channel end function process_instance_get_channel @ %def process_instance_get_channel @ <>= procedure :: set_fac_scale => process_instance_set_fac_scale <>= subroutine process_instance_set_fac_scale (instance, fac_scale) class(process_instance_t), intent(inout) :: instance real(default), intent(in) :: fac_scale integer :: i_term i_term = 1 call instance%term(i_term)%set_fac_scale (fac_scale) end subroutine process_instance_set_fac_scale @ %def process_instance_set_fac_scale @ Return factorization scale and strong coupling. We have to select a term instance. <>= procedure :: get_fac_scale => process_instance_get_fac_scale procedure :: get_alpha_s => process_instance_get_alpha_s <>= function process_instance_get_fac_scale (instance, i_term) result (fac_scale) class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term real(default) :: fac_scale fac_scale = instance%term(i_term)%get_fac_scale () end function process_instance_get_fac_scale function process_instance_get_alpha_s (instance, i_term) result (alpha_s) real(default) :: alpha_s class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term class(prc_core_t), pointer :: core => null () core => instance%process%get_core_term (i_term) alpha_s = instance%term(i_term)%get_alpha_s (core) core => null () end function process_instance_get_alpha_s @ %def process_instance_get_fac_scale @ %def process_instance_get_alpha_s @ <>= procedure :: get_qcd => process_instance_get_qcd <>= function process_instance_get_qcd (process_instance) result (qcd) type(qcd_t) :: qcd class(process_instance_t), intent(in) :: process_instance qcd = process_instance%process%get_qcd () end function process_instance_get_qcd @ %def process_instance_get_qcd @ Counter. <>= procedure :: reset_counter => process_instance_reset_counter procedure :: record_call => process_instance_record_call procedure :: get_counter => process_instance_get_counter <>= subroutine process_instance_reset_counter (process_instance) class(process_instance_t), intent(inout) :: process_instance call process_instance%mci_work(process_instance%i_mci)%reset_counter () end subroutine process_instance_reset_counter subroutine process_instance_record_call (process_instance) class(process_instance_t), intent(inout) :: process_instance call process_instance%mci_work(process_instance%i_mci)%record_call & (process_instance%evaluation_status) end subroutine process_instance_record_call pure function process_instance_get_counter (process_instance) result (counter) class(process_instance_t), intent(in) :: process_instance type(process_counter_t) :: counter counter = process_instance%mci_work(process_instance%i_mci)%get_counter () end function process_instance_get_counter @ %def process_instance_reset_counter @ %def process_instance_record_call @ %def process_instance_get_counter @ Sum up the total number of calls for all MCI records. <>= procedure :: get_actual_calls_total => process_instance_get_actual_calls_total <>= pure function process_instance_get_actual_calls_total (process_instance) & result (n) class(process_instance_t), intent(in) :: process_instance integer :: n integer :: i type(process_counter_t) :: counter n = 0 do i = 1, size (process_instance%mci_work) counter = process_instance%mci_work(i)%get_counter () n = n + counter%total end do end function process_instance_get_actual_calls_total @ %def process_instance_get_actual_calls_total @ <>= procedure :: reset_matrix_elements => process_instance_reset_matrix_elements <>= subroutine process_instance_reset_matrix_elements (instance) class(process_instance_t), intent(inout) :: instance integer :: i_term do i_term = 1, size (instance%term) call instance%term(i_term)%connected%trace%set_matrix_element (cmplx (0, 0, default)) call instance%term(i_term)%connected%matrix%set_matrix_element (cmplx (0, 0, default)) end do end subroutine process_instance_reset_matrix_elements @ %def process_instance_reset_matrix_elements @ <>= procedure :: get_test_phase_space_point & => process_instance_get_test_phase_space_point <>= subroutine process_instance_get_test_phase_space_point (instance, & i_component, i_core, p) type(vector4_t), dimension(:), allocatable, intent(out) :: p class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_component, i_core real(default), dimension(:), allocatable :: x logical :: success integer :: i_term instance%i_mci = i_component i_term = instance%process%get_i_term (i_core) associate (term => instance%term(i_term), kin => instance%kin(i_term)) allocate (x (instance%mci_work(i_component)%config%n_par)) x = 0.5_default call instance%set_mcpar (x, .true.) call instance%select_channel (1) call term%compute_seed_kinematics & (kin, instance%mci_work(i_component), 1, success) call kin%evaluate_radiation_kinematics & (instance%mci_work(instance%i_mci)%get_x_process ()) call term%compute_hard_kinematics (kin, success = success) allocate (p (size (term%p_hard))) p = term%int_hard%get_momenta () end associate end subroutine process_instance_get_test_phase_space_point @ %def process_instance_get_test_phase_space_point @ <>= procedure :: get_p_hard => process_instance_get_p_hard <>= pure function process_instance_get_p_hard (process_instance, i_term) & result (p_hard) type(vector4_t), dimension(:), allocatable :: p_hard class(process_instance_t), intent(in) :: process_instance integer, intent(in) :: i_term allocate (p_hard (size (process_instance%term(i_term)%get_p_hard ()))) p_hard = process_instance%term(i_term)%get_p_hard () end function process_instance_get_p_hard @ %def process_instance_get_p_hard @ <>= procedure :: get_first_active_i_term => process_instance_get_first_active_i_term <>= function process_instance_get_first_active_i_term (instance) result (i_term) integer :: i_term class(process_instance_t), intent(in) :: instance integer :: i i_term = 0 do i = 1, size (instance%term) if (instance%term(i)%active) then i_term = i exit end if end do end function process_instance_get_first_active_i_term @ %def process_instance_get_first_active_i_term @ <>= procedure :: get_real_of_mci => process_instance_get_real_of_mci <>= function process_instance_get_real_of_mci (instance) result (i_real) integer :: i_real class(process_instance_t), intent(in) :: instance select type (pcm_work => instance%pcm_work) type is (pcm_nlo_workspace_t) i_real = pcm_work%i_mci_to_real_component (instance%i_mci) end select end function process_instance_get_real_of_mci @ %def process_instance_get_real_of_mci @ <>= procedure :: get_connected_states => process_instance_get_connected_states <>= function process_instance_get_connected_states (instance, i_component) result (connected) type(connected_state_t), dimension(:), allocatable :: connected class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_component connected = instance%process%get_connected_states (i_component, & instance%term(:)%connected) end function process_instance_get_connected_states @ %def process_instance_get_connected_states @ Get the hadronic center-of-mass energy <>= procedure :: get_sqrts => process_instance_get_sqrts <>= function process_instance_get_sqrts (instance) result (sqrts) class(process_instance_t), intent(in) :: instance real(default) :: sqrts sqrts = instance%process%get_sqrts () end function process_instance_get_sqrts @ %def process_instance_get_sqrts @ Get the polarizations <>= procedure :: get_polarization => process_instance_get_polarization <>= function process_instance_get_polarization (instance) result (pol) class(process_instance_t), intent(in) :: instance real(default), dimension(:), allocatable :: pol pol = instance%process%get_polarization () end function process_instance_get_polarization @ %def process_instance_get_polarization @ Get the beam spectrum <>= procedure :: get_beam_file => process_instance_get_beam_file <>= function process_instance_get_beam_file (instance) result (file) class(process_instance_t), intent(in) :: instance type(string_t) :: file file = instance%process%get_beam_file () end function process_instance_get_beam_file @ %def process_instance_get_beam_file @ Get the process name <>= procedure :: get_process_name => process_instance_get_process_name <>= function process_instance_get_process_name (instance) result (name) class(process_instance_t), intent(in) :: instance type(string_t) :: name name = instance%process%get_id () end function process_instance_get_process_name @ %def process_instance_get_process_name @ \subsubsection{Particle sets} Here we provide two procedures that convert the process instance from/to a particle set. The conversion applies to the trace evaluator which has no quantum-number information, thus it involves only the momenta and the parent-child relations. We keep virtual particles. If [[n_incoming]] is provided, the status code of the first [[n_incoming]] particles will be reset to incoming. Otherwise, they would be classified as virtual. Nevertheless, it is possible to reconstruct the complete structure from a particle set. The reconstruction implies a re-evaluation of the structure function and matrix-element codes. The [[i_term]] index is needed for both input and output, to select among different active trace evaluators. In both cases, the [[instance]] object must be properly initialized. NB: The [[recover_beams]] option should be used only when the particle set originates from an external event file, and the user has asked for it. It should be switched off when reading from raw event file. <>= procedure :: get_trace => process_instance_get_trace procedure :: set_trace => process_instance_set_trace <>= subroutine process_instance_get_trace (instance, pset, i_term, n_incoming) class(process_instance_t), intent(in), target :: instance type(particle_set_t), intent(out) :: pset integer, intent(in) :: i_term integer, intent(in), optional :: n_incoming type(interaction_t), pointer :: int logical :: ok int => instance%get_trace_int_ptr (i_term) call pset%init (ok, int, int, FM_IGNORE_HELICITY, & [0._default, 0._default], .false., .true., n_incoming) end subroutine process_instance_get_trace subroutine process_instance_set_trace & (instance, pset, i_term, recover_beams, check_match, success) class(process_instance_t), intent(inout), target :: instance type(particle_set_t), intent(in) :: pset integer, intent(in) :: i_term logical, intent(in), optional :: recover_beams, check_match logical, intent(out), optional :: success type(interaction_t), pointer :: int integer :: n_in int => instance%get_trace_int_ptr (i_term) n_in = instance%process%get_n_in () call pset%fill_interaction (int, n_in, & recover_beams = recover_beams, & check_match = check_match, & state_flv = instance%get_state_flv (i_term), & success = success) end subroutine process_instance_set_trace @ %def process_instance_get_trace @ %def process_instance_set_trace @ This procedure allows us to override any QCD setting of the WHIZARD process and directly set the coupling value that comes together with a particle set. <>= procedure :: set_alpha_qcd_forced => process_instance_set_alpha_qcd_forced <>= subroutine process_instance_set_alpha_qcd_forced (instance, i_term, alpha_qcd) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_term real(default), intent(in) :: alpha_qcd call instance%term(i_term)%set_alpha_qcd_forced (alpha_qcd) end subroutine process_instance_set_alpha_qcd_forced @ %def process_instance_set_alpha_qcd_forced @ <>= procedure :: has_nlo_component => process_instance_has_nlo_component <>= function process_instance_has_nlo_component (instance) result (nlo) class(process_instance_t), intent(in) :: instance logical :: nlo nlo = instance%process%is_nlo_calculation () end function process_instance_has_nlo_component @ %def process_instance_has_nlo_component @ <>= procedure :: keep_failed_events => process_instance_keep_failed_events <>= function process_instance_keep_failed_events (instance) result (keep) logical :: keep class(process_instance_t), intent(in) :: instance keep = instance%mci_work(instance%i_mci)%keep_failed_events end function process_instance_keep_failed_events @ %def process_instance_keep_failed_events @ <>= procedure :: get_term_indices => process_instance_get_term_indices <>= function process_instance_get_term_indices (instance, nlo_type) result (i_term) integer, dimension(:), allocatable :: i_term class(process_instance_t), intent(in) :: instance integer :: nlo_type allocate (i_term (count (instance%term%nlo_type == nlo_type))) i_term = pack (instance%term%get_i_term_global (), instance%term%nlo_type == nlo_type) end function process_instance_get_term_indices @ %def process_instance_get_term_indices @ <>= procedure :: get_boost_to_lab => process_instance_get_boost_to_lab <>= function process_instance_get_boost_to_lab (instance, i_term) result (lt) type(lorentz_transformation_t) :: lt class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term lt = instance%kin(i_term)%get_boost_to_lab () end function process_instance_get_boost_to_lab @ %def process_instance_get_boost_to_lab @ <>= procedure :: get_boost_to_cms => process_instance_get_boost_to_cms <>= function process_instance_get_boost_to_cms (instance, i_term) result (lt) type(lorentz_transformation_t) :: lt class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term lt = instance%kin(i_term)%get_boost_to_cms () end function process_instance_get_boost_to_cms @ %def process_instance_get_boost_to_cms @ <>= procedure :: lab_is_cm => process_instance_lab_is_cm <>= function process_instance_lab_is_cm (instance, i_term) result (lab_is_cm) logical :: lab_is_cm class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term lab_is_cm = instance%kin(i_term)%phs%lab_is_cm () end function process_instance_lab_is_cm @ %def process_instance_lab_is_cm @ The [[pacify]] subroutine has the purpose of setting numbers to zero which are (by comparing with a [[tolerance]] parameter) considered equivalent with zero. We do this in some unit tests. Here, we a apply this to the phase space subobject of the process instance. <>= public :: pacify <>= interface pacify module procedure pacify_process_instance end interface pacify <>= subroutine pacify_process_instance (instance) type(process_instance_t), intent(inout) :: instance integer :: i do i = 1, size (instance%kin) call pacify (instance%kin(i)%phs) end do end subroutine pacify_process_instance @ %def pacify @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Unit tests} Test module, followed by the corresponding implementation module. <<[[processes_ut.f90]]>>= <> module processes_ut use unit_tests use processes_uti <> <> <> contains <> end module processes_ut @ %def processes_ut @ <<[[processes_uti.f90]]>>= <> module processes_uti <> <> use format_utils, only: write_separator use constants, only: TWOPI4 use physics_defs, only: CONV use os_interface use sm_qcd use lorentz use pdg_arrays use model_data use models use var_base, only: vars_t use variables, only: var_list_t use model_testbed, only: prepare_model use particle_specifiers, only: new_prt_spec use flavors use interactions, only: reset_interaction_counter use particles use rng_base use mci_base use mci_none, only: mci_none_t use mci_midpoint use sf_mappings use sf_base use phs_base use phs_single use phs_forests, only: syntax_phs_forest_init, syntax_phs_forest_final use phs_wood, only: phs_wood_config_t use resonances, only: resonance_history_set_t use process_constants use prc_core_def, only: prc_core_def_t use prc_core use prc_test, only: prc_test_create_library use prc_template_me, only: template_me_def_t use process_libraries use prc_test_core use process_counter use process_config, only: process_term_t use process, only: process_t use instances, only: process_instance_t, process_instance_hook_t use rng_base_ut, only: rng_test_factory_t use sf_base_ut, only: sf_test_data_t use mci_base_ut, only: mci_test_t use phs_base_ut, only: phs_test_config_t <> <> <> <> contains <> <> end module processes_uti @ %def processes_uti @ API: driver for the unit tests below. <>= public :: processes_test <>= subroutine processes_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine processes_test @ %def processes_test \subsubsection{Write an empty process object} The most trivial test is to write an uninitialized process object. <>= call test (processes_1, "processes_1", & "write an empty process object", & u, results) <>= public :: processes_1 <>= subroutine processes_1 (u) integer, intent(in) :: u type(process_t) :: process write (u, "(A)") "* Test output: processes_1" write (u, "(A)") "* Purpose: display an empty process object" write (u, "(A)") call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Test output end: processes_1" end subroutine processes_1 @ %def processes_1 @ \subsubsection{Initialize a process object} Initialize a process and display it. <>= call test (processes_2, "processes_2", & "initialize a simple process object", & u, results) <>= public :: processes_2 <>= subroutine processes_2 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable :: process class(mci_t), allocatable :: mci_template class(phs_config_t), allocatable :: phs_config_template write (u, "(A)") "* Test output: processes_2" write (u, "(A)") "* Purpose: initialize a simple process object" write (u, "(A)") write (u, "(A)") "* Build and load a test library with one process" write (u, "(A)") libname = "processes2" procname = libname call os_data%init () call prc_test_create_library (libname, lib) write (u, "(A)") "* Initialize a process object" write (u, "(A)") call model%init_test () allocate (process) call process%init (procname, lib, os_data, model) call process%set_run_id (var_str ("run_2")) call process%setup_test_cores () allocate (phs_test_config_t :: phs_config_template) call process%init_components (phs_config_template) call process%setup_mci (dispatch_mci_empty) call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Cleanup" call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_2" end subroutine processes_2 @ %def processes_2 @ Trivial for testing: do not allocate the MCI record. <>= subroutine dispatch_mci_empty (mci, var_list, process_id, is_nlo) class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo end subroutine dispatch_mci_empty @ %def dispatch_mci_empty @ \subsubsection{Compute a trivial matrix element} Initialize a process, retrieve some information and compute a matrix element. We use the same trivial process as for the previous test. All momentum and state dependence is trivial, so we just test basic functionality. <>= call test (processes_3, "processes_3", & "retrieve a trivial matrix element", & u, results) <>= public :: processes_3 <>= subroutine processes_3 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable :: process class(phs_config_t), allocatable :: phs_config_template type(process_constants_t) :: data type(vector4_t), dimension(:), allocatable :: p write (u, "(A)") "* Test output: processes_3" write (u, "(A)") "* Purpose: create a process & &and compute a matrix element" write (u, "(A)") write (u, "(A)") "* Build and load a test library with one process" write (u, "(A)") libname = "processes3" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call model%init_test () allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_test_config_t :: phs_config_template) call process%init_components (phs_config_template) call process%setup_mci (dispatch_mci_test3) write (u, "(A)") "* Return the number of process components" write (u, "(A)") write (u, "(A,I0)") "n_components = ", process%get_n_components () write (u, "(A)") write (u, "(A)") "* Return the number of flavor states" write (u, "(A)") data = process%get_constants (1) write (u, "(A,I0)") "n_flv(1) = ", data%n_flv write (u, "(A)") write (u, "(A)") "* Return the first flavor state" write (u, "(A)") write (u, "(A,4(1x,I0))") "flv_state(1) =", data%flv_state (:,1) write (u, "(A)") write (u, "(A)") "* Set up kinematics & &[arbitrary, the matrix element is constant]" allocate (p (4)) write (u, "(A)") write (u, "(A)") "* Retrieve the matrix element" write (u, "(A)") write (u, "(A,F5.3,' + ',F5.3,' I')") "me (1, p, 1, 1, 1) = ", & process%compute_amplitude (1, 1, 1, p, 1, 1, 1) write (u, "(A)") write (u, "(A)") "* Cleanup" call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_3" end subroutine processes_3 @ %def processes_3 @ MCI record with some contents. <>= subroutine dispatch_mci_test3 (mci, var_list, process_id, is_nlo) class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo allocate (mci_test_t :: mci) select type (mci) type is (mci_test_t) call mci%set_dimensions (2, 2) call mci%set_divisions (100) end select end subroutine dispatch_mci_test3 @ %def dispatch_mci_test3 @ \subsubsection{Generate a process instance} Initialize a process and process instance, choose a sampling point and fill the process instance. We use the same trivial process as for the previous test. All momentum and state dependence is trivial, so we just test basic functionality. <>= call test (processes_4, "processes_4", & "create and fill a process instance (partonic event)", & u, results) <>= public :: processes_4 <>= subroutine processes_4 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts type(process_instance_t), allocatable, target :: process_instance type(particle_set_t) :: pset write (u, "(A)") "* Test output: processes_4" write (u, "(A)") "* Purpose: create a process & &and fill a process instance" write (u, "(A)") write (u, "(A)") "* Build and initialize a test process" write (u, "(A)") libname = "processes4" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call reset_interaction_counter () call model%init_test () allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_test_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Prepare a trivial beam setup" write (u, "(A)") sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_empty) write (u, "(A)") "* Complete process initialization" write (u, "(A)") call process%setup_terms () call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Create a process instance" write (u, "(A)") allocate (process_instance) call process_instance%init (process) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Inject a set of random numbers" write (u, "(A)") call process_instance%choose_mci (1) call process_instance%set_mcpar ([0._default, 0._default]) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Set up hard kinematics" write (u, "(A)") call process_instance%select_channel (1) call process_instance%compute_seed_kinematics () call process_instance%compute_hard_kinematics () call process_instance%compute_eff_kinematics () call process_instance%evaluate_expressions () call process_instance%compute_other_channels () write (u, "(A)") "* Evaluate matrix element and square" write (u, "(A)") call process_instance%evaluate_trace () call process_instance%write (u) call process_instance%get_trace (pset, 1) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Particle content:" write (u, "(A)") call write_separator (u) call pset%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Recover process instance" write (u, "(A)") allocate (process_instance) call process_instance%init (process) call process_instance%choose_mci (1) call process_instance%set_trace (pset, 1, check_match = .false.) call process_instance%activate () process_instance%evaluation_status = STAT_EFF_KINEMATICS call process_instance%recover_hard_kinematics (i_term = 1) call process_instance%recover_seed_kinematics (i_term = 1) call process_instance%select_channel (1) call process_instance%recover_mcpar (i_term = 1) call process_instance%compute_seed_kinematics (skip_term = 1) call process_instance%compute_hard_kinematics (skip_term = 1) call process_instance%compute_eff_kinematics (skip_term = 1) call process_instance%evaluate_expressions () call process_instance%compute_other_channels (skip_term = 1) call process_instance%evaluate_trace () call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call pset%final () call process_instance%final () deallocate (process_instance) call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_4" end subroutine processes_4 @ %def processes_4 @ \subsubsection{Structure function configuration} Configure structure functions (multi-channel) in a process object. <>= call test (processes_7, "processes_7", & "process configuration with structure functions", & u, results) <>= public :: processes_7 <>= subroutine processes_7 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data type(sf_config_t), dimension(:), allocatable :: sf_config type(sf_channel_t), dimension(2) :: sf_channel write (u, "(A)") "* Test output: processes_7" write (u, "(A)") "* Purpose: initialize a process with & &structure functions" write (u, "(A)") write (u, "(A)") "* Build and initialize a process object" write (u, "(A)") libname = "processes7" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call model%init_test () allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_test_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Set beam, structure functions, and mappings" write (u, "(A)") sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () pdg_in = 25 allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (process%get_model_ptr (), pdg_in) end select allocate (sf_config (2)) call sf_config(1)%init ([1], data) call sf_config(2)%init ([2], data) call process%init_sf_chain (sf_config) deallocate (sf_config) call process%test_allocate_sf_channels (3) call sf_channel(1)%init (2) call sf_channel(1)%activate_mapping ([1,2]) call process%set_sf_channel (2, sf_channel(1)) call sf_channel(2)%init (2) call sf_channel(2)%set_s_mapping ([1,2]) call process%set_sf_channel (3, sf_channel(2)) call process%setup_mci (dispatch_mci_empty) call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Cleanup" call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_7" end subroutine processes_7 @ %def processes_7 @ \subsubsection{Evaluating a process with structure function} Configure structure functions (single-channel) in a process object, create an instance, compute kinematics and evaluate. Note the order of operations when setting up structure functions and phase space. The beams are first, they determine the [[sqrts]] value. We can also set up the chain of structure functions. We then configure the phase space. From this, we can obtain information about special configurations (resonances, etc.), which we need for allocating the possible structure-function channels (parameterizations and mappings). Finally, we match phase-space channels onto structure-function channels. In the current example, this matching is trivial; we only have one structure-function channel. <>= call test (processes_8, "processes_8", & "process evaluation with structure functions", & u, results) <>= public :: processes_8 <>= subroutine processes_8 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts type(process_instance_t), allocatable, target :: process_instance type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data type(sf_config_t), dimension(:), allocatable :: sf_config type(sf_channel_t) :: sf_channel type(particle_set_t) :: pset write (u, "(A)") "* Test output: processes_8" write (u, "(A)") "* Purpose: evaluate a process with & &structure functions" write (u, "(A)") write (u, "(A)") "* Build and initialize a process object" write (u, "(A)") libname = "processes8" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call reset_interaction_counter () call model%init_test () allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_test_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Set beam, structure functions, and mappings" write (u, "(A)") sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) pdg_in = 25 allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (process%get_model_ptr (), pdg_in) end select allocate (sf_config (2)) call sf_config(1)%init ([1], data) call sf_config(2)%init ([2], data) call process%init_sf_chain (sf_config) deallocate (sf_config) call process%configure_phs () call process%test_allocate_sf_channels (1) call sf_channel%init (2) call sf_channel%activate_mapping ([1,2]) call process%set_sf_channel (1, sf_channel) write (u, "(A)") "* Complete process initialization" write (u, "(A)") call process%setup_mci (dispatch_mci_empty) call process%setup_terms () call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Create a process instance" write (u, "(A)") allocate (process_instance) call process_instance%init (process) write (u, "(A)") "* Set up kinematics and evaluate" write (u, "(A)") call process_instance%choose_mci (1) call process_instance%evaluate_sqme (1, & [0.8_default, 0.8_default, 0.1_default, 0.2_default]) call process_instance%write (u) call process_instance%get_trace (pset, 1) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Particle content:" write (u, "(A)") call write_separator (u) call pset%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Recover process instance" write (u, "(A)") call reset_interaction_counter (2) allocate (process_instance) call process_instance%init (process) call process_instance%choose_mci (1) call process_instance%set_trace (pset, 1, check_match = .false.) call process_instance%recover & (channel = 1, i_term = 1, update_sqme = .true., recover_phs = .true.) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call pset%final () call process_instance%final () deallocate (process_instance) call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_8" end subroutine processes_8 @ %def processes_8 @ \subsubsection{Multi-channel phase space and structure function} This is an extension of the previous example. This time, we have two distinct structure-function channels which are matched to the two distinct phase-space channels. <>= call test (processes_9, "processes_9", & "multichannel kinematics and structure functions", & u, results) <>= public :: processes_9 <>= subroutine processes_9 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts type(process_instance_t), allocatable, target :: process_instance type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data type(sf_config_t), dimension(:), allocatable :: sf_config type(sf_channel_t) :: sf_channel real(default), dimension(4) :: x_saved type(particle_set_t) :: pset write (u, "(A)") "* Test output: processes_9" write (u, "(A)") "* Purpose: evaluate a process with & &structure functions" write (u, "(A)") "* in a multi-channel configuration" write (u, "(A)") write (u, "(A)") "* Build and initialize a process object" write (u, "(A)") libname = "processes9" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call reset_interaction_counter () call model%init_test () allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_test_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Set beam, structure functions, and mappings" write (u, "(A)") sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) pdg_in = 25 allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (process%get_model_ptr (), pdg_in) end select allocate (sf_config (2)) call sf_config(1)%init ([1], data) call sf_config(2)%init ([2], data) call process%init_sf_chain (sf_config) deallocate (sf_config) call process%configure_phs () call process%test_allocate_sf_channels (2) call sf_channel%init (2) call process%set_sf_channel (1, sf_channel) call sf_channel%init (2) call sf_channel%activate_mapping ([1,2]) call process%set_sf_channel (2, sf_channel) call process%test_set_component_sf_channel ([1, 2]) write (u, "(A)") "* Complete process initialization" write (u, "(A)") call process%setup_mci (dispatch_mci_empty) call process%setup_terms () call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Create a process instance" write (u, "(A)") allocate (process_instance) call process_instance%init (process) write (u, "(A)") "* Set up kinematics in channel 1 and evaluate" write (u, "(A)") call process_instance%choose_mci (1) call process_instance%evaluate_sqme (1, & [0.8_default, 0.8_default, 0.1_default, 0.2_default]) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Extract MC input parameters" write (u, "(A)") write (u, "(A)") "Channel 1:" call process_instance%get_mcpar (1, x_saved) write (u, "(2x,9(1x,F7.5))") x_saved write (u, "(A)") "Channel 2:" call process_instance%get_mcpar (2, x_saved) write (u, "(2x,9(1x,F7.5))") x_saved write (u, "(A)") write (u, "(A)") "* Set up kinematics in channel 2 and evaluate" write (u, "(A)") call process_instance%evaluate_sqme (2, x_saved) call process_instance%write (u) call process_instance%get_trace (pset, 1) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Recover process instance for channel 2" write (u, "(A)") call reset_interaction_counter (2) allocate (process_instance) call process_instance%init (process) call process_instance%choose_mci (1) call process_instance%set_trace (pset, 1, check_match = .false.) call process_instance%recover & (channel = 2, i_term = 1, update_sqme = .true., recover_phs = .true.) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call pset%final () call process_instance%final () deallocate (process_instance) call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_9" end subroutine processes_9 @ %def processes_9 @ \subsubsection{Event generation} Activate the MC integrator for the process object and use it to generate a single event. Note that the test integrator does not require integration in preparation for generating events. <>= call test (processes_10, "processes_10", & "event generation", & u, results) <>= public :: processes_10 <>= subroutine processes_10 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable, target :: process class(mci_t), pointer :: mci class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts type(process_instance_t), allocatable, target :: process_instance write (u, "(A)") "* Test output: processes_10" write (u, "(A)") "* Purpose: generate events for a process without & &structure functions" write (u, "(A)") "* in a multi-channel configuration" write (u, "(A)") write (u, "(A)") "* Build and initialize a process object" write (u, "(A)") libname = "processes10" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call reset_interaction_counter () call model%init_test () allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_test_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Prepare a trivial beam setup" write (u, "(A)") sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_test10) write (u, "(A)") "* Complete process initialization" write (u, "(A)") call process%setup_terms () call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Create a process instance" write (u, "(A)") allocate (process_instance) call process_instance%init (process) write (u, "(A)") "* Generate weighted event" write (u, "(A)") call process%test_get_mci_ptr (mci) select type (mci) type is (mci_test_t) ! This ensures that the next 'random' numbers are 0.3, 0.5, 0.7 call mci%rng%init (3) ! Include the constant PHS factor in the stored maximum of the integrand call mci%set_max_factor (conv * twopi4 & / (2 * sqrt (lambda (sqrts **2, 125._default**2, 125._default**2)))) end select call process_instance%generate_weighted_event (1) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Generate unweighted event" write (u, "(A)") call process_instance%generate_unweighted_event (1) call process%test_get_mci_ptr (mci) select type (mci) type is (mci_test_t) write (u, "(A,I0)") " Success in try ", mci%tries write (u, "(A)") end select call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call process_instance%final () deallocate (process_instance) call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_10" end subroutine processes_10 @ %def processes_10 @ MCI record with some contents. <>= subroutine dispatch_mci_test10 (mci, var_list, process_id, is_nlo) class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo allocate (mci_test_t :: mci) select type (mci) type is (mci_test_t); call mci%set_divisions (100) end select end subroutine dispatch_mci_test10 @ %def dispatch_mci_test10 @ \subsubsection{Integration} Activate the MC integrator for the process object and use it to integrate over phase space. <>= call test (processes_11, "processes_11", & "integration", & u, results) <>= public :: processes_11 <>= subroutine processes_11 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable, target :: process class(mci_t), allocatable :: mci_template class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts type(process_instance_t), allocatable, target :: process_instance write (u, "(A)") "* Test output: processes_11" write (u, "(A)") "* Purpose: integrate a process without & &structure functions" write (u, "(A)") "* in a multi-channel configuration" write (u, "(A)") write (u, "(A)") "* Build and initialize a process object" write (u, "(A)") libname = "processes11" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call reset_interaction_counter () call model%init_test () allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_test_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Prepare a trivial beam setup" write (u, "(A)") sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_test10) write (u, "(A)") "* Complete process initialization" write (u, "(A)") call process%setup_terms () call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Create a process instance" write (u, "(A)") allocate (process_instance) call process_instance%init (process) write (u, "(A)") "* Integrate with default test parameters" write (u, "(A)") call process_instance%integrate (1, n_it=1, n_calls=10000) call process%final_integration (1) call process%write (.false., u) write (u, "(A)") write (u, "(A,ES13.7)") " Integral divided by phs factor = ", & process%get_integral (1) & / process_instance%kin(1)%phs_factor write (u, "(A)") write (u, "(A)") "* Cleanup" call process_instance%final () deallocate (process_instance) call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_11" end subroutine processes_11 @ %def processes_11 @ \subsubsection{Complete events} For the purpose of simplifying further tests, we implement a convenience routine that initializes a process and prepares a single event. This is a wrapup of the test [[processes_10]]. The procedure is re-exported by the [[processes_ut]] module. <>= public :: prepare_test_process <>= subroutine prepare_test_process & (process, process_instance, model, var_list, run_id) type(process_t), intent(out), target :: process type(process_instance_t), intent(out), target :: process_instance class(model_data_t), intent(in), target :: model type(var_list_t), intent(inout), optional :: var_list type(string_t), intent(in), optional :: run_id type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), allocatable, target :: process_model class(mci_t), pointer :: mci class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts libname = "processes_test" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call reset_interaction_counter () allocate (process_model) call process_model%init (model%get_name (), & model%get_n_real (), & model%get_n_complex (), & model%get_n_field (), & model%get_n_vtx ()) call process_model%copy_from (model) call process%init (procname, lib, os_data, process_model, var_list) if (present (run_id)) call process%set_run_id (run_id) call process%setup_test_cores () allocate (phs_test_config_t :: phs_config_template) call process%init_components (phs_config_template) sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_test10) call process%setup_terms () call process_instance%init (process) call process%test_get_mci_ptr (mci) select type (mci) type is (mci_test_t) ! This ensures that the next 'random' numbers are 0.3, 0.5, 0.7 call mci%rng%init (3) ! Include the constant PHS factor in the stored maximum of the integrand call mci%set_max_factor (conv * twopi4 & / (2 * sqrt (lambda (sqrts **2, 125._default**2, 125._default**2)))) end select call process%reset_library_ptr () ! avoid dangling pointer call process_model%final () end subroutine prepare_test_process @ %def prepare_test_process @ Here we do the cleanup of the process and process instance emitted by the previous routine. <>= public :: cleanup_test_process <>= subroutine cleanup_test_process (process, process_instance) type(process_t), intent(inout) :: process type(process_instance_t), intent(inout) :: process_instance call process_instance%final () call process%final () end subroutine cleanup_test_process @ %def cleanup_test_process @ This is the actual test. Prepare the test process and event, fill all evaluators, and display the results. Use a particle set as temporary storage, read kinematics and recalculate the event. <>= call test (processes_12, "processes_12", & "event post-processing", & u, results) <>= public :: processes_12 <>= subroutine processes_12 (u) integer, intent(in) :: u type(process_t), allocatable, target :: process type(process_instance_t), allocatable, target :: process_instance type(particle_set_t) :: pset type(model_data_t), target :: model write (u, "(A)") "* Test output: processes_12" write (u, "(A)") "* Purpose: generate a complete partonic event" write (u, "(A)") call model%init_test () write (u, "(A)") "* Build and initialize process and process instance & &and generate event" write (u, "(A)") allocate (process) allocate (process_instance) call prepare_test_process (process, process_instance, model, & run_id = var_str ("run_12")) call process_instance%setup_event_data (i_core = 1) call process%prepare_simulation (1) call process_instance%init_simulation (1) call process_instance%generate_weighted_event (1) call process_instance%evaluate_event_data () call process_instance%write (u) call process_instance%get_trace (pset, 1) call process_instance%final_simulation (1) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Recover kinematics and recalculate" write (u, "(A)") call reset_interaction_counter (2) allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data () call process_instance%choose_mci (1) call process_instance%set_trace (pset, 1, check_match = .false.) call process_instance%recover & (channel = 1, i_term = 1, update_sqme = .true., recover_phs = .true.) call process_instance%recover_event () call process_instance%evaluate_event_data () call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call cleanup_test_process (process, process_instance) deallocate (process_instance) deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_12" end subroutine processes_12 @ %def processes_12 @ \subsubsection{Colored interaction} This test specifically checks the transformation of process data (flavor, helicity, and color) into an interaction in a process term. We use the [[test_t]] process core (which has no nontrivial particles), but call only the [[is_allowed]] method, which always returns true. <>= call test (processes_13, "processes_13", & "colored interaction", & u, results) <>= public :: processes_13 <>= subroutine processes_13 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_data_t), target :: model type(process_term_t) :: term class(prc_core_t), allocatable :: core write (u, "(A)") "* Test output: processes_13" write (u, "(A)") "* Purpose: initialized a colored interaction" write (u, "(A)") write (u, "(A)") "* Set up a process constants block" write (u, "(A)") call os_data%init () call model%init_sm_test () allocate (test_t :: core) associate (data => term%data) data%n_in = 2 data%n_out = 3 data%n_flv = 2 data%n_hel = 2 data%n_col = 2 data%n_cin = 2 allocate (data%flv_state (5, 2)) data%flv_state (:,1) = [ 1, 21, 1, 21, 21] data%flv_state (:,2) = [ 2, 21, 2, 21, 21] allocate (data%hel_state (5, 2)) data%hel_state (:,1) = [1, 1, 1, 1, 0] data%hel_state (:,2) = [1,-1, 1,-1, 0] allocate (data%col_state (2, 5, 2)) data%col_state (:,:,1) = & reshape ([[1, 0], [2,-1], [3, 0], [2,-3], [0,0]], [2,5]) data%col_state (:,:,2) = & reshape ([[1, 0], [2,-3], [3, 0], [2,-1], [0,0]], [2,5]) allocate (data%ghost_flag (5, 2)) data%ghost_flag(1:4,:) = .false. data%ghost_flag(5,:) = .true. end associate write (u, "(A)") "* Set up the interaction" write (u, "(A)") call reset_interaction_counter () call term%setup_interaction (core, model) call term%int%basic_write (u) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_13" end subroutine processes_13 @ %def processes_13 @ \subsubsection{MD5 sums} Configure a process with structure functions (multi-channel) and compute MD5 sums <>= call test (processes_14, "processes_14", & "process configuration and MD5 sum", & u, results) <>= public :: processes_14 <>= subroutine processes_14 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data type(sf_config_t), dimension(:), allocatable :: sf_config type(sf_channel_t), dimension(3) :: sf_channel write (u, "(A)") "* Test output: processes_14" write (u, "(A)") "* Purpose: initialize a process with & &structure functions" write (u, "(A)") "* and compute MD5 sum" write (u, "(A)") write (u, "(A)") "* Build and initialize a process object" write (u, "(A)") libname = "processes7" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call lib%compute_md5sum () call model%init_test () allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_test_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Set beam, structure functions, and mappings" write (u, "(A)") sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () pdg_in = 25 allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (process%get_model_ptr (), pdg_in) end select call process%test_allocate_sf_channels (3) allocate (sf_config (2)) call sf_config(1)%init ([1], data) call sf_config(2)%init ([2], data) call process%init_sf_chain (sf_config) deallocate (sf_config) call sf_channel(1)%init (2) call process%set_sf_channel (1, sf_channel(1)) call sf_channel(2)%init (2) call sf_channel(2)%activate_mapping ([1,2]) call process%set_sf_channel (2, sf_channel(2)) call sf_channel(3)%init (2) call sf_channel(3)%set_s_mapping ([1,2]) call process%set_sf_channel (3, sf_channel(3)) call process%setup_mci (dispatch_mci_empty) call process%compute_md5sum () call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Cleanup" call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_14" end subroutine processes_14 @ %def processes_14 @ \subsubsection{Decay Process Evaluation} Initialize an evaluate a decay process. <>= call test (processes_15, "processes_15", & "decay process", & u, results) <>= public :: processes_15 <>= subroutine processes_15 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template type(process_instance_t), allocatable, target :: process_instance type(particle_set_t) :: pset write (u, "(A)") "* Test output: processes_15" write (u, "(A)") "* Purpose: initialize a decay process object" write (u, "(A)") write (u, "(A)") "* Build and load a test library with one process" write (u, "(A)") libname = "processes15" procname = libname call os_data%init () call prc_test_create_library (libname, lib, scattering = .false., & decay = .true.) call model%init_test () call model%set_par (var_str ("ff"), 0.4_default) call model%set_par (var_str ("mf"), & model%get_real (var_str ("ff")) * model%get_real (var_str ("ms"))) write (u, "(A)") "* Initialize a process object" write (u, "(A)") allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_single_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Prepare a trivial beam setup" write (u, "(A)") call process%setup_beams_decay (i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_empty) write (u, "(A)") "* Complete process initialization" write (u, "(A)") call process%setup_terms () call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Create a process instance" write (u, "(A)") call reset_interaction_counter (3) allocate (process_instance) call process_instance%init (process) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Inject a set of random numbers" write (u, "(A)") call process_instance%choose_mci (1) call process_instance%set_mcpar ([0._default, 0._default]) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Set up hard kinematics" write (u, "(A)") call process_instance%select_channel (1) call process_instance%compute_seed_kinematics () call process_instance%compute_hard_kinematics () write (u, "(A)") "* Evaluate matrix element and square" write (u, "(A)") call process_instance%compute_eff_kinematics () call process_instance%evaluate_expressions () call process_instance%compute_other_channels () call process_instance%evaluate_trace () call process_instance%write (u) call process_instance%get_trace (pset, 1) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Particle content:" write (u, "(A)") call write_separator (u) call pset%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Recover process instance" write (u, "(A)") call reset_interaction_counter (3) allocate (process_instance) call process_instance%init (process) call process_instance%choose_mci (1) call process_instance%set_trace (pset, 1, check_match = .false.) call process_instance%recover (1, 1, .true., .true.) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call pset%final () call process_instance%final () deallocate (process_instance) call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_15" end subroutine processes_15 @ %def processes_15 @ \subsubsection{Integration: decay} Activate the MC integrator for the decay object and use it to integrate over phase space. <>= call test (processes_16, "processes_16", & "decay integration", & u, results) <>= public :: processes_16 <>= subroutine processes_16 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template type(process_instance_t), allocatable, target :: process_instance write (u, "(A)") "* Test output: processes_16" write (u, "(A)") "* Purpose: integrate a process without & &structure functions" write (u, "(A)") "* in a multi-channel configuration" write (u, "(A)") write (u, "(A)") "* Build and initialize a process object" write (u, "(A)") libname = "processes16" procname = libname call os_data%init () call prc_test_create_library (libname, lib, scattering = .false., & decay = .true.) call reset_interaction_counter () call model%init_test () call model%set_par (var_str ("ff"), 0.4_default) call model%set_par (var_str ("mf"), & model%get_real (var_str ("ff")) * model%get_real (var_str ("ms"))) allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_single_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Prepare a trivial beam setup" write (u, "(A)") call process%setup_beams_decay (i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_test_midpoint) write (u, "(A)") "* Complete process initialization" write (u, "(A)") call process%setup_terms () call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Create a process instance" write (u, "(A)") allocate (process_instance) call process_instance%init (process) write (u, "(A)") "* Integrate with default test parameters" write (u, "(A)") call process_instance%integrate (1, n_it=1, n_calls=10000) call process%final_integration (1) call process%write (.false., u) write (u, "(A)") write (u, "(A,ES13.7)") " Integral divided by phs factor = ", & process%get_integral (1) & / process_instance%kin(1)%phs_factor write (u, "(A)") write (u, "(A)") "* Cleanup" call process_instance%final () deallocate (process_instance) call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_16" end subroutine processes_16 @ %def processes_16 @ MCI record prepared for midpoint integrator. <>= subroutine dispatch_mci_test_midpoint (mci, var_list, process_id, is_nlo) class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo allocate (mci_midpoint_t :: mci) end subroutine dispatch_mci_test_midpoint @ %def dispatch_mci_test_midpoint @ \subsubsection{Decay Process Evaluation} Initialize an evaluate a decay process for a moving particle. <>= call test (processes_17, "processes_17", & "decay of moving particle", & u, results) <>= public :: processes_17 <>= subroutine processes_17 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template type(process_instance_t), allocatable, target :: process_instance type(particle_set_t) :: pset type(flavor_t) :: flv_beam real(default) :: m, p, E write (u, "(A)") "* Test output: processes_17" write (u, "(A)") "* Purpose: initialize a decay process object" write (u, "(A)") write (u, "(A)") "* Build and load a test library with one process" write (u, "(A)") libname = "processes17" procname = libname call os_data%init () call prc_test_create_library (libname, lib, scattering = .false., & decay = .true.) write (u, "(A)") "* Initialize a process object" write (u, "(A)") call model%init_test () call model%set_par (var_str ("ff"), 0.4_default) call model%set_par (var_str ("mf"), & model%get_real (var_str ("ff")) * model%get_real (var_str ("ms"))) allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_single_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Prepare a trivial beam setup" write (u, "(A)") call process%setup_beams_decay (rest_frame = .false., i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_empty) write (u, "(A)") "* Complete process initialization" write (u, "(A)") call process%setup_terms () call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Create a process instance" write (u, "(A)") call reset_interaction_counter (3) allocate (process_instance) call process_instance%init (process) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Set parent momentum and random numbers" write (u, "(A)") call process_instance%choose_mci (1) call process_instance%set_mcpar ([0._default, 0._default]) call flv_beam%init (25, process%get_model_ptr ()) m = flv_beam%get_mass () p = 3 * m / 4 E = sqrt (m**2 + p**2) call process_instance%set_beam_momenta ([vector4_moving (E, p, 3)]) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Set up hard kinematics" write (u, "(A)") call process_instance%select_channel (1) call process_instance%compute_seed_kinematics () call process_instance%compute_hard_kinematics () write (u, "(A)") "* Evaluate matrix element and square" write (u, "(A)") call process_instance%compute_eff_kinematics () call process_instance%evaluate_expressions () call process_instance%compute_other_channels () call process_instance%evaluate_trace () call process_instance%write (u) call process_instance%get_trace (pset, 1) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Particle content:" write (u, "(A)") call write_separator (u) call pset%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Recover process instance" write (u, "(A)") call reset_interaction_counter (3) allocate (process_instance) call process_instance%init (process) call process_instance%choose_mci (1) call process_instance%set_trace (pset, 1, check_match = .false.) call process_instance%recover (1, 1, .true., .true.) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call pset%final () call process_instance%final () deallocate (process_instance) call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_17" end subroutine processes_17 @ %def processes_17 @ \subsubsection{Resonances in Phase Space} This test demonstrates the extraction of the resonance-history set from the generated phase space. We need a nontrivial process, but no matrix element. This is provided by the [[prc_template]] method, using the [[SM]] model. We also need the [[phs_wood]] method, otherwise we would not have resonances in the phase space configuration. <>= call test (processes_18, "processes_18", & "extract resonance history set", & u, results) <>= public :: processes_18 <>= subroutine processes_18 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(string_t) :: model_name type(os_data_t) :: os_data class(model_data_t), pointer :: model class(vars_t), pointer :: vars type(process_t), pointer :: process type(resonance_history_set_t) :: res_set integer :: i write (u, "(A)") "* Test output: processes_18" write (u, "(A)") "* Purpose: extra resonance histories" write (u, "(A)") write (u, "(A)") "* Build and load a test library with one process" write (u, "(A)") libname = "processes_18_lib" procname = "processes_18_p" call os_data%init () call syntax_phs_forest_init () model_name = "SM" model => null () call prepare_model (model, model_name, vars) write (u, "(A)") "* Initialize a process library with one process" write (u, "(A)") select type (model) class is (model_t) call prepare_resonance_test_library (lib, libname, procname, model, os_data, u) end select write (u, "(A)") write (u, "(A)") "* Initialize a process object with phase space" allocate (process) select type (model) class is (model_t) call prepare_resonance_test_process (process, lib, procname, model, os_data) end select write (u, "(A)") write (u, "(A)") "* Extract resonance history set" write (u, "(A)") call process%extract_resonance_history_set (res_set) call res_set%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call process%final () deallocate (process) call model%final () deallocate (model) call syntax_phs_forest_final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_18" end subroutine processes_18 @ %def processes_18 @ Auxiliary subroutine that constructs the process library for the above test. <>= subroutine prepare_resonance_test_library & (lib, libname, procname, model, os_data, u) type(process_library_t), target, intent(out) :: lib type(string_t), intent(in) :: libname type(string_t), intent(in) :: procname type(model_t), intent(in), target :: model type(os_data_t), intent(in) :: os_data integer, intent(in) :: u type(string_t), dimension(:), allocatable :: prt_in, prt_out class(prc_core_def_t), allocatable :: def type(process_def_entry_t), pointer :: entry call lib%init (libname) allocate (prt_in (2), prt_out (3)) prt_in = [var_str ("e+"), var_str ("e-")] prt_out = [var_str ("d"), var_str ("ubar"), var_str ("W+")] allocate (template_me_def_t :: def) select type (def) type is (template_me_def_t) call def%init (model, prt_in, prt_out, unity = .false.) end select allocate (entry) call entry%init (procname, & model_name = model%get_name (), & n_in = 2, n_components = 1) call entry%import_component (1, n_out = size (prt_out), & prt_in = new_prt_spec (prt_in), & prt_out = new_prt_spec (prt_out), & method = var_str ("template"), & variant = def) call entry%write (u) call lib%append (entry) call lib%configure (os_data) call lib%write_makefile (os_data, force = .true., verbose = .false.) call lib%clean (os_data, distclean = .false.) call lib%write_driver (force = .true.) call lib%load (os_data) end subroutine prepare_resonance_test_library @ %def prepare_resonance_test_library @ We want a test process which has been initialized up to the point where we can evaluate the matrix element. This is in fact rather complicated. We copy the steps from [[integration_setup_process]] in the [[integrate]] module, which is not available at this point. <>= subroutine prepare_resonance_test_process & (process, lib, procname, model, os_data) class(process_t), intent(out), target :: process type(process_library_t), intent(in), target :: lib type(string_t), intent(in) :: procname type(model_t), intent(in), target :: model type(os_data_t), intent(in) :: os_data class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts call process%init (procname, lib, os_data, model) allocate (phs_wood_config_t :: phs_config_template) call process%init_components (phs_config_template) call process%setup_test_cores (type_string = var_str ("template")) sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_none) call process%setup_terms () end subroutine prepare_resonance_test_process @ %def prepare_resonance_test_process @ MCI record prepared for the none (dummy) integrator. <>= subroutine dispatch_mci_none (mci, var_list, process_id, is_nlo) class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo allocate (mci_none_t :: mci) end subroutine dispatch_mci_none @ %def dispatch_mci_none @ \subsubsection{Add after evaluate hook(s)} Initialize a process and process instance, add a trivial process hook, choose a sampling point and fill the process instance. We use the same trivial process as for the previous test. All momentum and state dependence is trivial, so we just test basic functionality. <>= type, extends(process_instance_hook_t) :: process_instance_hook_test_t integer :: unit character(len=15) :: name contains procedure :: init => process_instance_hook_test_init procedure :: final => process_instance_hook_test_final procedure :: evaluate => process_instance_hook_test_evaluate end type process_instance_hook_test_t @ <>= subroutine process_instance_hook_test_init (hook, var_list, instance) class(process_instance_hook_test_t), intent(inout), target :: hook type(var_list_t), intent(in) :: var_list class(process_instance_t), intent(in), target :: instance end subroutine process_instance_hook_test_init subroutine process_instance_hook_test_final (hook) class(process_instance_hook_test_t), intent(inout) :: hook end subroutine process_instance_hook_test_final subroutine process_instance_hook_test_evaluate (hook, instance) class(process_instance_hook_test_t), intent(inout) :: hook class(process_instance_t), intent(in), target :: instance write (hook%unit, "(A)") "Execute hook:" write (hook%unit, "(2X,A,1X,A,I0,A)") hook%name, "(", len (trim (hook%name)), ")" end subroutine process_instance_hook_test_evaluate @ <>= call test (processes_19, "processes_19", & "add trivial hooks to a process instance ", & u, results) <>= public :: processes_19 <>= subroutine processes_19 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data class(model_data_t), pointer :: model type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts type(process_instance_t) :: process_instance class(process_instance_hook_t), allocatable, target :: process_instance_hook, process_instance_hook2 type(particle_set_t) :: pset write (u, "(A)") "* Test output: processes_19" write (u, "(A)") "* Purpose: allocate process instance & &and add an after evaluate hook" write (u, "(A)") write (u, "(A)") write (u, "(A)") "* Allocate a process instance" write (u, "(A)") call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Allocate hook and add to process instance" write (u, "(A)") allocate (process_instance_hook_test_t :: process_instance_hook) call process_instance%append_after_hook (process_instance_hook) allocate (process_instance_hook_test_t :: process_instance_hook2) call process_instance%append_after_hook (process_instance_hook2) select type (process_instance_hook) type is (process_instance_hook_test_t) process_instance_hook%unit = u process_instance_hook%name = "Hook 1" end select select type (process_instance_hook2) type is (process_instance_hook_test_t) process_instance_hook2%unit = u process_instance_hook2%name = "Hook 2" end select write (u, "(A)") "* Evaluate matrix element and square" write (u, "(A)") call process_instance%evaluate_after_hook () write (u, "(A)") write (u, "(A)") "* Cleanup" call process_instance_hook%final () deallocate (process_instance_hook) write (u, "(A)") write (u, "(A)") "* Test output end: processes_19" end subroutine processes_19 @ %def processes_19 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Process Stacks} For storing and handling multiple processes, we define process stacks. These are ordinary stacks where new process entries are pushed onto the top. We allow for multiple entries with identical process ID, but distinct run ID. The implementation is essentially identical to the [[prclib_stacks]] module above. Unfortunately, Fortran supports no generic programming, so we do not make use of this fact. When searching for a specific process ID, we will get (a pointer to) the topmost process entry with that ID on the stack, which was entered last. Usually, this is the best version of the process (in terms of integral, etc.) Thus the stack terminology makes sense. <<[[process_stacks.f90]]>>= <> module process_stacks <> <> use io_units use format_utils, only: write_separator use diagnostics use os_interface use sm_qcd use model_data use rng_base use variables use observables use process_libraries use process <> <> <> contains <> end module process_stacks @ %def process_stacks @ \subsection{The process entry type} A process entry is a process object, augmented by a pointer to the next entry. We do not need specific methods, all relevant methods are inherited. On higher level, processes should be prepared as process entry objects. <>= public :: process_entry_t <>= type, extends (process_t) :: process_entry_t type(process_entry_t), pointer :: next => null () end type process_entry_t @ %def process_entry_t @ \subsection{The process stack type} For easy conversion and lookup it is useful to store the filling number in the object. The content is stored as a linked list. The [[var_list]] component stores process-specific results, so they can be retrieved as (pseudo) variables. The process stack can be linked to another one. This allows us to work with stacks of local scope. <>= public :: process_stack_t <>= type :: process_stack_t integer :: n = 0 type(process_entry_t), pointer :: first => null () type(var_list_t), pointer :: var_list => null () type(process_stack_t), pointer :: next => null () contains <> end type process_stack_t @ %def process_stack_t @ Finalize partly: deallocate the process stack and variable list entries, but keep the variable list as an empty object. This way, the variable list links are kept. <>= procedure :: clear => process_stack_clear <>= subroutine process_stack_clear (stack) class(process_stack_t), intent(inout) :: stack type(process_entry_t), pointer :: process if (associated (stack%var_list)) then call stack%var_list%final () end if do while (associated (stack%first)) process => stack%first stack%first => process%next call process%final () deallocate (process) end do stack%n = 0 end subroutine process_stack_clear @ %def process_stack_clear @ Finalizer. Clear and deallocate the variable list. <>= procedure :: final => process_stack_final <>= subroutine process_stack_final (object) class(process_stack_t), intent(inout) :: object call object%clear () if (associated (object%var_list)) then deallocate (object%var_list) end if end subroutine process_stack_final @ %def process_stack_final @ Output. The processes on the stack will be ordered LIFO, i.e., backwards. <>= procedure :: write => process_stack_write <>= recursive subroutine process_stack_write (object, unit, pacify) class(process_stack_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify type(process_entry_t), pointer :: process integer :: u u = given_output_unit (unit) call write_separator (u, 2) select case (object%n) case (0) write (u, "(1x,A)") "Process stack: [empty]" call write_separator (u, 2) case default write (u, "(1x,A)") "Process stack:" process => object%first do while (associated (process)) call process%write (.false., u, pacify = pacify) process => process%next end do end select if (associated (object%next)) then write (u, "(1x,A)") "[Processes from context environment:]" call object%next%write (u, pacify) end if end subroutine process_stack_write @ %def process_stack_write @ The variable list is printed by a separate routine, since it should be linked to the global variable list, anyway. <>= procedure :: write_var_list => process_stack_write_var_list <>= subroutine process_stack_write_var_list (object, unit) class(process_stack_t), intent(in) :: object integer, intent(in), optional :: unit if (associated (object%var_list)) then - call var_list_write (object%var_list, unit) + call object%var_list%write (unit) end if end subroutine process_stack_write_var_list @ %def process_stack_write_var_list @ Short output. Since this is a stack, the default output ordering for each stack will be last-in, first-out. To enable first-in, first-out, which is more likely to be requested, there is an optional [[fifo]] argument. <>= procedure :: show => process_stack_show <>= recursive subroutine process_stack_show (object, unit, fifo) class(process_stack_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: fifo type(process_entry_t), pointer :: process logical :: reverse integer :: u, i, j u = given_output_unit (unit) reverse = .false.; if (present (fifo)) reverse = fifo select case (object%n) case (0) case default if (.not. reverse) then process => object%first do while (associated (process)) call process%show (u, verbose=.false.) process => process%next end do else do i = 1, object%n process => object%first do j = 1, object%n - i process => process%next end do call process%show (u, verbose=.false.) end do end if end select if (associated (object%next)) call object%next%show () end subroutine process_stack_show @ %def process_stack_show @ \subsection{Link} Link the current process stack to a global one. <>= procedure :: link => process_stack_link <>= subroutine process_stack_link (local_stack, global_stack) class(process_stack_t), intent(inout) :: local_stack type(process_stack_t), intent(in), target :: global_stack local_stack%next => global_stack end subroutine process_stack_link @ %def process_stack_link @ Initialize the process variable list and link the main variable list to it. <>= procedure :: init_var_list => process_stack_init_var_list <>= subroutine process_stack_init_var_list (stack, var_list) class(process_stack_t), intent(inout) :: stack type(var_list_t), intent(inout), optional :: var_list allocate (stack%var_list) if (present (var_list)) call var_list%link (stack%var_list) end subroutine process_stack_init_var_list @ %def process_stack_init_var_list @ Link the process variable list to a global variable list. <>= procedure :: link_var_list => process_stack_link_var_list <>= subroutine process_stack_link_var_list (stack, var_list) class(process_stack_t), intent(inout) :: stack type(var_list_t), intent(in), target :: var_list call stack%var_list%link (var_list) end subroutine process_stack_link_var_list @ %def process_stack_link_var_list @ \subsection{Push} We take a process pointer and push it onto the stack. The previous pointer is nullified. Subsequently, the process is `owned' by the stack and will be finalized when the stack is deleted. <>= procedure :: push => process_stack_push <>= subroutine process_stack_push (stack, process) class(process_stack_t), intent(inout) :: stack type(process_entry_t), intent(inout), pointer :: process process%next => stack%first stack%first => process process => null () stack%n = stack%n + 1 end subroutine process_stack_push @ %def process_stack_push @ Inverse: Remove the last process pointer in the list and return it. <>= procedure :: pop_last => process_stack_pop_last <>= subroutine process_stack_pop_last (stack, process) class(process_stack_t), intent(inout) :: stack type(process_entry_t), intent(inout), pointer :: process type(process_entry_t), pointer :: previous integer :: i select case (stack%n) case (:0) process => null () case (1) process => stack%first stack%first => null () stack%n = 0 case (2:) process => stack%first do i = 2, stack%n previous => process process => process%next end do previous%next => null () stack%n = stack%n - 1 end select end subroutine process_stack_pop_last @ %def process_stack_pop_last @ Initialize process variables for a given process ID, without setting values. <>= procedure :: init_result_vars => process_stack_init_result_vars <>= subroutine process_stack_init_result_vars (stack, id) class(process_stack_t), intent(inout) :: stack type(string_t), intent(in) :: id call var_list_init_num_id (stack%var_list, id) call var_list_init_process_results (stack%var_list, id) end subroutine process_stack_init_result_vars @ %def process_stack_init_result_vars @ Fill process variables with values. This is executed after the integration pass. Note: We set only integral and error. With multiple MCI records possible, the results for [[n_calls]], [[chi2]] etc. are not necessarily unique. (We might set the efficiency, though.) <>= procedure :: fill_result_vars => process_stack_fill_result_vars <>= subroutine process_stack_fill_result_vars (stack, id) class(process_stack_t), intent(inout) :: stack type(string_t), intent(in) :: id type(process_t), pointer :: process process => stack%get_process_ptr (id) if (associated (process)) then call var_list_init_num_id (stack%var_list, id, process%get_num_id ()) if (process%has_integral ()) then call var_list_init_process_results (stack%var_list, id, & integral = process%get_integral (), & error = process%get_error ()) end if else call msg_bug ("process_stack_fill_result_vars: unknown process ID") end if end subroutine process_stack_fill_result_vars @ %def process_stack_fill_result_vars @ If one of the result variables has a local image in [[var_list_local]], update the value there as well. <>= procedure :: update_result_vars => process_stack_update_result_vars <>= subroutine process_stack_update_result_vars (stack, id, var_list_local) class(process_stack_t), intent(inout) :: stack type(string_t), intent(in) :: id type(var_list_t), intent(inout) :: var_list_local call update ("integral(" // id // ")") call update ("error(" // id // ")") contains subroutine update (var_name) type(string_t), intent(in) :: var_name real(default) :: value if (var_list_local%contains (var_name, follow_link = .false.)) then value = stack%var_list%get_rval (var_name) call var_list_local%set_real (var_name, value, is_known = .true.) end if end subroutine update end subroutine process_stack_update_result_vars @ %def process_stack_update_result_vars @ \subsection{Data Access} Tell if a process exists. <>= procedure :: exists => process_stack_exists <>= function process_stack_exists (stack, id) result (flag) class(process_stack_t), intent(in) :: stack type(string_t), intent(in) :: id logical :: flag type(process_t), pointer :: process process => stack%get_process_ptr (id) flag = associated (process) end function process_stack_exists @ %def process_stack_exists @ Return a pointer to a process with specific ID. Look also at a linked stack, if necessary. <>= procedure :: get_process_ptr => process_stack_get_process_ptr <>= recursive function process_stack_get_process_ptr (stack, id) result (ptr) class(process_stack_t), intent(in) :: stack type(string_t), intent(in) :: id type(process_t), pointer :: ptr type(process_entry_t), pointer :: entry ptr => null () entry => stack%first do while (associated (entry)) if (entry%get_id () == id) then ptr => entry%process_t return end if entry => entry%next end do if (associated (stack%next)) ptr => stack%next%get_process_ptr (id) end function process_stack_get_process_ptr @ %def process_stack_get_process_ptr @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[process_stacks_ut.f90]]>>= <> module process_stacks_ut use unit_tests use process_stacks_uti <> <> contains <> end module process_stacks_ut @ %def process_stacks_ut @ <<[[process_stacks_uti.f90]]>>= <> module process_stacks_uti <> use os_interface use sm_qcd use models use model_data use variables, only: var_list_t use process_libraries use rng_base use prc_test, only: prc_test_create_library use process, only: process_t use instances, only: process_instance_t use processes_ut, only: prepare_test_process use process_stacks use rng_base_ut, only: rng_test_factory_t <> <> contains <> end module process_stacks_uti @ %def process_stacks_uti @ API: driver for the unit tests below. <>= public :: process_stacks_test <>= subroutine process_stacks_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine process_stacks_test @ %def process_stacks_test @ \subsubsection{Write an empty process stack} The most trivial test is to write an uninitialized process stack. <>= call test (process_stacks_1, "process_stacks_1", & "write an empty process stack", & u, results) <>= public :: process_stacks_1 <>= subroutine process_stacks_1 (u) integer, intent(in) :: u type(process_stack_t) :: stack write (u, "(A)") "* Test output: process_stacks_1" write (u, "(A)") "* Purpose: display an empty process stack" write (u, "(A)") call stack%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: process_stacks_1" end subroutine process_stacks_1 @ %def process_stacks_1 @ \subsubsection{Fill a process stack} Fill a process stack with two (identical) processes. <>= call test (process_stacks_2, "process_stacks_2", & "fill a process stack", & u, results) <>= public :: process_stacks_2 <>= subroutine process_stacks_2 (u) integer, intent(in) :: u type(process_stack_t) :: stack type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(var_list_t) :: var_list type(process_entry_t), pointer :: process => null () write (u, "(A)") "* Test output: process_stacks_2" write (u, "(A)") "* Purpose: fill a process stack" write (u, "(A)") write (u, "(A)") "* Build, initialize and store two test processes" write (u, "(A)") libname = "process_stacks2" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call model%init_test () call var_list%append_string (var_str ("$run_id")) call var_list%append_log (var_str ("?alphas_is_fixed"), .true.) call var_list%append_int (var_str ("seed"), 0) allocate (process) call var_list%set_string & (var_str ("$run_id"), var_str ("run1"), is_known=.true.) call process%init (procname, lib, os_data, model, var_list) call stack%push (process) allocate (process) call var_list%set_string & (var_str ("$run_id"), var_str ("run2"), is_known=.true.) call process%init (procname, lib, os_data, model, var_list) call stack%push (process) call stack%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call stack%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: process_stacks_2" end subroutine process_stacks_2 @ %def process_stacks_2 @ \subsubsection{Fill a process stack} Fill a process stack with two (identical) processes. <>= call test (process_stacks_3, "process_stacks_3", & "process variables", & u, results) <>= public :: process_stacks_3 <>= subroutine process_stacks_3 (u) integer, intent(in) :: u type(process_stack_t) :: stack type(model_t), target :: model type(string_t) :: procname type(process_entry_t), pointer :: process => null () type(process_instance_t), target :: process_instance write (u, "(A)") "* Test output: process_stacks_3" write (u, "(A)") "* Purpose: setup process variables" write (u, "(A)") write (u, "(A)") "* Initialize process variables" write (u, "(A)") procname = "processes_test" call model%init_test () write (u, "(A)") "* Initialize process variables" write (u, "(A)") call stack%init_var_list () call stack%init_result_vars (procname) call stack%write_var_list (u) write (u, "(A)") write (u, "(A)") "* Build and integrate a test process" write (u, "(A)") allocate (process) call prepare_test_process (process%process_t, process_instance, model) call process_instance%integrate (1, 1, 1000) call process_instance%final () call process%final_integration (1) call stack%push (process) write (u, "(A)") "* Fill process variables" write (u, "(A)") call stack%fill_result_vars (procname) call stack%write_var_list (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call stack%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: process_stacks_3" end subroutine process_stacks_3 @ %def process_stacks_3 @ \subsubsection{Linked a process stack} Fill two process stack, linked to each other. <>= call test (process_stacks_4, "process_stacks_4", & "linked stacks", & u, results) <>= public :: process_stacks_4 <>= subroutine process_stacks_4 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(process_stack_t), target :: stack1, stack2 type(model_t), target :: model type(string_t) :: libname type(string_t) :: procname1, procname2 type(os_data_t) :: os_data type(process_entry_t), pointer :: process => null () write (u, "(A)") "* Test output: process_stacks_4" write (u, "(A)") "* Purpose: link process stacks" write (u, "(A)") write (u, "(A)") "* Initialize process variables" write (u, "(A)") libname = "process_stacks_4_lib" procname1 = "process_stacks_4a" procname2 = "process_stacks_4b" call os_data%init () write (u, "(A)") "* Initialize first process" write (u, "(A)") call prc_test_create_library (procname1, lib) call model%init_test () allocate (process) call process%init (procname1, lib, os_data, model) call stack1%push (process) write (u, "(A)") "* Initialize second process" write (u, "(A)") call stack2%link (stack1) call prc_test_create_library (procname2, lib) allocate (process) call process%init (procname2, lib, os_data, model) call stack2%push (process) write (u, "(A)") "* Show linked stacks" write (u, "(A)") call stack2%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call stack2%final () call stack1%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: process_stacks_4" end subroutine process_stacks_4 @ %def process_stacks_4 @ Index: trunk/src/whizard-core/whizard.nw =================================================================== --- trunk/src/whizard-core/whizard.nw (revision 8782) +++ trunk/src/whizard-core/whizard.nw (revision 8783) @@ -1,29208 +1,29208 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD main code as NOWEB source \includemodulegraph{whizard-core} \chapter{Integration and Simulation} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{User-controlled File I/O} The SINDARIN language includes commands that write output to file (input may be added later). We identify files by their name, and manage the unit internally. We need procedures for opening, closing, and printing files. <<[[user_files.f90]]>>= <> module user_files <> use io_units use diagnostics use ifiles use analysis <> <> <> <> contains <> end module user_files @ %def user_files @ \subsection{The file type} This is a type that describes an open user file and its properties. The entry is part of a doubly-linked list. <>= type :: file_t private type(string_t) :: name integer :: unit = -1 logical :: reading = .false. logical :: writing = .false. type(file_t), pointer :: prev => null () type(file_t), pointer :: next => null () end type file_t @ %def file_t @ The initializer opens the file. <>= subroutine file_init (file, name, action, status, position) type(file_t), intent(out) :: file type(string_t), intent(in) :: name character(len=*), intent(in) :: action, status, position file%unit = free_unit () file%name = name open (unit = file%unit, file = char (file%name), & action = action, status = status, position = position) select case (action) case ("read") file%reading = .true. case ("write") file%writing = .true. case ("readwrite") file%reading = .true. file%writing = .true. end select end subroutine file_init @ %def file_init @ The finalizer closes it. <>= subroutine file_final (file) type(file_t), intent(inout) :: file close (unit = file%unit) file%unit = -1 end subroutine file_final @ %def file_final @ Check if a file is open with correct status. <>= function file_is_open (file, action) result (flag) logical :: flag type(file_t), intent(in) :: file character(*), intent(in) :: action select case (action) case ("read") flag = file%reading case ("write") flag = file%writing case ("readwrite") flag = file%reading .and. file%writing case default call msg_bug ("Checking file '" // char (file%name) & // "': illegal action specifier") end select end function file_is_open @ %def file_is_open @ Return the unit number of a file for direct access. It should be checked first whether the file is open. <>= function file_get_unit (file) result (unit) integer :: unit type(file_t), intent(in) :: file unit = file%unit end function file_get_unit @ %def file_get_unit @ Write to the file. Error if in wrong mode. If there is no string, just write an empty record. If there is a string, respect the [[advancing]] option. <>= subroutine file_write_string (file, string, advancing) type(file_t), intent(in) :: file type(string_t), intent(in), optional :: string logical, intent(in), optional :: advancing if (file%writing) then if (present (string)) then if (present (advancing)) then if (advancing) then write (file%unit, "(A)") char (string) else write (file%unit, "(A)", advance="no") char (string) end if else write (file%unit, "(A)") char (string) end if else write (file%unit, *) end if else call msg_error ("Writing to file: File '" // char (file%name) & // "' is not open for writing.") end if end subroutine file_write_string @ %def file_write @ Write a whole ifile, line by line. <>= subroutine file_write_ifile (file, ifile) type(file_t), intent(in) :: file type(ifile_t), intent(in) :: ifile type(line_p) :: line call line_init (line, ifile) do while (line_is_associated (line)) call file_write_string (file, line_get_string_advance (line)) end do end subroutine file_write_ifile @ %def file_write_ifile @ Write an analysis object (or all objects) to an open file. <>= subroutine file_write_analysis (file, tag) type(file_t), intent(in) :: file type(string_t), intent(in), optional :: tag if (file%writing) then if (present (tag)) then call analysis_write (tag, unit = file%unit) else call analysis_write (unit = file%unit) end if else call msg_error ("Writing analysis to file: File '" // char (file%name) & // "' is not open for writing.") end if end subroutine file_write_analysis @ %def file_write_analysis @ \subsection{The file list} We maintain a list of all open files and their attributes. The list must be doubly-linked because we may delete entries. <>= public :: file_list_t <>= type :: file_list_t type(file_t), pointer :: first => null () type(file_t), pointer :: last => null () end type file_list_t @ %def file_list_t @ There is no initialization routine, but a finalizer which deletes all: <>= public :: file_list_final <>= subroutine file_list_final (file_list) type(file_list_t), intent(inout) :: file_list type(file_t), pointer :: current do while (associated (file_list%first)) current => file_list%first file_list%first => current%next call file_final (current) deallocate (current) end do file_list%last => null () end subroutine file_list_final @ %def file_list_final @ Find an entry in the list. Return null pointer on failure. <>= function file_list_get_file_ptr (file_list, name) result (current) type(file_t), pointer :: current type(file_list_t), intent(in) :: file_list type(string_t), intent(in) :: name current => file_list%first do while (associated (current)) if (current%name == name) return current => current%next end do end function file_list_get_file_ptr @ %def file_list_get_file_ptr @ Check if a file is open, public version: <>= public :: file_list_is_open <>= function file_list_is_open (file_list, name, action) result (flag) logical :: flag type(file_list_t), intent(in) :: file_list type(string_t), intent(in) :: name character(len=*), intent(in) :: action type(file_t), pointer :: current current => file_list_get_file_ptr (file_list, name) if (associated (current)) then flag = file_is_open (current, action) else flag = .false. end if end function file_list_is_open @ %def file_list_is_open @ Return the unit number for a file. It should be checked first whether the file is open. <>= public :: file_list_get_unit <>= function file_list_get_unit (file_list, name) result (unit) integer :: unit type(file_list_t), intent(in) :: file_list type(string_t), intent(in) :: name type(file_t), pointer :: current current => file_list_get_file_ptr (file_list, name) if (associated (current)) then unit = file_get_unit (current) else unit = -1 end if end function file_list_get_unit @ %def file_list_get_unit @ Append a new file entry, i.e., open this file. Error if it is already open. <>= public :: file_list_open <>= subroutine file_list_open (file_list, name, action, status, position) type(file_list_t), intent(inout) :: file_list type(string_t), intent(in) :: name character(len=*), intent(in) :: action, status, position type(file_t), pointer :: current if (.not. associated (file_list_get_file_ptr (file_list, name))) then allocate (current) call msg_message ("Opening file '" // char (name) // "' for output") call file_init (current, name, action, status, position) if (associated (file_list%last)) then file_list%last%next => current current%prev => file_list%last else file_list%first => current end if file_list%last => current else call msg_error ("Opening file: File '" // char (name) & // "' is already open.") end if end subroutine file_list_open @ %def file_list_open @ Delete a file entry, i.e., close this file. Error if it is not open. <>= public :: file_list_close <>= subroutine file_list_close (file_list, name) type(file_list_t), intent(inout) :: file_list type(string_t), intent(in) :: name type(file_t), pointer :: current current => file_list_get_file_ptr (file_list, name) if (associated (current)) then if (associated (current%prev)) then current%prev%next => current%next else file_list%first => current%next end if if (associated (current%next)) then current%next%prev => current%prev else file_list%last => current%prev end if call msg_message ("Closing file '" // char (name) // "' for output") call file_final (current) deallocate (current) else call msg_error ("Closing file: File '" // char (name) & // "' is not open.") end if end subroutine file_list_close @ %def file_list_close @ Write a string to file. Error if it is not open. <>= public :: file_list_write <>= interface file_list_write module procedure file_list_write_string module procedure file_list_write_ifile end interface <>= subroutine file_list_write_string (file_list, name, string, advancing) type(file_list_t), intent(in) :: file_list type(string_t), intent(in) :: name type(string_t), intent(in), optional :: string logical, intent(in), optional :: advancing type(file_t), pointer :: current current => file_list_get_file_ptr (file_list, name) if (associated (current)) then call file_write_string (current, string, advancing) else call msg_error ("Writing to file: File '" // char (name) & // "'is not open.") end if end subroutine file_list_write_string subroutine file_list_write_ifile (file_list, name, ifile) type(file_list_t), intent(in) :: file_list type(string_t), intent(in) :: name type(ifile_t), intent(in) :: ifile type(file_t), pointer :: current current => file_list_get_file_ptr (file_list, name) if (associated (current)) then call file_write_ifile (current, ifile) else call msg_error ("Writing to file: File '" // char (name) & // "'is not open.") end if end subroutine file_list_write_ifile @ %def file_list_write @ Write an analysis object or all objects to data file. Error if it is not open. If the file name is empty, write to standard output. <>= public :: file_list_write_analysis <>= subroutine file_list_write_analysis (file_list, name, tag) type(file_list_t), intent(in) :: file_list type(string_t), intent(in) :: name type(string_t), intent(in), optional :: tag type(file_t), pointer :: current if (name == "") then if (present (tag)) then call analysis_write (tag) else call analysis_write end if else current => file_list_get_file_ptr (file_list, name) if (associated (current)) then call file_write_analysis (current, tag) else call msg_error ("Writing analysis to file: File '" // char (name) & // "' is not open.") end if end if end subroutine file_list_write_analysis @ %def file_list_write_analysis @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Runtime data} <<[[rt_data.f90]]>>= <> module rt_data <> <> use io_units use format_utils, only: write_separator use format_defs, only: FMT_19, FMT_12 use system_dependencies use diagnostics use os_interface use lexers use parser use models use subevents use pdg_arrays use variables, only: var_list_t use process_libraries use prclib_stacks use prc_core, only: helicity_selection_t use beam_structures use event_base, only: event_callback_t use user_files use process_stacks use iterations <> <> <> contains <> end module rt_data @ %def rt_data @ \subsection{Strategy for models and variables} The program manages its data via a main [[rt_data_t]] object. During program flow, various commands create and use local [[rt_data_t]] objects. Those transient blocks contain either pointers to global object or local copies which are deleted after use. Each [[rt_data_t]] object contains a variable list component. This lists holds (local copies of) all kinds of intrinsic or user-defined variables. The variable list is linked to the variable list contained in the local process library. This, in turn, is linked to the variable list of the [[rt_data_t]] context, and so on. A variable lookup will thus be recursively delegated to the linked variable lists, until a match is found. When modifying a variable which is not yet local, the program creates a local copy and uses this afterwards. Thus, when the local [[rt_data_t]] object is deleted, the context value is recovered. Models are kept in a model list which is separate from the variable list. Otherwise, they are treated in a similar manner: the local list is linked to the context model list. Model lookup is thus recursively delegated. When a model or any part of it is modified, the model is copied to the local [[rt_data_t]] object, so the context model is not modified. Commands such as [[integrate]] will create their own copy of the current model (and of the current variable list) at the point where they are executed. When a model is encountered for the first time, it is read from file. The reading is automatically delegated to the global context. Thus, this master copy survives until the main [[rt_data_t]] object is deleted, at program completion. If there is a currently active model, its variable list is linked to the main variable list. Variable lookups will then start from the model variable list. When the current model is switched, the new active model will get this link instead. Consequently, a change to the current model is kept as long as this model has a local copy; it survives local model switches. On the other hand, a parameter change in the current model doesn't affect any other model, even if the parameter name is identical. @ \subsection{Container for parse nodes} The runtime data set contains a bunch of parse nodes (chunks of code that have not been compiled into evaluation trees but saved for later use). We collect them here. This implementation has the useful effect that an assignment between two objects of this type will establish a pointer-target relationship for all components. <>= type :: rt_parse_nodes_t type(parse_node_t), pointer :: cuts_lexpr => null () type(parse_node_t), pointer :: scale_expr => null () type(parse_node_t), pointer :: fac_scale_expr => null () type(parse_node_t), pointer :: ren_scale_expr => null () type(parse_node_t), pointer :: weight_expr => null () type(parse_node_t), pointer :: selection_lexpr => null () type(parse_node_t), pointer :: reweight_expr => null () type(parse_node_t), pointer :: analysis_lexpr => null () type(parse_node_p), dimension(:), allocatable :: alt_setup contains <> end type rt_parse_nodes_t @ %def rt_parse_nodes_t @ Clear individual components. The parse nodes are nullified. No finalization needed since the pointer targets are part of the global parse tree. <>= procedure :: clear => rt_parse_nodes_clear <>= subroutine rt_parse_nodes_clear (rt_pn, name) class(rt_parse_nodes_t), intent(inout) :: rt_pn type(string_t), intent(in) :: name select case (char (name)) case ("cuts") rt_pn%cuts_lexpr => null () case ("scale") rt_pn%scale_expr => null () case ("factorization_scale") rt_pn%fac_scale_expr => null () case ("renormalization_scale") rt_pn%ren_scale_expr => null () case ("weight") rt_pn%weight_expr => null () case ("selection") rt_pn%selection_lexpr => null () case ("reweight") rt_pn%reweight_expr => null () case ("analysis") rt_pn%analysis_lexpr => null () end select end subroutine rt_parse_nodes_clear @ %def rt_parse_nodes_clear @ Output for the parse nodes. <>= procedure :: write => rt_parse_nodes_write <>= subroutine rt_parse_nodes_write (object, unit) class(rt_parse_nodes_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) call wrt ("Cuts", object%cuts_lexpr) call write_separator (u) call wrt ("Scale", object%scale_expr) call write_separator (u) call wrt ("Factorization scale", object%fac_scale_expr) call write_separator (u) call wrt ("Renormalization scale", object%ren_scale_expr) call write_separator (u) call wrt ("Weight", object%weight_expr) call write_separator (u, 2) call wrt ("Event selection", object%selection_lexpr) call write_separator (u) call wrt ("Event reweighting factor", object%reweight_expr) call write_separator (u) call wrt ("Event analysis", object%analysis_lexpr) if (allocated (object%alt_setup)) then call write_separator (u, 2) write (u, "(1x,A,':')") "Alternative setups" do i = 1, size (object%alt_setup) call write_separator (u) call wrt ("Commands", object%alt_setup(i)%ptr) end do end if contains subroutine wrt (title, pn) character(*), intent(in) :: title type(parse_node_t), intent(in), pointer :: pn if (associated (pn)) then write (u, "(1x,A,':')") title call write_separator (u) call parse_node_write_rec (pn, u) else write (u, "(1x,A,':',1x,A)") title, "[undefined]" end if end subroutine wrt end subroutine rt_parse_nodes_write @ %def rt_parse_nodes_write @ Screen output for individual components. (This should eventually be more condensed, currently we print the internal representation tree.) <>= procedure :: show => rt_parse_nodes_show <>= subroutine rt_parse_nodes_show (rt_pn, name, unit) class(rt_parse_nodes_t), intent(in) :: rt_pn type(string_t), intent(in) :: name integer, intent(in), optional :: unit type(parse_node_t), pointer :: pn integer :: u u = given_output_unit (unit) select case (char (name)) case ("cuts") pn => rt_pn%cuts_lexpr case ("scale") pn => rt_pn%scale_expr case ("factorization_scale") pn => rt_pn%fac_scale_expr case ("renormalization_scale") pn => rt_pn%ren_scale_expr case ("weight") pn => rt_pn%weight_expr case ("selection") pn => rt_pn%selection_lexpr case ("reweight") pn => rt_pn%reweight_expr case ("analysis") pn => rt_pn%analysis_lexpr end select if (associated (pn)) then write (u, "(A,1x,A,1x,A)") "Expression:", char (name), "(parse tree):" call parse_node_write_rec (pn, u) else write (u, "(A,1x,A,A)") "Expression:", char (name), ": [undefined]" end if end subroutine rt_parse_nodes_show @ %def rt_parse_nodes_show @ \subsection{The data type} This is a big data container which contains everything that is used and modified during the command flow. A local copy of this can be used to temporarily override defaults. The data set is transparent. <>= public :: rt_data_t <>= type :: rt_data_t type(lexer_t), pointer :: lexer => null () type(rt_data_t), pointer :: context => null () type(string_t), dimension(:), allocatable :: export type(var_list_t) :: var_list type(iterations_list_t) :: it_list type(os_data_t) :: os_data type(model_list_t) :: model_list type(model_t), pointer :: model => null () logical :: model_is_copy = .false. type(model_t), pointer :: preload_model => null () type(model_t), pointer :: fallback_model => null () type(prclib_stack_t) :: prclib_stack type(process_library_t), pointer :: prclib => null () type(beam_structure_t) :: beam_structure type(rt_parse_nodes_t) :: pn type(process_stack_t) :: process_stack type(string_t), dimension(:), allocatable :: sample_fmt class(event_callback_t), allocatable :: event_callback type(file_list_t), pointer :: out_files => null () logical :: quit = .false. integer :: quit_code = 0 type(string_t) :: logfile logical :: nlo_fixed_order = .false. logical, dimension(0:5) :: selected_nlo_parts = .false. integer, dimension(:), allocatable :: nlo_component contains <> end type rt_data_t @ %def rt_data_t @ \subsection{Output} <>= procedure :: write => rt_data_write <>= subroutine rt_data_write (object, unit, vars, pacify) class(rt_data_t), intent(in) :: object integer, intent(in), optional :: unit type(string_t), dimension(:), intent(in), optional :: vars logical, intent(in), optional :: pacify integer :: u, i u = given_output_unit (unit) call write_separator (u, 2) write (u, "(1x,A)") "Runtime data:" if (object%get_n_export () > 0) then call write_separator (u, 2) write (u, "(1x,A)") "Exported objects and variables:" call write_separator (u) call object%write_exports (u) end if if (present (vars)) then if (size (vars) /= 0) then call write_separator (u, 2) write (u, "(1x,A)") "Selected variables:" call write_separator (u) call object%write_vars (u, vars) end if else call write_separator (u, 2) if (associated (object%model)) then call object%model%write_var_list (u, follow_link=.true.) else call object%var_list%write (u, follow_link=.true.) end if end if if (object%it_list%get_n_pass () > 0) then call write_separator (u, 2) write (u, "(1x)", advance="no") call object%it_list%write (u) end if if (associated (object%model)) then call write_separator (u, 2) call object%model%write (u) end if call object%prclib_stack%write (u) call object%beam_structure%write (u) call write_separator (u, 2) call object%pn%write (u) if (allocated (object%sample_fmt)) then call write_separator (u) write (u, "(1x,A)", advance="no") "Event sample formats = " do i = 1, size (object%sample_fmt) if (i > 1) write (u, "(A,1x)", advance="no") "," write (u, "(A)", advance="no") char (object%sample_fmt(i)) end do write (u, "(A)") end if call write_separator (u) write (u, "(1x,A)", advance="no") "Event callback:" if (allocated (object%event_callback)) then call object%event_callback%write (u) else write (u, "(1x,A)") "[undefined]" end if call object%process_stack%write (u, pacify) write (u, "(1x,A,1x,L1)") "quit :", object%quit write (u, "(1x,A,1x,I0)") "quit_code:", object%quit_code call write_separator (u, 2) write (u, "(1x,A,1x,A)") "Logfile :", "'" // trim (char (object%logfile)) // "'" call write_separator (u, 2) end subroutine rt_data_write @ %def rt_data_write @ Write only selected variables. <>= procedure :: write_vars => rt_data_write_vars <>= subroutine rt_data_write_vars (object, unit, vars) class(rt_data_t), intent(in), target :: object integer, intent(in), optional :: unit type(string_t), dimension(:), intent(in) :: vars type(var_list_t), pointer :: var_list integer :: u, i u = given_output_unit (unit) var_list => object%get_var_list_ptr () do i = 1, size (vars) associate (var => vars(i)) if (var_list%contains (var, follow_link=.true.)) then call var_list%write_var (var, unit = u, & follow_link = .true., defined=.true.) end if end associate end do end subroutine rt_data_write_vars @ %def rt_data_write_vars @ Write only the model list. <>= procedure :: write_model_list => rt_data_write_model_list <>= subroutine rt_data_write_model_list (object, unit) class(rt_data_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) call object%model_list%write (u) end subroutine rt_data_write_model_list @ %def rt_data_write_model_list @ Write only the library stack. <>= procedure :: write_libraries => rt_data_write_libraries <>= subroutine rt_data_write_libraries (object, unit, libpath) class(rt_data_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: libpath integer :: u u = given_output_unit (unit) call object%prclib_stack%write (u, libpath) end subroutine rt_data_write_libraries @ %def rt_data_write_libraries @ Write only the beam data. <>= procedure :: write_beams => rt_data_write_beams <>= subroutine rt_data_write_beams (object, unit) class(rt_data_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) call write_separator (u, 2) call object%beam_structure%write (u) call write_separator (u, 2) end subroutine rt_data_write_beams @ %def rt_data_write_beams @ Write only the process and event expressions. <>= procedure :: write_expr => rt_data_write_expr <>= subroutine rt_data_write_expr (object, unit) class(rt_data_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) call write_separator (u, 2) call object%pn%write (u) call write_separator (u, 2) end subroutine rt_data_write_expr @ %def rt_data_write_expr @ Write only the process stack. <>= procedure :: write_process_stack => rt_data_write_process_stack <>= subroutine rt_data_write_process_stack (object, unit) class(rt_data_t), intent(in) :: object integer, intent(in), optional :: unit call object%process_stack%write (unit) end subroutine rt_data_write_process_stack @ %def rt_data_write_process_stack @ <>= procedure :: write_var_descriptions => rt_data_write_var_descriptions <>= subroutine rt_data_write_var_descriptions (rt_data, unit, ascii_output) class(rt_data_t), intent(in) :: rt_data integer, intent(in), optional :: unit logical, intent(in), optional :: ascii_output integer :: u logical :: ao u = given_output_unit (unit) ao = .false.; if (present (ascii_output)) ao = ascii_output call rt_data%var_list%write (u, follow_link=.true., & descriptions=.true., ascii_output=ao) end subroutine rt_data_write_var_descriptions @ %def rt_data_write_var_descriptions @ <>= procedure :: show_description_of_string => rt_data_show_description_of_string <>= subroutine rt_data_show_description_of_string (rt_data, string, & unit, ascii_output) class(rt_data_t), intent(in) :: rt_data type(string_t), intent(in) :: string integer, intent(in), optional :: unit logical, intent(in), optional :: ascii_output integer :: u logical :: ao u = given_output_unit (unit) ao = .false.; if (present (ascii_output)) ao = ascii_output call rt_data%var_list%write_var (string, unit=u, follow_link=.true., & defined=.false., descriptions=.true., ascii_output=ao) end subroutine rt_data_show_description_of_string @ %def rt_data_show_description_of_string @ \subsection{Clear} The [[clear]] command can remove the contents of various subobjects. The objects themselves should stay. <>= procedure :: clear_beams => rt_data_clear_beams <>= subroutine rt_data_clear_beams (global) class(rt_data_t), intent(inout) :: global call global%beam_structure%final_sf () call global%beam_structure%final_pol () call global%beam_structure%final_mom () end subroutine rt_data_clear_beams @ %def rt_data_clear_beams @ \subsection{Initialization} Initialize runtime data. This defines special variables such as [[sqrts]], and should be done only for the instance that is actually global. Local copies will inherit the special variables. We link the global variable list to the process stack variable list, so the latter is always available (and kept global). <>= procedure :: global_init => rt_data_global_init <>= subroutine rt_data_global_init (global, paths, logfile) class(rt_data_t), intent(out), target :: global type(paths_t), intent(in), optional :: paths type(string_t), intent(in), optional :: logfile integer :: seed call global%os_data%init (paths) if (present (logfile)) then global%logfile = logfile else global%logfile = "" end if allocate (global%out_files) call system_clock (seed) call global%var_list%init_defaults (seed, paths) call global%init_pointer_variables () call global%process_stack%init_var_list (global%var_list) end subroutine rt_data_global_init @ %def rt_data_global_init @ \subsection{Local copies} This is done at compile time when a local copy of runtime data is needed: Link the variable list and initialize all derived parameters. This allows for synchronizing them with local variable changes without affecting global data. Also re-initialize pointer variables, so they point to local copies of their targets. <>= procedure :: local_init => rt_data_local_init <>= subroutine rt_data_local_init (local, global, env) class(rt_data_t), intent(inout), target :: local type(rt_data_t), intent(in), target :: global integer, intent(in), optional :: env local%context => global call local%process_stack%link (global%process_stack) call local%process_stack%init_var_list (local%var_list) call local%process_stack%link_var_list (global%var_list) call local%var_list%append_string (var_str ("$model_name"), & var_str (""), intrinsic=.true.) call local%init_pointer_variables () local%fallback_model => global%fallback_model local%os_data = global%os_data local%logfile = global%logfile call local%model_list%link (global%model_list) local%model => global%model if (associated (local%model)) then call local%model%link_var_list (local%var_list) end if if (allocated (global%event_callback)) then allocate (local%event_callback, source = global%event_callback) end if end subroutine rt_data_local_init @ %def rt_data_local_init @ These variables point to objects which get local copies: <>= procedure :: init_pointer_variables => rt_data_init_pointer_variables <>= subroutine rt_data_init_pointer_variables (local) class(rt_data_t), intent(inout), target :: local logical, target, save :: known = .true. call local%var_list%append_string_ptr (var_str ("$fc"), & local%os_data%fc, known, intrinsic=.true., & description=var_str('This string variable gives the ' // & '\ttt{Fortran} compiler used within \whizard. It can ' // & 'only be accessed, not set by the user. (cf. also ' // & '\ttt{\$fcflags}, \ttt{\$fclibs})')) call local%var_list%append_string_ptr (var_str ("$fcflags"), & local%os_data%fcflags, known, intrinsic=.true., & description=var_str('This string variable gives the ' // & 'compiler flags for the \ttt{Fortran} compiler used ' // & 'within \whizard. It can only be accessed, not set by ' // & 'the user. (cf. also \ttt{\$fc}, \ttt{\$fclibs})')) call local%var_list%append_string_ptr (var_str ("$fclibs"), & local%os_data%fclibs, known, intrinsic=.true., & description=var_str('This string variable gives the ' // & 'linked libraries for the \ttt{Fortran} compiler used ' // & 'within \whizard. It can only be accessed, not set by ' // & 'the user. (cf. also \ttt{\$fc}, \ttt{\$fcflags})')) end subroutine rt_data_init_pointer_variables @ %def rt_data_init_pointer_variables @ This is done at execution time: Copy data, transfer pointers. [[local]] has intent(inout) because its local variable list has already been prepared by the previous routine. To be pedantic, the local pointers to model and library should point to the entries in the local copies. (However, as long as these are just shallow copies with identical content, this is actually irrelevant.) The process library and process stacks behave as global objects. The copies of the process library and process stacks should be shallow copies, so the contents stay identical. Since objects may be pushed on the stack in the local environment, upon restoring the global environment, we should reverse the assignment. Then the added stack elements will end up on the global stack. (This should be reconsidered in a parallel environment.) <>= procedure :: activate => rt_data_activate <>= subroutine rt_data_activate (local) class(rt_data_t), intent(inout), target :: local class(rt_data_t), pointer :: global global => local%context if (associated (global)) then local%lexer => global%lexer call global%copy_globals (local) local%os_data = global%os_data local%logfile = global%logfile if (associated (global%prclib)) then local%prclib => & local%prclib_stack%get_library_ptr (global%prclib%get_name ()) end if call local%import_values () call local%process_stack%link (global%process_stack) local%it_list = global%it_list local%beam_structure = global%beam_structure local%pn = global%pn if (allocated (local%sample_fmt)) deallocate (local%sample_fmt) if (allocated (global%sample_fmt)) then allocate (local%sample_fmt (size (global%sample_fmt)), & source = global%sample_fmt) end if local%out_files => global%out_files local%model => global%model local%model_is_copy = .false. else if (.not. associated (local%model)) then local%model => local%preload_model local%model_is_copy = .false. end if if (associated (local%model)) then call local%model%link_var_list (local%var_list) call local%var_list%set_string (var_str ("$model_name"), & local%model%get_name (), is_known = .true.) else call local%var_list%set_string (var_str ("$model_name"), & var_str (""), is_known = .false.) end if end subroutine rt_data_activate @ %def rt_data_activate @ Restore the previous state of data, without actually finalizing the local environment. We also clear the local process stack. Some local modifications (model list and process library stack) are communicated to the global context, if there is any. If the [[keep_local]] flag is set, we want to retain current settings in the local environment. In particular, we create an instance of the currently selected model (which thus becomes separated from the model library!). The local variables are also kept. <>= procedure :: deactivate => rt_data_deactivate <>= subroutine rt_data_deactivate (local, global, keep_local) class(rt_data_t), intent(inout), target :: local class(rt_data_t), intent(inout), optional, target :: global logical, intent(in), optional :: keep_local type(string_t) :: local_model, local_scheme logical :: same_model, delete delete = .true.; if (present (keep_local)) delete = .not. keep_local if (present (global)) then if (associated (global%model) .and. associated (local%model)) then local_model = local%model%get_name () if (global%model%has_schemes ()) then local_scheme = local%model%get_scheme () same_model = & global%model%matches (local_model, local_scheme) else same_model = global%model%matches (local_model) end if else same_model = .false. end if if (delete) then call local%process_stack%clear () call local%unselect_model () call local%unset_values () else if (associated (local%model)) then call local%ensure_model_copy () end if if (.not. same_model .and. associated (global%model)) then if (global%model%has_schemes ()) then call msg_message ("Restoring model '" // & char (global%model%get_name ()) // "', scheme '" // & char (global%model%get_scheme ()) // "'") else call msg_message ("Restoring model '" // & char (global%model%get_name ()) // "'") end if end if if (associated (global%model)) then call global%model%link_var_list (global%var_list) end if call global%restore_globals (local) else call local%unselect_model () end if end subroutine rt_data_deactivate @ %def rt_data_deactivate @ This imports the global objects for which local modifications should be kept. Currently, this is only the process library stack. <>= procedure :: copy_globals => rt_data_copy_globals <>= subroutine rt_data_copy_globals (global, local) class(rt_data_t), intent(in) :: global class(rt_data_t), intent(inout) :: local local%prclib_stack = global%prclib_stack end subroutine rt_data_copy_globals @ %def rt_data_copy_globals @ This restores global objects for which local modifications should be kept. May also modify (remove) the local objects. <>= procedure :: restore_globals => rt_data_restore_globals <>= subroutine rt_data_restore_globals (global, local) class(rt_data_t), intent(inout) :: global class(rt_data_t), intent(inout) :: local global%prclib_stack = local%prclib_stack call local%handle_exports (global) end subroutine rt_data_restore_globals @ %def rt_data_restore_globals @ \subsection{Exported objects} Exported objects are transferred to the global state when a local environment is closed. (For the top-level global data set, there is no effect.) The current implementation handles only the [[results]] object, which resolves to the local process stack. The stack elements are appended to the global stack without modification, the local stack becomes empty. Write names of objects to be exported: <>= procedure :: write_exports => rt_data_write_exports <>= subroutine rt_data_write_exports (rt_data, unit) class(rt_data_t), intent(in) :: rt_data integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) do i = 1, rt_data%get_n_export () write (u, "(A)") char (rt_data%export(i)) end do end subroutine rt_data_write_exports @ %def rt_data_write_exports @ The number of entries in the export list. <>= procedure :: get_n_export => rt_data_get_n_export <>= function rt_data_get_n_export (rt_data) result (n) class(rt_data_t), intent(in) :: rt_data integer :: n if (allocated (rt_data%export)) then n = size (rt_data%export) else n = 0 end if end function rt_data_get_n_export @ %def rt_data_get_n_export @ Return a specific export @ Append new names to the export list. If a duplicate occurs, do not transfer it. <>= procedure :: append_exports => rt_data_append_exports <>= subroutine rt_data_append_exports (rt_data, export) class(rt_data_t), intent(inout) :: rt_data type(string_t), dimension(:), intent(in) :: export logical, dimension(:), allocatable :: mask type(string_t), dimension(:), allocatable :: tmp integer :: i, j, n if (.not. allocated (rt_data%export)) allocate (rt_data%export (0)) n = size (rt_data%export) allocate (mask (size (export)), source=.false.) do i = 1, size (export) mask(i) = all (export(i) /= rt_data%export) & .and. all (export(i) /= export(:i-1)) end do if (count (mask) > 0) then allocate (tmp (n + count (mask))) tmp(1:n) = rt_data%export(:) j = n do i = 1, size (export) if (mask(i)) then j = j + 1 tmp(j) = export(i) end if end do call move_alloc (from=tmp, to=rt_data%export) end if end subroutine rt_data_append_exports @ %def rt_data_append_exports @ Transfer export-objects from the [[local]] rt data to the [[global]] rt data, as far as supported. <>= procedure :: handle_exports => rt_data_handle_exports <>= subroutine rt_data_handle_exports (local, global) class(rt_data_t), intent(inout), target :: local class(rt_data_t), intent(inout), target :: global type(string_t) :: export integer :: i if (local%get_n_export () > 0) then do i = 1, local%get_n_export () export = local%export(i) select case (char (export)) case ("results") call msg_message ("Exporting integration results & &to outer environment") call local%transfer_process_stack (global) case default call msg_bug ("handle exports: '" & // char (export) // "' unsupported") end select end do end if end subroutine rt_data_handle_exports @ %def rt_data_handle_exports @ Export the process stack. One-by-one, take the last process from the local stack and push it on the global stack. Also handle the corresponding result variables: append if the process did not exist yet in the global stack, otherwise update. TODO: result variables do not work that way yet, require initialization in the global variable list. <>= procedure :: transfer_process_stack => rt_data_transfer_process_stack <>= subroutine rt_data_transfer_process_stack (local, global) class(rt_data_t), intent(inout), target :: local class(rt_data_t), intent(inout), target :: global type(process_entry_t), pointer :: process type(string_t) :: process_id do call local%process_stack%pop_last (process) if (.not. associated (process)) exit process_id = process%get_id () call global%process_stack%push (process) call global%process_stack%fill_result_vars (process_id) call global%process_stack%update_result_vars & (process_id, global%var_list) end do end subroutine rt_data_transfer_process_stack @ %def rt_data_transfer_process_stack @ \subsection{Finalization} Finalizer for the variable list and the structure-function list. This is done only for the global RT dataset; local copies contain pointers to this and do not need a finalizer. <>= procedure :: final => rt_data_global_final <>= subroutine rt_data_global_final (global) class(rt_data_t), intent(inout) :: global call global%process_stack%final () call global%prclib_stack%final () call global%model_list%final () call global%var_list%final (follow_link=.false.) if (associated (global%out_files)) then call file_list_final (global%out_files) deallocate (global%out_files) end if end subroutine rt_data_global_final @ %def rt_data_global_final @ The local copy needs a finalizer for the variable list, which consists of local copies. This finalizer is called only when the local environment is finally discarded. (Note that the process stack should already have been cleared after execution, which can occur many times for the same local environment.) <>= procedure :: local_final => rt_data_local_final <>= subroutine rt_data_local_final (local) class(rt_data_t), intent(inout) :: local call local%process_stack%clear () call local%model_list%final () call local%var_list%final (follow_link=.false.) end subroutine rt_data_local_final @ %def rt_data_local_final @ \subsection{Model Management} Read a model, so it becomes available for activation. No variables or model copies, this is just initialization. If this is a local environment, the model will be automatically read into the global context. <>= procedure :: read_model => rt_data_read_model <>= subroutine rt_data_read_model (global, name, model, scheme) class(rt_data_t), intent(inout) :: global type(string_t), intent(in) :: name type(string_t), intent(in), optional :: scheme type(model_t), pointer, intent(out) :: model type(string_t) :: filename filename = name // ".mdl" call global%model_list%read_model & (name, filename, global%os_data, model, scheme) end subroutine rt_data_read_model @ %def rt_data_read_model @ Read a UFO model. Create it on the fly if necessary. <>= procedure :: read_ufo_model => rt_data_read_ufo_model <>= subroutine rt_data_read_ufo_model (global, name, model, ufo_path) class(rt_data_t), intent(inout) :: global type(string_t), intent(in) :: name type(model_t), pointer, intent(out) :: model type(string_t), intent(in), optional :: ufo_path type(string_t) :: filename filename = name // ".ufo.mdl" call global%model_list%read_model & (name, filename, global%os_data, model, ufo=.true., ufo_path=ufo_path) end subroutine rt_data_read_ufo_model @ %def rt_data_read_ufo_model @ Initialize the fallback model. This model is used whenever the current model does not describe all physical particles (hadrons, mainly). It is not supposed to be modified, and the pointer should remain linked to this model. <>= procedure :: init_fallback_model => rt_data_init_fallback_model <>= subroutine rt_data_init_fallback_model (global, name, filename) class(rt_data_t), intent(inout) :: global type(string_t), intent(in) :: name, filename call global%model_list%read_model & (name, filename, global%os_data, global%fallback_model) end subroutine rt_data_init_fallback_model @ %def rt_data_init_fallback_model @ Activate a model: assign the current-model pointer and set the model name in the variable list. If necessary, read the model from file. Link the global variable list to the model variable list. <>= procedure :: select_model => rt_data_select_model <>= subroutine rt_data_select_model (global, name, scheme, ufo, ufo_path) class(rt_data_t), intent(inout), target :: global type(string_t), intent(in) :: name type(string_t), intent(in), optional :: scheme logical, intent(in), optional :: ufo type(string_t), intent(in), optional :: ufo_path logical :: same_model, ufo_model ufo_model = .false.; if (present (ufo)) ufo_model = ufo if (associated (global%model)) then same_model = global%model%matches (name, scheme, ufo) else same_model = .false. end if if (.not. same_model) then global%model => global%model_list%get_model_ptr (name, scheme, ufo) if (.not. associated (global%model)) then if (ufo_model) then call global%read_ufo_model (name, global%model, ufo_path) else call global%read_model (name, global%model) end if global%model_is_copy = .false. else if (associated (global%context)) then global%model_is_copy = & global%model_list%model_exists (name, scheme, ufo, & follow_link=.false.) else global%model_is_copy = .false. end if end if if (associated (global%model)) then call global%model%link_var_list (global%var_list) call global%var_list%set_string (var_str ("$model_name"), & name, is_known = .true.) if (global%model%is_ufo_model ()) then call msg_message ("Switching to model '" // char (name) // "' " & // "(generated from UFO source)") else if (global%model%has_schemes ()) then call msg_message ("Switching to model '" // char (name) // "', " & // "scheme '" // char (global%model%get_scheme ()) // "'") else call msg_message ("Switching to model '" // char (name) // "'") end if else call global%var_list%set_string (var_str ("$model_name"), & var_str (""), is_known = .false.) end if end subroutine rt_data_select_model @ %def rt_data_select_model @ Remove the model link. Do not unset the model name variable, because this may unset the variable in a parent [[rt_data]] object (via linked var lists). <>= procedure :: unselect_model => rt_data_unselect_model <>= subroutine rt_data_unselect_model (global) class(rt_data_t), intent(inout), target :: global if (associated (global%model)) then global%model => null () global%model_is_copy = .false. end if end subroutine rt_data_unselect_model @ %def rt_data_unselect_model @ Create a copy of the currently selected model and append it to the local model list. The model pointer is redirected to the copy. (Not applicable for the global model list, those models will be modified in-place.) <>= procedure :: ensure_model_copy => rt_data_ensure_model_copy <>= subroutine rt_data_ensure_model_copy (global) class(rt_data_t), intent(inout), target :: global if (associated (global%context)) then if (.not. global%model_is_copy) then call global%model_list%append_copy (global%model, global%model) global%model_is_copy = .true. call global%model%link_var_list (global%var_list) end if end if end subroutine rt_data_ensure_model_copy @ %def rt_data_ensure_model_copy @ Modify a model variable. The update mechanism will ensure that the model parameter set remains consistent. This has to take place in a local copy of the current model. If there is none yet, create one. <>= procedure :: model_set_real => rt_data_model_set_real <>= subroutine rt_data_model_set_real (global, name, rval, verbose, pacified) class(rt_data_t), intent(inout), target :: global type(string_t), intent(in) :: name real(default), intent(in) :: rval logical, intent(in), optional :: verbose, pacified call global%ensure_model_copy () call global%model%set_real (name, rval, verbose, pacified) end subroutine rt_data_model_set_real @ %def rt_data_model_set_real @ Modify particle properties. This has to take place in a local copy of the current model. If there is none yet, create one. <>= procedure :: modify_particle => rt_data_modify_particle <>= subroutine rt_data_modify_particle & (global, pdg, polarized, stable, decay, & isotropic_decay, diagonal_decay, decay_helicity) class(rt_data_t), intent(inout), target :: global integer, intent(in) :: pdg logical, intent(in), optional :: polarized, stable logical, intent(in), optional :: isotropic_decay, diagonal_decay integer, intent(in), optional :: decay_helicity type(string_t), dimension(:), intent(in), optional :: decay call global%ensure_model_copy () if (present (polarized)) then if (polarized) then call global%model%set_polarized (pdg) else call global%model%set_unpolarized (pdg) end if end if if (present (stable)) then if (stable) then call global%model%set_stable (pdg) else if (present (decay)) then call global%model%set_unstable & (pdg, decay, isotropic_decay, diagonal_decay, decay_helicity) else call msg_bug ("Setting particle unstable: missing decay processes") end if end if end subroutine rt_data_modify_particle @ %def rt_data_modify_particle @ \subsection{Managing Variables} Return a pointer to the currently active variable list. If there is no model, this is the global variable list. If there is one, it is the model variable list, which should be linked to the former. <>= procedure :: get_var_list_ptr => rt_data_get_var_list_ptr <>= function rt_data_get_var_list_ptr (global) result (var_list) class(rt_data_t), intent(in), target :: global type(var_list_t), pointer :: var_list if (associated (global%model)) then var_list => global%model%get_var_list_ptr () else var_list => global%var_list end if end function rt_data_get_var_list_ptr @ %def rt_data_get_var_list_ptr @ Initialize a local variable: append it to the current variable list. No initial value, yet. <>= procedure :: append_log => rt_data_append_log procedure :: append_int => rt_data_append_int procedure :: append_real => rt_data_append_real procedure :: append_cmplx => rt_data_append_cmplx procedure :: append_subevt => rt_data_append_subevt procedure :: append_pdg_array => rt_data_append_pdg_array procedure :: append_string => rt_data_append_string <>= subroutine rt_data_append_log (local, name, lval, intrinsic, user) class(rt_data_t), intent(inout) :: local type(string_t), intent(in) :: name logical, intent(in), optional :: lval logical, intent(in), optional :: intrinsic, user call local%var_list%append_log (name, lval, & intrinsic = intrinsic, user = user) end subroutine rt_data_append_log subroutine rt_data_append_int (local, name, ival, intrinsic, user) class(rt_data_t), intent(inout) :: local type(string_t), intent(in) :: name integer, intent(in), optional :: ival logical, intent(in), optional :: intrinsic, user call local%var_list%append_int (name, ival, & intrinsic = intrinsic, user = user) end subroutine rt_data_append_int subroutine rt_data_append_real (local, name, rval, intrinsic, user) class(rt_data_t), intent(inout) :: local type(string_t), intent(in) :: name real(default), intent(in), optional :: rval logical, intent(in), optional :: intrinsic, user call local%var_list%append_real (name, rval, & intrinsic = intrinsic, user = user) end subroutine rt_data_append_real subroutine rt_data_append_cmplx (local, name, cval, intrinsic, user) class(rt_data_t), intent(inout) :: local type(string_t), intent(in) :: name complex(default), intent(in), optional :: cval logical, intent(in), optional :: intrinsic, user call local%var_list%append_cmplx (name, cval, & intrinsic = intrinsic, user = user) end subroutine rt_data_append_cmplx subroutine rt_data_append_subevt (local, name, pval, intrinsic, user) class(rt_data_t), intent(inout) :: local type(string_t), intent(in) :: name type(subevt_t), intent(in), optional :: pval logical, intent(in) :: intrinsic, user call local%var_list%append_subevt (name, & intrinsic = intrinsic, user = user) end subroutine rt_data_append_subevt subroutine rt_data_append_pdg_array (local, name, aval, intrinsic, user) class(rt_data_t), intent(inout) :: local type(string_t), intent(in) :: name type(pdg_array_t), intent(in), optional :: aval logical, intent(in), optional :: intrinsic, user call local%var_list%append_pdg_array (name, aval, & intrinsic = intrinsic, user = user) end subroutine rt_data_append_pdg_array subroutine rt_data_append_string (local, name, sval, intrinsic, user) class(rt_data_t), intent(inout) :: local type(string_t), intent(in) :: name type(string_t), intent(in), optional :: sval logical, intent(in), optional :: intrinsic, user call local%var_list%append_string (name, sval, & intrinsic = intrinsic, user = user) end subroutine rt_data_append_string @ %def rt_data_append_log @ %def rt_data_append_int @ %def rt_data_append_real @ %def rt_data_append_cmplx @ %def rt_data_append_subevt @ %def rt_data_append_pdg_array @ %def rt_data_append_string @ Import values for all local variables, given a global context environment where these variables are defined. <>= procedure :: import_values => rt_data_import_values <>= subroutine rt_data_import_values (local) class(rt_data_t), intent(inout) :: local type(rt_data_t), pointer :: global global => local%context if (associated (global)) then call local%var_list%import (global%var_list) end if end subroutine rt_data_import_values @ %def rt_data_import_values @ Unset all variable values. <>= procedure :: unset_values => rt_data_unset_values <>= subroutine rt_data_unset_values (global) class(rt_data_t), intent(inout) :: global call global%var_list%undefine (follow_link=.false.) end subroutine rt_data_unset_values @ %def rt_data_unset_values @ Set a variable. (Not a model variable, these are handled separately.) We can assume that the variable has been initialized. <>= procedure :: set_log => rt_data_set_log procedure :: set_int => rt_data_set_int procedure :: set_real => rt_data_set_real procedure :: set_cmplx => rt_data_set_cmplx procedure :: set_subevt => rt_data_set_subevt procedure :: set_pdg_array => rt_data_set_pdg_array procedure :: set_string => rt_data_set_string <>= subroutine rt_data_set_log & (global, name, lval, is_known, force, verbose) class(rt_data_t), intent(inout) :: global type(string_t), intent(in) :: name logical, intent(in) :: lval logical, intent(in) :: is_known logical, intent(in), optional :: force, verbose call global%var_list%set_log (name, lval, is_known, & force=force, verbose=verbose) end subroutine rt_data_set_log subroutine rt_data_set_int & (global, name, ival, is_known, force, verbose) class(rt_data_t), intent(inout) :: global type(string_t), intent(in) :: name integer, intent(in) :: ival logical, intent(in) :: is_known logical, intent(in), optional :: force, verbose call global%var_list%set_int (name, ival, is_known, & force=force, verbose=verbose) end subroutine rt_data_set_int subroutine rt_data_set_real & (global, name, rval, is_known, force, verbose, pacified) class(rt_data_t), intent(inout) :: global type(string_t), intent(in) :: name real(default), intent(in) :: rval logical, intent(in) :: is_known logical, intent(in), optional :: force, verbose, pacified call global%var_list%set_real (name, rval, is_known, & force=force, verbose=verbose, pacified=pacified) end subroutine rt_data_set_real subroutine rt_data_set_cmplx & (global, name, cval, is_known, force, verbose, pacified) class(rt_data_t), intent(inout) :: global type(string_t), intent(in) :: name complex(default), intent(in) :: cval logical, intent(in) :: is_known logical, intent(in), optional :: force, verbose, pacified call global%var_list%set_cmplx (name, cval, is_known, & force=force, verbose=verbose, pacified=pacified) end subroutine rt_data_set_cmplx subroutine rt_data_set_subevt & (global, name, pval, is_known, force, verbose) class(rt_data_t), intent(inout) :: global type(string_t), intent(in) :: name type(subevt_t), intent(in) :: pval logical, intent(in) :: is_known logical, intent(in), optional :: force, verbose call global%var_list%set_subevt (name, pval, is_known, & force=force, verbose=verbose) end subroutine rt_data_set_subevt subroutine rt_data_set_pdg_array & (global, name, aval, is_known, force, verbose) class(rt_data_t), intent(inout) :: global type(string_t), intent(in) :: name type(pdg_array_t), intent(in) :: aval logical, intent(in) :: is_known logical, intent(in), optional :: force, verbose call global%var_list%set_pdg_array (name, aval, is_known, & force=force, verbose=verbose) end subroutine rt_data_set_pdg_array subroutine rt_data_set_string & (global, name, sval, is_known, force, verbose) class(rt_data_t), intent(inout) :: global type(string_t), intent(in) :: name type(string_t), intent(in) :: sval logical, intent(in) :: is_known logical, intent(in), optional :: force, verbose call global%var_list%set_string (name, sval, is_known, & force=force, verbose=verbose) end subroutine rt_data_set_string @ %def rt_data_set_log @ %def rt_data_set_int @ %def rt_data_set_real @ %def rt_data_set_cmplx @ %def rt_data_set_subevt @ %def rt_data_set_pdg_array @ %def rt_data_set_string @ Return the value of a variable, assuming that the type is correct. <>= procedure :: get_lval => rt_data_get_lval procedure :: get_ival => rt_data_get_ival procedure :: get_rval => rt_data_get_rval procedure :: get_cval => rt_data_get_cval procedure :: get_pval => rt_data_get_pval procedure :: get_aval => rt_data_get_aval procedure :: get_sval => rt_data_get_sval <>= function rt_data_get_lval (global, name) result (lval) logical :: lval class(rt_data_t), intent(in), target :: global type(string_t), intent(in) :: name type(var_list_t), pointer :: var_list var_list => global%get_var_list_ptr () lval = var_list%get_lval (name) end function rt_data_get_lval function rt_data_get_ival (global, name) result (ival) integer :: ival class(rt_data_t), intent(in), target :: global type(string_t), intent(in) :: name type(var_list_t), pointer :: var_list var_list => global%get_var_list_ptr () ival = var_list%get_ival (name) end function rt_data_get_ival function rt_data_get_rval (global, name) result (rval) real(default) :: rval class(rt_data_t), intent(in), target :: global type(string_t), intent(in) :: name type(var_list_t), pointer :: var_list var_list => global%get_var_list_ptr () rval = var_list%get_rval (name) end function rt_data_get_rval function rt_data_get_cval (global, name) result (cval) complex(default) :: cval class(rt_data_t), intent(in), target :: global type(string_t), intent(in) :: name type(var_list_t), pointer :: var_list var_list => global%get_var_list_ptr () cval = var_list%get_cval (name) end function rt_data_get_cval function rt_data_get_aval (global, name) result (aval) type(pdg_array_t) :: aval class(rt_data_t), intent(in), target :: global type(string_t), intent(in) :: name type(var_list_t), pointer :: var_list var_list => global%get_var_list_ptr () aval = var_list%get_aval (name) end function rt_data_get_aval function rt_data_get_pval (global, name) result (pval) type(subevt_t) :: pval class(rt_data_t), intent(in), target :: global type(string_t), intent(in) :: name type(var_list_t), pointer :: var_list var_list => global%get_var_list_ptr () pval = var_list%get_pval (name) end function rt_data_get_pval function rt_data_get_sval (global, name) result (sval) type(string_t) :: sval class(rt_data_t), intent(in), target :: global type(string_t), intent(in) :: name type(var_list_t), pointer :: var_list var_list => global%get_var_list_ptr () sval = var_list%get_sval (name) end function rt_data_get_sval @ %def rt_data_get_lval @ %def rt_data_get_ival @ %def rt_data_get_rval @ %def rt_data_get_cval @ %def rt_data_get_pval @ %def rt_data_get_aval @ %def rt_data_get_sval @ Return true if the variable exists in the global list. <>= procedure :: contains => rt_data_contains <>= function rt_data_contains (global, name) result (lval) logical :: lval class(rt_data_t), intent(in), target :: global type(string_t), intent(in) :: name type(var_list_t), pointer :: var_list var_list => global%get_var_list_ptr () lval = var_list%contains (name) end function rt_data_contains @ %def rt_data_contains @ Return true if the value of the variable is known. <>= procedure :: is_known => rt_data_is_known <>= function rt_data_is_known (global, name) result (lval) logical :: lval class(rt_data_t), intent(in), target :: global type(string_t), intent(in) :: name type(var_list_t), pointer :: var_list var_list => global%get_var_list_ptr () lval = var_list%is_known (name) end function rt_data_is_known @ %def rt_data_is_known @ \subsection{Further Content} Add a library (available via a pointer of type [[prclib_entry_t]]) to the stack and update the pointer and variable list to the current library. The pointer association of [[prclib_entry]] will be discarded. <>= procedure :: add_prclib => rt_data_add_prclib <>= subroutine rt_data_add_prclib (global, prclib_entry) class(rt_data_t), intent(inout) :: global type(prclib_entry_t), intent(inout), pointer :: prclib_entry call global%prclib_stack%push (prclib_entry) call global%update_prclib (global%prclib_stack%get_first_ptr ()) end subroutine rt_data_add_prclib @ %def rt_data_add_prclib @ Given a pointer to a process library, make this the currently active library. <>= procedure :: update_prclib => rt_data_update_prclib <>= subroutine rt_data_update_prclib (global, lib) class(rt_data_t), intent(inout) :: global type(process_library_t), intent(in), target :: lib global%prclib => lib if (global%var_list%contains (& var_str ("$library_name"), follow_link = .false.)) then call global%var_list%set_string (var_str ("$library_name"), & global%prclib%get_name (), is_known=.true.) else call global%var_list%append_string ( & var_str ("$library_name"), global%prclib%get_name (), & intrinsic = .true.) end if end subroutine rt_data_update_prclib @ %def rt_data_update_prclib @ \subsection{Miscellaneous} The helicity selection data are distributed among several parameters. Here, we collect them in a single record. <>= procedure :: get_helicity_selection => rt_data_get_helicity_selection <>= function rt_data_get_helicity_selection (rt_data) result (helicity_selection) class(rt_data_t), intent(in) :: rt_data type(helicity_selection_t) :: helicity_selection associate (var_list => rt_data%var_list) helicity_selection%active = var_list%get_lval (& var_str ("?helicity_selection_active")) if (helicity_selection%active) then helicity_selection%threshold = var_list%get_rval (& var_str ("helicity_selection_threshold")) helicity_selection%cutoff = var_list%get_ival (& var_str ("helicity_selection_cutoff")) end if end associate end function rt_data_get_helicity_selection @ %def rt_data_get_helicity_selection @ Show the beam setup: beam structure and relevant global variables. <>= procedure :: show_beams => rt_data_show_beams <>= subroutine rt_data_show_beams (rt_data, unit) class(rt_data_t), intent(in) :: rt_data integer, intent(in), optional :: unit type(string_t) :: s integer :: u u = given_output_unit (unit) associate (beams => rt_data%beam_structure, var_list => rt_data%var_list) call beams%write (u) if (.not. beams%asymmetric () .and. beams%get_n_beam () == 2) then write (u, "(2x,A," // FMT_19 // ",1x,'GeV')") "sqrts =", & var_list%get_rval (var_str ("sqrts")) end if if (beams%contains ("pdf_builtin")) then s = var_list%get_sval (var_str ("$pdf_builtin_set")) if (s /= "") then write (u, "(2x,A,1x,3A)") "PDF set =", '"', char (s), '"' else write (u, "(2x,A,1x,A)") "PDF set =", "[undefined]" end if end if if (beams%contains ("lhapdf")) then s = var_list%get_sval (var_str ("$lhapdf_dir")) if (s /= "") then write (u, "(2x,A,1x,3A)") "LHAPDF dir =", '"', char (s), '"' end if s = var_list%get_sval (var_str ("$lhapdf_file")) if (s /= "") then write (u, "(2x,A,1x,3A)") "LHAPDF file =", '"', char (s), '"' write (u, "(2x,A,1x,I0)") "LHAPDF member =", & var_list%get_ival (var_str ("lhapdf_member")) else write (u, "(2x,A,1x,A)") "LHAPDF file =", "[undefined]" end if end if if (beams%contains ("lhapdf_photon")) then s = var_list%get_sval (var_str ("$lhapdf_dir")) if (s /= "") then write (u, "(2x,A,1x,3A)") "LHAPDF dir =", '"', char (s), '"' end if s = var_list%get_sval (var_str ("$lhapdf_photon_file")) if (s /= "") then write (u, "(2x,A,1x,3A)") "LHAPDF file =", '"', char (s), '"' write (u, "(2x,A,1x,I0)") "LHAPDF member =", & var_list%get_ival (var_str ("lhapdf_member")) write (u, "(2x,A,1x,I0)") "LHAPDF scheme =", & var_list%get_ival (& var_str ("lhapdf_photon_scheme")) else write (u, "(2x,A,1x,A)") "LHAPDF file =", "[undefined]" end if end if if (beams%contains ("isr")) then write (u, "(2x,A," // FMT_19 // ")") "ISR alpha =", & var_list%get_rval (var_str ("isr_alpha")) write (u, "(2x,A," // FMT_19 // ")") "ISR Q max =", & var_list%get_rval (var_str ("isr_q_max")) write (u, "(2x,A," // FMT_19 // ")") "ISR mass =", & var_list%get_rval (var_str ("isr_mass")) write (u, "(2x,A,1x,I0)") "ISR order =", & var_list%get_ival (var_str ("isr_order")) write (u, "(2x,A,1x,L1)") "ISR recoil =", & var_list%get_lval (var_str ("?isr_recoil")) write (u, "(2x,A,1x,L1)") "ISR energy cons. =", & var_list%get_lval (var_str ("?isr_keep_energy")) end if if (beams%contains ("epa")) then write (u, "(2x,A," // FMT_19 // ")") "EPA alpha =", & var_list%get_rval (var_str ("epa_alpha")) write (u, "(2x,A," // FMT_19 // ")") "EPA x min =", & var_list%get_rval (var_str ("epa_x_min")) write (u, "(2x,A," // FMT_19 // ")") "EPA Q min =", & var_list%get_rval (var_str ("epa_q_min")) write (u, "(2x,A," // FMT_19 // ")") "EPA Q max =", & var_list%get_rval (var_str ("epa_q_max")) write (u, "(2x,A," // FMT_19 // ")") "EPA mass =", & var_list%get_rval (var_str ("epa_mass")) write (u, "(2x,A,1x,L1)") "EPA recoil =", & var_list%get_lval (var_str ("?epa_recoil")) write (u, "(2x,A,1x,L1)") "EPA energy cons. =", & var_list%get_lval (var_str ("?epa_keep_energy")) end if if (beams%contains ("ewa")) then write (u, "(2x,A," // FMT_19 // ")") "EWA x min =", & var_list%get_rval (var_str ("ewa_x_min")) write (u, "(2x,A," // FMT_19 // ")") "EWA Pt max =", & var_list%get_rval (var_str ("ewa_pt_max")) write (u, "(2x,A," // FMT_19 // ")") "EWA mass =", & var_list%get_rval (var_str ("ewa_mass")) write (u, "(2x,A,1x,L1)") "EWA recoil =", & var_list%get_lval (var_str ("?ewa_recoil")) write (u, "(2x,A,1x,L1)") "EWA energy cons. =", & var_list%get_lval (var_str ("ewa_keep_energy")) end if if (beams%contains ("circe1")) then write (u, "(2x,A,1x,I0)") "CIRCE1 version =", & var_list%get_ival (var_str ("circe1_ver")) write (u, "(2x,A,1x,I0)") "CIRCE1 revision =", & var_list%get_ival (var_str ("circe1_rev")) s = var_list%get_sval (var_str ("$circe1_acc")) write (u, "(2x,A,1x,A)") "CIRCE1 acceler. =", char (s) write (u, "(2x,A,1x,I0)") "CIRCE1 chattin. =", & var_list%get_ival (var_str ("circe1_chat")) write (u, "(2x,A," // FMT_19 // ")") "CIRCE1 sqrts =", & var_list%get_rval (var_str ("circe1_sqrts")) write (u, "(2x,A," // FMT_19 // ")") "CIRCE1 epsil. =", & var_list%get_rval (var_str ("circe1_eps")) write (u, "(2x,A,1x,L1)") "CIRCE1 phot. 1 =", & var_list%get_lval (var_str ("?circe1_photon1")) write (u, "(2x,A,1x,L1)") "CIRCE1 phot. 2 =", & var_list%get_lval (var_str ("?circe1_photon2")) write (u, "(2x,A,1x,L1)") "CIRCE1 generat. =", & var_list%get_lval (var_str ("?circe1_generate")) write (u, "(2x,A,1x,L1)") "CIRCE1 mapping =", & var_list%get_lval (var_str ("?circe1_map")) write (u, "(2x,A," // FMT_19 // ")") "CIRCE1 map. slope =", & var_list%get_rval (var_str ("circe1_mapping_slope")) write (u, "(2x,A,1x,L1)") "CIRCE recoil photon =", & var_list%get_lval (var_str ("?circe1_with_radiation")) end if if (beams%contains ("circe2")) then s = var_list%get_sval (var_str ("$circe2_design")) write (u, "(2x,A,1x,A)") "CIRCE2 design =", char (s) s = var_list%get_sval (var_str ("$circe2_file")) write (u, "(2x,A,1x,A)") "CIRCE2 file =", char (s) write (u, "(2x,A,1x,L1)") "CIRCE2 polarized =", & var_list%get_lval (var_str ("?circe2_polarized")) end if if (beams%contains ("gaussian")) then write (u, "(2x,A,1x," // FMT_12 // ")") "Gaussian spread 1 =", & var_list%get_rval (var_str ("gaussian_spread1")) write (u, "(2x,A,1x," // FMT_12 // ")") "Gaussian spread 2 =", & var_list%get_rval (var_str ("gaussian_spread2")) end if if (beams%contains ("beam_events")) then s = var_list%get_sval (var_str ("$beam_events_file")) write (u, "(2x,A,1x,A)") "Beam events file =", char (s) write (u, "(2x,A,1x,L1)") "Beam events EOF warn =", & var_list%get_lval (var_str ("?beam_events_warn_eof")) end if end associate end subroutine rt_data_show_beams @ %def rt_data_show_beams @ Return the collision energy as determined by the current beam settings. Without beam setup, this is the [[sqrts]] variable. If the value is meaningless for a setup, the function returns zero. <>= procedure :: get_sqrts => rt_data_get_sqrts <>= function rt_data_get_sqrts (rt_data) result (sqrts) class(rt_data_t), intent(in) :: rt_data real(default) :: sqrts sqrts = rt_data%var_list%get_rval (var_str ("sqrts")) end function rt_data_get_sqrts @ %def rt_data_get_sqrts @ For testing purposes, the [[rt_data_t]] contents can be pacified to suppress numerical fluctuations in (constant) test matrix elements. <>= procedure :: pacify => rt_data_pacify <>= subroutine rt_data_pacify (rt_data, efficiency_reset, error_reset) class(rt_data_t), intent(inout) :: rt_data logical, intent(in), optional :: efficiency_reset, error_reset type(process_entry_t), pointer :: process process => rt_data%process_stack%first do while (associated (process)) call process%pacify (efficiency_reset, error_reset) process => process%next end do end subroutine rt_data_pacify @ %def rt_data_pacify @ <>= procedure :: set_event_callback => rt_data_set_event_callback <>= subroutine rt_data_set_event_callback (global, callback) class(rt_data_t), intent(inout) :: global class(event_callback_t), intent(in) :: callback if (allocated (global%event_callback)) deallocate (global%event_callback) allocate (global%event_callback, source = callback) end subroutine rt_data_set_event_callback @ %def rt_data_set_event_callback @ <>= procedure :: has_event_callback => rt_data_has_event_callback procedure :: get_event_callback => rt_data_get_event_callback <>= function rt_data_has_event_callback (global) result (flag) class(rt_data_t), intent(in) :: global logical :: flag flag = allocated (global%event_callback) end function rt_data_has_event_callback function rt_data_get_event_callback (global) result (callback) class(rt_data_t), intent(in) :: global class(event_callback_t), allocatable :: callback if (allocated (global%event_callback)) then allocate (callback, source = global%event_callback) end if end function rt_data_get_event_callback @ %def rt_data_has_event_callback @ %def rt_data_get_event_callback @ Force system-dependent objects to well-defined values. Some of the variables are locked and therefore must be addressed directly. This is, of course, only required for testing purposes. In principle, the [[real_specimen]] variables could be set to their values in [[rt_data_t]], but this depends on the precision again, so we set them to some dummy values. <>= public :: fix_system_dependencies <>= subroutine fix_system_dependencies (global) class(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list var_list => global%get_var_list_ptr () call var_list%set_log (var_str ("?omega_openmp"), & .false., is_known = .true., force=.true.) call var_list%set_log (var_str ("?openmp_is_active"), & .false., is_known = .true., force=.true.) call var_list%set_int (var_str ("openmp_num_threads_default"), & 1, is_known = .true., force=.true.) call var_list%set_int (var_str ("openmp_num_threads"), & 1, is_known = .true., force=.true.) call var_list%set_int (var_str ("real_range"), & 307, is_known = .true., force=.true.) call var_list%set_int (var_str ("real_precision"), & 15, is_known = .true., force=.true.) call var_list%set_real (var_str ("real_epsilon"), & 1.e-16_default, is_known = .true., force=.true.) call var_list%set_real (var_str ("real_tiny"), & 1.e-300_default, is_known = .true., force=.true.) global%os_data%fc = "Fortran-compiler" global%os_data%fcflags = "Fortran-flags" global%os_data%fclibs = "Fortran-libs" end subroutine fix_system_dependencies @ %def fix_system_dependencies @ <>= public :: show_description_of_string <>= subroutine show_description_of_string (string) type(string_t), intent(in) :: string type(rt_data_t), target :: global call global%global_init () call global%show_description_of_string (string, ascii_output=.true.) end subroutine show_description_of_string @ %def show_description_of_string @ <>= public :: show_tex_descriptions <>= subroutine show_tex_descriptions () type(rt_data_t), target :: global call global%global_init () call fix_system_dependencies (global) call global%set_int (var_str ("seed"), 0, is_known=.true.) call global%var_list%sort () call global%write_var_descriptions () end subroutine show_tex_descriptions @ %def show_tex_descriptions @ \subsection{Unit Tests} Test module, followed by the corresponding implementation module. <<[[rt_data_ut.f90]]>>= <> module rt_data_ut use unit_tests use rt_data_uti <> <> contains <> end module rt_data_ut @ %def rt_data_ut @ <<[[rt_data_uti.f90]]>>= <> module rt_data_uti <> <> use format_defs, only: FMT_19 use ifiles use lexers use parser use flavors - use variables, only: var_list_t, var_entry_t, var_entry_init_int + use variables, only: var_list_t use eval_trees use models use prclib_stacks use rt_data <> <> contains <> <> end module rt_data_uti @ %def rt_data_ut @ API: driver for the unit tests below. <>= public :: rt_data_test <>= subroutine rt_data_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine rt_data_test @ %def rt_data_test @ \subsubsection{Initial content} @ Display the RT data in the state just after (global) initialization. <>= call test (rt_data_1, "rt_data_1", & "initialize", & u, results) <>= public :: rt_data_1 <>= subroutine rt_data_1 (u) integer, intent(in) :: u type(rt_data_t), target :: global write (u, "(A)") "* Test output: rt_data_1" write (u, "(A)") "* Purpose: initialize global runtime data" write (u, "(A)") call global%global_init (logfile = var_str ("rt_data.log")) call fix_system_dependencies (global) call global%set_int (var_str ("seed"), 0, is_known=.true.) call global%it_list%init ([2, 3], [5000, 20000]) call global%write (u) call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: rt_data_1" end subroutine rt_data_1 @ %def rt_data_1 @ \subsubsection{Fill values} Fill in empty slots in the runtime data block. <>= call test (rt_data_2, "rt_data_2", & "fill", & u, results) <>= public :: rt_data_2 <>= subroutine rt_data_2 (u) integer, intent(in) :: u type(rt_data_t), target :: global type(flavor_t), dimension(2) :: flv type(string_t) :: cut_expr_text type(ifile_t) :: ifile type(stream_t) :: stream type(parse_tree_t) :: parse_tree write (u, "(A)") "* Test output: rt_data_2" write (u, "(A)") "* Purpose: initialize global runtime data & &and fill contents" write (u, "(A)") call syntax_model_file_init () call global%global_init () call fix_system_dependencies (global) call global%select_model (var_str ("Test")) call global%set_real (var_str ("sqrts"), & 1000._default, is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known=.true.) call flv%init ([25,25], global%model) call global%set_string (var_str ("$run_id"), & var_str ("run1"), is_known = .true.) call global%set_real (var_str ("luminosity"), & 33._default, is_known = .true.) call syntax_pexpr_init () cut_expr_text = "all Pt > 100 [s]" call ifile_append (ifile, cut_expr_text) call stream_init (stream, ifile) call parse_tree_init_lexpr (parse_tree, stream, .true.) global%pn%cuts_lexpr => parse_tree%get_root_ptr () allocate (global%sample_fmt (2)) global%sample_fmt(1) = "foo_fmt" global%sample_fmt(2) = "bar_fmt" call global%write (u) call parse_tree_final (parse_tree) call stream_final (stream) call ifile_final (ifile) call syntax_pexpr_final () call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: rt_data_2" end subroutine rt_data_2 @ %def rt_data_2 @ \subsubsection{Save and restore} Set up a local runtime data block, change some contents, restore the global block. <>= call test (rt_data_3, "rt_data_3", & "save/restore", & u, results) <>= public :: rt_data_3 <>= subroutine rt_data_3 (u) use event_base, only: event_callback_nop_t integer, intent(in) :: u type(rt_data_t), target :: global, local type(flavor_t), dimension(2) :: flv type(string_t) :: cut_expr_text type(ifile_t) :: ifile type(stream_t) :: stream type(parse_tree_t) :: parse_tree type(prclib_entry_t), pointer :: lib type(event_callback_nop_t) :: event_callback_nop write (u, "(A)") "* Test output: rt_data_3" write (u, "(A)") "* Purpose: initialize global runtime data & &and fill contents;" write (u, "(A)") "* copy to local block and back" write (u, "(A)") write (u, "(A)") "* Init global data" write (u, "(A)") call syntax_model_file_init () call global%global_init () call fix_system_dependencies (global) call global%set_int (var_str ("seed"), & 0, is_known=.true.) call global%select_model (var_str ("Test")) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call flv%init ([25,25], global%model) call global%beam_structure%init_sf (flv%get_name (), [1]) call global%beam_structure%set_sf (1, 1, var_str ("pdf_builtin")) call global%set_string (var_str ("$run_id"), & var_str ("run1"), is_known = .true.) call global%set_real (var_str ("luminosity"), & 33._default, is_known = .true.) call syntax_pexpr_init () cut_expr_text = "all Pt > 100 [s]" call ifile_append (ifile, cut_expr_text) call stream_init (stream, ifile) call parse_tree_init_lexpr (parse_tree, stream, .true.) global%pn%cuts_lexpr => parse_tree%get_root_ptr () allocate (global%sample_fmt (2)) global%sample_fmt(1) = "foo_fmt" global%sample_fmt(2) = "bar_fmt" allocate (lib) call lib%init (var_str ("library_1")) call global%add_prclib (lib) write (u, "(A)") "* Init and modify local data" write (u, "(A)") call local%local_init (global) call local%append_string (var_str ("$integration_method"), intrinsic=.true.) call local%append_string (var_str ("$phs_method"), intrinsic=.true.) call local%activate () write (u, "(1x,A,L1)") "model associated = ", associated (local%model) write (u, "(1x,A,L1)") "library associated = ", associated (local%prclib) write (u, *) call local%model_set_real (var_str ("ms"), 150._default) call local%set_string (var_str ("$integration_method"), & var_str ("midpoint"), is_known = .true.) call local%set_string (var_str ("$phs_method"), & var_str ("single"), is_known = .true.) local%os_data%fc = "Local compiler" allocate (lib) call lib%init (var_str ("library_2")) call local%add_prclib (lib) call local%set_event_callback (event_callback_nop) call local%write (u) write (u, "(A)") write (u, "(A)") "* Restore global data" write (u, "(A)") call local%deactivate (global) write (u, "(1x,A,L1)") "model associated = ", associated (global%model) write (u, "(1x,A,L1)") "library associated = ", associated (global%prclib) write (u, *) call global%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call parse_tree_final (parse_tree) call stream_final (stream) call ifile_final (ifile) call syntax_pexpr_final () call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: rt_data_3" end subroutine rt_data_3 @ %def rt_data_3 @ \subsubsection{Show variables} Display selected variables in the global record. <>= call test (rt_data_4, "rt_data_4", & "show variables", & u, results) <>= public :: rt_data_4 <>= subroutine rt_data_4 (u) integer, intent(in) :: u type(rt_data_t), target :: global type(string_t), dimension(0) :: empty_string_array write (u, "(A)") "* Test output: rt_data_4" write (u, "(A)") "* Purpose: display selected variables" write (u, "(A)") call global%global_init () write (u, "(A)") "* No variables:" write (u, "(A)") call global%write_vars (u, empty_string_array) write (u, "(A)") "* Two variables:" write (u, "(A)") call global%write_vars (u, & [var_str ("?unweighted"), var_str ("$phs_method")]) write (u, "(A)") write (u, "(A)") "* Display whole record with selected variables" write (u, "(A)") call global%write (u, & vars = [var_str ("?unweighted"), var_str ("$phs_method")]) call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: rt_data_4" end subroutine rt_data_4 @ %def rt_data_4 @ \subsubsection{Show parts} Display only selected parts in the state just after (global) initialization. <>= call test (rt_data_5, "rt_data_5", & "show parts", & u, results) <>= public :: rt_data_5 <>= subroutine rt_data_5 (u) integer, intent(in) :: u type(rt_data_t), target :: global write (u, "(A)") "* Test output: rt_data_5" write (u, "(A)") "* Purpose: display parts of rt data" write (u, "(A)") call global%global_init () call global%write_libraries (u) write (u, "(A)") call global%write_beams (u) write (u, "(A)") call global%write_process_stack (u) call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: rt_data_5" end subroutine rt_data_5 @ %def rt_data_5 @ \subsubsection{Local Model} Locally modify a model and restore the global one. We need an auxiliary function to determine the status of a model particle: <>= function is_stable (pdg, global) result (flag) integer, intent(in) :: pdg type(rt_data_t), intent(in) :: global logical :: flag type(flavor_t) :: flv call flv%init (pdg, global%model) flag = flv%is_stable () end function is_stable function is_polarized (pdg, global) result (flag) integer, intent(in) :: pdg type(rt_data_t), intent(in) :: global logical :: flag type(flavor_t) :: flv call flv%init (pdg, global%model) flag = flv%is_polarized () end function is_polarized @ %def is_stable is_polarized <>= call test (rt_data_6, "rt_data_6", & "local model", & u, results) <>= public :: rt_data_6 <>= subroutine rt_data_6 (u) integer, intent(in) :: u type(rt_data_t), target :: global, local type(var_list_t), pointer :: model_vars type(string_t) :: var_name write (u, "(A)") "* Test output: rt_data_6" write (u, "(A)") "* Purpose: apply and keep local modifications to model" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%select_model (var_str ("Test")) write (u, "(A)") "* Original model" write (u, "(A)") call global%write_model_list (u) write (u, *) write (u, "(A,L1)") "s is stable = ", is_stable (25, global) write (u, "(A,L1)") "f is polarized = ", is_polarized (6, global) write (u, *) var_name = "ff" write (u, "(A)", advance="no") "Global model variable: " model_vars => global%model%get_var_list_ptr () call model_vars%write_var (var_name, u) write (u, "(A)") write (u, "(A)") "* Apply local modifications: unstable" write (u, "(A)") call local%local_init (global) call local%activate () call local%model_set_real (var_name, 0.4_default) call local%modify_particle (25, stable = .false., decay = [var_str ("d1")]) call local%modify_particle (6, stable = .false., & decay = [var_str ("f1")], isotropic_decay = .true.) call local%modify_particle (-6, stable = .false., & decay = [var_str ("f2"), var_str ("f3")], diagonal_decay = .true.) call local%model%write (u) write (u, "(A)") write (u, "(A)") "* Further modifications" write (u, "(A)") call local%modify_particle (6, stable = .false., & decay = [var_str ("f1")], & diagonal_decay = .true., isotropic_decay = .false.) call local%modify_particle (-6, stable = .false., & decay = [var_str ("f2"), var_str ("f3")], & diagonal_decay = .false., isotropic_decay = .true.) call local%model%write (u) write (u, "(A)") write (u, "(A)") "* Further modifications: f stable but polarized" write (u, "(A)") call local%modify_particle (6, stable = .true., polarized = .true.) call local%modify_particle (-6, stable = .true.) call local%model%write (u) write (u, "(A)") write (u, "(A)") "* Global model" write (u, "(A)") call global%model%write (u) write (u, *) write (u, "(A,L1)") "s is stable = ", is_stable (25, global) write (u, "(A,L1)") "f is polarized = ", is_polarized (6, global) write (u, "(A)") write (u, "(A)") "* Local model" write (u, "(A)") call local%model%write (u) write (u, *) write (u, "(A,L1)") "s is stable = ", is_stable (25, local) write (u, "(A,L1)") "f is polarized = ", is_polarized (6, local) write (u, *) write (u, "(A)", advance="no") "Global model variable: " model_vars => global%model%get_var_list_ptr () call model_vars%write_var (var_name, u) write (u, "(A)", advance="no") "Local model variable: " associate (model_var_list_ptr => local%model%get_var_list_ptr()) call model_var_list_ptr%write_var (var_name, u) end associate write (u, "(A)") write (u, "(A)") "* Restore global" call local%deactivate (global, keep_local = .true.) write (u, "(A)") write (u, "(A)") "* Global model" write (u, "(A)") call global%model%write (u) write (u, *) write (u, "(A,L1)") "s is stable = ", is_stable (25, global) write (u, "(A,L1)") "f is polarized = ", is_polarized (6, global) write (u, "(A)") write (u, "(A)") "* Local model" write (u, "(A)") call local%model%write (u) write (u, *) write (u, "(A,L1)") "s is stable = ", is_stable (25, local) write (u, "(A,L1)") "f is polarized = ", is_polarized (6, local) write (u, *) write (u, "(A)", advance="no") "Global model variable: " model_vars => global%model%get_var_list_ptr () call model_vars%write_var (var_name, u) write (u, "(A)", advance="no") "Local model variable: " associate (model_var_list_ptr => local%model%get_var_list_ptr()) call model_var_list_ptr%write_var (var_name, u) end associate write (u, "(A)") write (u, "(A)") "* Cleanup" call local%model%final () deallocate (local%model) call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: rt_data_6" end subroutine rt_data_6 @ %def rt_data_6 @ \subsubsection{Result variables} Initialize result variables and check that they are accessible via the global variable list. <>= call test (rt_data_7, "rt_data_7", & "result variables", & u, results) <>= public :: rt_data_7 <>= subroutine rt_data_7 (u) integer, intent(in) :: u type(rt_data_t), target :: global write (u, "(A)") "* Test output: rt_data_7" write (u, "(A)") "* Purpose: set and access result variables" write (u, "(A)") write (u, "(A)") "* Initialize process variables" write (u, "(A)") call global%global_init () call global%process_stack%init_result_vars (var_str ("testproc")) call global%var_list%write_var (& var_str ("integral(testproc)"), u, defined=.true.) call global%var_list%write_var (& var_str ("error(testproc)"), u, defined=.true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: rt_data_7" end subroutine rt_data_7 @ %def rt_data_7 @ \subsubsection{Beam energy} If beam parameters are set, the variable [[sqrts]] is not necessarily the collision energy. The method [[get_sqrts]] fetches the correct value. <>= call test (rt_data_8, "rt_data_8", & "beam energy", & u, results) <>= public :: rt_data_8 <>= subroutine rt_data_8 (u) integer, intent(in) :: u type(rt_data_t), target :: global write (u, "(A)") "* Test output: rt_data_8" write (u, "(A)") "* Purpose: get correct collision energy" write (u, "(A)") write (u, "(A)") "* Initialize" write (u, "(A)") call global%global_init () write (u, "(A)") "* Set sqrts" write (u, "(A)") call global%set_real (var_str ("sqrts"), & 1000._default, is_known = .true.) write (u, "(1x,A," // FMT_19 // ")") "sqrts =", global%get_sqrts () write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: rt_data_8" end subroutine rt_data_8 @ %def rt_data_8 @ \subsubsection{Local variable modifications} <>= call test (rt_data_9, "rt_data_9", & "local variables", & u, results) <>= public :: rt_data_9 <>= subroutine rt_data_9 (u) integer, intent(in) :: u type(rt_data_t), target :: global, local type(var_list_t), pointer :: var_list write (u, "(A)") "* Test output: rt_data_9" write (u, "(A)") "* Purpose: handle local variables" write (u, "(A)") call syntax_model_file_init () write (u, "(A)") "* Initialize global record and set some variables" write (u, "(A)") call global%global_init () call global%select_model (var_str ("Test")) call global%set_real (var_str ("sqrts"), 17._default, is_known = .true.) call global%set_real (var_str ("luminosity"), 2._default, is_known = .true.) call global%model_set_real (var_str ("ff"), 0.5_default) call global%model_set_real (var_str ("gy"), 1.2_default) var_list => global%get_var_list_ptr () call var_list%write_var (var_str ("sqrts"), u, defined=.true.) call var_list%write_var (var_str ("luminosity"), u, defined=.true.) call var_list%write_var (var_str ("ff"), u, defined=.true.) call var_list%write_var (var_str ("gy"), u, defined=.true.) call var_list%write_var (var_str ("mf"), u, defined=.true.) call var_list%write_var (var_str ("x"), u, defined=.true.) write (u, "(A)") write (u, "(1x,A,1x,F5.2)") "sqrts = ", & global%get_rval (var_str ("sqrts")) write (u, "(1x,A,1x,F5.2)") "luminosity = ", & global%get_rval (var_str ("luminosity")) write (u, "(1x,A,1x,F5.2)") "ff = ", & global%get_rval (var_str ("ff")) write (u, "(1x,A,1x,F5.2)") "gy = ", & global%get_rval (var_str ("gy")) write (u, "(1x,A,1x,F5.2)") "mf = ", & global%get_rval (var_str ("mf")) write (u, "(1x,A,1x,F5.2)") "x = ", & global%get_rval (var_str ("x")) write (u, "(A)") write (u, "(A)") "* Create local record with local variables" write (u, "(A)") call local%local_init (global) call local%append_real (var_str ("luminosity"), intrinsic = .true.) call local%append_real (var_str ("x"), user = .true.) call local%activate () var_list => local%get_var_list_ptr () call var_list%write_var (var_str ("sqrts"), u) call var_list%write_var (var_str ("luminosity"), u) call var_list%write_var (var_str ("ff"), u) call var_list%write_var (var_str ("gy"), u) call var_list%write_var (var_str ("mf"), u) call var_list%write_var (var_str ("x"), u, defined=.true.) write (u, "(A)") write (u, "(1x,A,1x,F5.2)") "sqrts = ", & local%get_rval (var_str ("sqrts")) write (u, "(1x,A,1x,F5.2)") "luminosity = ", & local%get_rval (var_str ("luminosity")) write (u, "(1x,A,1x,F5.2)") "ff = ", & local%get_rval (var_str ("ff")) write (u, "(1x,A,1x,F5.2)") "gy = ", & local%get_rval (var_str ("gy")) write (u, "(1x,A,1x,F5.2)") "mf = ", & local%get_rval (var_str ("mf")) write (u, "(1x,A,1x,F5.2)") "x = ", & local%get_rval (var_str ("x")) write (u, "(A)") write (u, "(A)") "* Modify some local variables" write (u, "(A)") call local%set_real (var_str ("luminosity"), 42._default, is_known=.true.) call local%set_real (var_str ("x"), 6.66_default, is_known=.true.) call local%model_set_real (var_str ("ff"), 0.7_default) var_list => local%get_var_list_ptr () call var_list%write_var (var_str ("sqrts"), u) call var_list%write_var (var_str ("luminosity"), u) call var_list%write_var (var_str ("ff"), u) call var_list%write_var (var_str ("gy"), u) call var_list%write_var (var_str ("mf"), u) call var_list%write_var (var_str ("x"), u, defined=.true.) write (u, "(A)") write (u, "(1x,A,1x,F5.2)") "sqrts = ", & local%get_rval (var_str ("sqrts")) write (u, "(1x,A,1x,F5.2)") "luminosity = ", & local%get_rval (var_str ("luminosity")) write (u, "(1x,A,1x,F5.2)") "ff = ", & local%get_rval (var_str ("ff")) write (u, "(1x,A,1x,F5.2)") "gy = ", & local%get_rval (var_str ("gy")) write (u, "(1x,A,1x,F5.2)") "mf = ", & local%get_rval (var_str ("mf")) write (u, "(1x,A,1x,F5.2)") "x = ", & local%get_rval (var_str ("x")) write (u, "(A)") write (u, "(A)") "* Restore globals" write (u, "(A)") call local%deactivate (global) var_list => global%get_var_list_ptr () call var_list%write_var (var_str ("sqrts"), u) call var_list%write_var (var_str ("luminosity"), u) call var_list%write_var (var_str ("ff"), u) call var_list%write_var (var_str ("gy"), u) call var_list%write_var (var_str ("mf"), u) call var_list%write_var (var_str ("x"), u, defined=.true.) write (u, "(A)") write (u, "(1x,A,1x,F5.2)") "sqrts = ", & global%get_rval (var_str ("sqrts")) write (u, "(1x,A,1x,F5.2)") "luminosity = ", & global%get_rval (var_str ("luminosity")) write (u, "(1x,A,1x,F5.2)") "ff = ", & global%get_rval (var_str ("ff")) write (u, "(1x,A,1x,F5.2)") "gy = ", & global%get_rval (var_str ("gy")) write (u, "(1x,A,1x,F5.2)") "mf = ", & global%get_rval (var_str ("mf")) write (u, "(1x,A,1x,F5.2)") "x = ", & global%get_rval (var_str ("x")) write (u, "(A)") write (u, "(A)") "* Cleanup" call local%local_final () call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: rt_data_9" end subroutine rt_data_9 @ %def rt_data_9 @ \subsubsection{Descriptions} <>= call test(rt_data_10, "rt_data_10", & "descriptions", u, results) <>= public :: rt_data_10 <>= subroutine rt_data_10 (u) integer, intent(in) :: u type(rt_data_t) :: global ! type(var_list_t) :: var_list write (u, "(A)") "* Test output: rt_data_10" write (u, "(A)") "* Purpose: display descriptions" write (u, "(A)") call global%var_list%append_real (var_str ("sqrts"), & intrinsic=.true., & description=var_str ('Real variable in order to set the center-of-mass ' // & 'energy for the collisions.')) call global%var_list%append_real (var_str ("luminosity"), 0._default, & intrinsic=.true., & description=var_str ('This specifier \ttt{luminosity = {\em ' // & '}} sets the integrated luminosity (in inverse femtobarns, ' // & 'fb${}^{-1}$) for the event generation of the processes in the ' // & '\sindarin\ input files.')) call global%var_list%append_int (var_str ("seed"), 1234, & intrinsic=.true., & description=var_str ('Integer variable \ttt{seed = {\em }} ' // & 'that allows to set a specific random seed \ttt{num}.')) call global%var_list%append_string (var_str ("$method"), var_str ("omega"), & intrinsic=.true., & description=var_str ('This string variable specifies the method ' // & 'for the matrix elements to be used in the evaluation.')) call global%var_list%append_log (var_str ("?read_color_factors"), .true., & intrinsic=.true., & description=var_str ('This flag decides whether to read QCD ' // & 'color factors from the matrix element provided by each method, ' // & 'or to try and calculate the color factors in \whizard\ internally.')) call global%var_list%sort () call global%write_var_descriptions (u) call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: rt_data_10" end subroutine rt_data_10 @ %def rt_data_10 @ \subsubsection{Export objects} Export objects are variables or other data that should be copied or otherwise applied to corresponding objects in the outer scope. We test appending and retrieval for the export list. <>= call test(rt_data_11, "rt_data_11", & "export objects", u, results) <>= public :: rt_data_11 <>= subroutine rt_data_11 (u) integer, intent(in) :: u type(rt_data_t) :: global type(string_t), dimension(:), allocatable :: exports integer :: i write (u, "(A)") "* Test output: rt_data_11" write (u, "(A)") "* Purpose: handle export object list" write (u, "(A)") write (u, "(A)") "* Empty export list" write (u, "(A)") call global%write_exports (u) write (u, "(A)") "* Add an entry" write (u, "(A)") allocate (exports (1)) exports(1) = var_str ("results") do i = 1, size (exports) write (u, "('+ ',A)") char (exports(i)) end do write (u, *) call global%append_exports (exports) call global%write_exports (u) write (u, "(A)") write (u, "(A)") "* Add more entries, including doubler" write (u, "(A)") deallocate (exports) allocate (exports (3)) exports(1) = var_str ("foo") exports(2) = var_str ("results") exports(3) = var_str ("bar") do i = 1, size (exports) write (u, "('+ ',A)") char (exports(i)) end do write (u, *) call global%append_exports (exports) call global%write_exports (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: rt_data_11" end subroutine rt_data_11 @ %def rt_data_11 @ @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Select implementations} For abstract types (process core, integrator, phase space, etc.), we need a way to dynamically select a concrete type, using either data given by the user or a previous selection of a concrete type. This is done by subroutines in the current module. We would like to put this in the [[me_methods]] folder but it also depends on [[gosam]] and [[openloops]], so it is unclear where to put it. <<[[dispatch_me_methods.f90]]>>= <> module dispatch_me_methods <> <> use physics_defs, only: BORN use diagnostics use sm_qcd use variables, only: var_list_t use models use model_data use prc_core_def use prc_core use prc_test_core use prc_template_me use prc_test use prc_omega use prc_external use prc_gosam use prc_openloops use prc_recola use prc_threshold <> <> contains <> end module dispatch_me_methods @ %def dispatch_me_methods @ \subsection{Process Core Definition} The [[prc_core_def_t]] abstract type can be instantiated by providing a [[$method]] string variable. <>= public :: dispatch_core_def <>= subroutine dispatch_core_def (core_def, prt_in, prt_out, & model, var_list, id, nlo_type, method) class(prc_core_def_t), allocatable, intent(out) :: core_def type(string_t), dimension(:), intent(in) :: prt_in type(string_t), dimension(:), intent(in) :: prt_out type(model_t), pointer, intent(in) :: model type(var_list_t), intent(in) :: var_list type(string_t), intent(in), optional :: id integer, intent(in), optional :: nlo_type type(string_t), intent(in), optional :: method type(string_t) :: model_name, meth type(string_t) :: ufo_path type(string_t) :: restrictions logical :: ufo logical :: cms_scheme logical :: openmp_support logical :: report_progress logical :: diags, diags_color logical :: write_phs_output type(string_t) :: extra_options, correction_type integer :: nlo integer :: alpha_power integer :: alphas_power if (present (method)) then meth = method else meth = var_list%get_sval (var_str ("$method")) end if if (debug_on) call msg_debug2 (D_CORE, "dispatch_core_def") if (associated (model)) then model_name = model%get_name () cms_scheme = model%get_scheme () == "Complex_Mass_Scheme" ufo = model%is_ufo_model () ufo_path = model%get_ufo_path () else model_name = "" cms_scheme = .false. ufo = .false. end if restrictions = var_list%get_sval (& var_str ("$restrictions")) diags = var_list%get_lval (& var_str ("?vis_diags")) diags_color = var_list%get_lval (& var_str ("?vis_diags_color")) openmp_support = var_list%get_lval (& var_str ("?omega_openmp")) report_progress = var_list%get_lval (& var_str ("?report_progress")) write_phs_output = var_list%get_lval (& var_str ("?omega_write_phs_output")) extra_options = var_list%get_sval (& var_str ("$omega_flags")) nlo = BORN; if (present (nlo_type)) nlo = nlo_type alpha_power = var_list%get_ival (var_str ("alpha_power")) alphas_power = var_list%get_ival (var_str ("alphas_power")) correction_type = var_list%get_sval (var_str ("$nlo_correction_type")) if (debug_on) call msg_debug2 (D_CORE, "dispatching core method: ", meth) select case (char (meth)) case ("unit_test") allocate (prc_test_def_t :: core_def) select type (core_def) type is (prc_test_def_t) call core_def%init (model_name, prt_in, prt_out) end select case ("template") allocate (template_me_def_t :: core_def) select type (core_def) type is (template_me_def_t) call core_def%init (model, prt_in, prt_out, unity = .false.) end select case ("template_unity") allocate (template_me_def_t :: core_def) select type (core_def) type is (template_me_def_t) call core_def%init (model, prt_in, prt_out, unity = .true.) end select case ("omega") allocate (omega_def_t :: core_def) select type (core_def) type is (omega_def_t) call core_def%init (model_name, prt_in, prt_out, & .false., ufo, ufo_path, & restrictions, cms_scheme, & openmp_support, report_progress, write_phs_output, & extra_options, diags, diags_color) end select case ("ovm") allocate (omega_def_t :: core_def) select type (core_def) type is (omega_def_t) call core_def%init (model_name, prt_in, prt_out, & .true., .false., var_str (""), & restrictions, cms_scheme, & openmp_support, report_progress, write_phs_output, & extra_options, diags, diags_color) end select case ("gosam") allocate (gosam_def_t :: core_def) select type (core_def) type is (gosam_def_t) if (present (id)) then call core_def%init (id, model_name, prt_in, & prt_out, nlo, restrictions, var_list) else call msg_fatal ("Dispatch GoSam def: No id!") end if end select case ("openloops") allocate (openloops_def_t :: core_def) select type (core_def) type is (openloops_def_t) if (present (id)) then call core_def%init (id, model_name, prt_in, & prt_out, nlo, restrictions, var_list) else call msg_fatal ("Dispatch OpenLoops def: No id!") end if end select case ("recola") call abort_if_recola_not_active () allocate (recola_def_t :: core_def) select type (core_def) type is (recola_def_t) if (present (id)) then call core_def%init (id, model_name, prt_in, prt_out, & nlo, alpha_power, alphas_power, correction_type, & restrictions) else call msg_fatal ("Dispatch RECOLA def: No id!") end if end select case ("dummy") allocate (prc_external_test_def_t :: core_def) select type (core_def) type is (prc_external_test_def_t) if (present (id)) then call core_def%init (id, model_name, prt_in, prt_out) else call msg_fatal ("Dispatch User-Defined Test def: No id!") end if end select case ("threshold") allocate (threshold_def_t :: core_def) select type (core_def) type is (threshold_def_t) if (present (id)) then call core_def%init (id, model_name, prt_in, prt_out, & nlo, restrictions) else call msg_fatal ("Dispatch Threshold def: No id!") end if end select case default call msg_fatal ("Process configuration: method '" & // char (meth) // "' not implemented") end select end subroutine dispatch_core_def @ %def dispatch_core_def @ \subsection{Process core allocation} Here we allocate an object of abstract type [[prc_core_t]] with a concrete type that matches a process definition. The [[prc_omega_t]] extension will require the current parameter set, so we take the opportunity to grab it from the model. <>= public :: dispatch_core <>= subroutine dispatch_core (core, core_def, model, & helicity_selection, qcd, use_color_factors, has_beam_pol) class(prc_core_t), allocatable, intent(inout) :: core class(prc_core_def_t), intent(in) :: core_def class(model_data_t), intent(in), target, optional :: model type(helicity_selection_t), intent(in), optional :: helicity_selection type(qcd_t), intent(in), optional :: qcd logical, intent(in), optional :: use_color_factors logical, intent(in), optional :: has_beam_pol select type (core_def) type is (prc_test_def_t) allocate (test_t :: core) type is (template_me_def_t) allocate (prc_template_me_t :: core) select type (core) type is (prc_template_me_t) call core%set_parameters (model) end select class is (omega_def_t) if (.not. allocated (core)) allocate (prc_omega_t :: core) select type (core) type is (prc_omega_t) call core%set_parameters (model, & helicity_selection, qcd, use_color_factors) end select type is (gosam_def_t) if (.not. allocated (core)) allocate (prc_gosam_t :: core) select type (core) type is (prc_gosam_t) call core%set_parameters (qcd) end select type is (openloops_def_t) if (.not. allocated (core)) allocate (prc_openloops_t :: core) select type (core) type is (prc_openloops_t) call core%set_parameters (qcd) end select type is (recola_def_t) if (.not. allocated (core)) allocate (prc_recola_t :: core) select type (core) type is (prc_recola_t) call core%set_parameters (qcd, model) end select type is (prc_external_test_def_t) if (.not. allocated (core)) allocate (prc_external_test_t :: core) select type (core) type is (prc_external_test_t) call core%set_parameters (qcd, model) end select type is (threshold_def_t) if (.not. allocated (core)) allocate (prc_threshold_t :: core) select type (core) type is (prc_threshold_t) call core%set_parameters (qcd, model) call core%set_beam_pol (has_beam_pol) end select class default call msg_bug ("Process core: unexpected process definition type") end select end subroutine dispatch_core @ %def dispatch_core @ \subsection{Process core update and restoration} Here we take an existing object of abstract type [[prc_core_t]] and update the parameters as given by the current state of [[model]]. Optionally, we can save the previous state as [[saved_core]]. The second routine restores the original from the save. (In the test case, there is no possible update.) <>= public :: dispatch_core_update public :: dispatch_core_restore <>= subroutine dispatch_core_update & (core, model, helicity_selection, qcd, saved_core) class(prc_core_t), allocatable, intent(inout) :: core class(model_data_t), intent(in), optional, target :: model type(helicity_selection_t), intent(in), optional :: helicity_selection type(qcd_t), intent(in), optional :: qcd class(prc_core_t), allocatable, intent(inout), optional :: saved_core if (present (saved_core)) then allocate (saved_core, source = core) end if select type (core) type is (test_t) type is (prc_omega_t) call core%set_parameters (model, helicity_selection, qcd) call core%activate_parameters () class is (prc_external_t) call msg_message ("Updating user defined cores is not implemented yet.") class default call msg_bug ("Process core update: unexpected process definition type") end select end subroutine dispatch_core_update subroutine dispatch_core_restore (core, saved_core) class(prc_core_t), allocatable, intent(inout) :: core class(prc_core_t), allocatable, intent(inout) :: saved_core call move_alloc (from = saved_core, to = core) select type (core) type is (test_t) type is (prc_omega_t) call core%activate_parameters () class default call msg_bug ("Process core restore: unexpected process definition type") end select end subroutine dispatch_core_restore @ %def dispatch_core_update dispatch_core_restore @ \subsection{Unit Tests} Test module, followed by the corresponding implementation module. <<[[dispatch_ut.f90]]>>= <> module dispatch_ut use unit_tests use dispatch_uti <> <> <> contains <> end module dispatch_ut @ %def dispatch_ut @ <<[[dispatch_uti.f90]]>>= <> module dispatch_uti <> <> use os_interface, only: os_data_t use physics_defs, only: ELECTRON, PROTON use sm_qcd, only: qcd_t use flavors, only: flavor_t use interactions, only: reset_interaction_counter use pdg_arrays, only: pdg_array_t, assignment(=) use prc_core_def, only: prc_core_def_t use prc_test_core, only: test_t use prc_core, only: prc_core_t use prc_test, only: prc_test_def_t use prc_omega, only: omega_def_t, prc_omega_t use sf_mappings, only: sf_channel_t use sf_base, only: sf_data_t, sf_config_t use phs_base, only: phs_channel_collection_t use variables, only: var_list_t use model_data, only: model_data_t use models, only: syntax_model_file_init, syntax_model_file_final use rt_data, only: rt_data_t use dispatch_phase_space, only: dispatch_sf_channels use dispatch_beams, only: sf_prop_t, dispatch_qcd use dispatch_beams, only: dispatch_sf_config, dispatch_sf_data use dispatch_me_methods, only: dispatch_core_def, dispatch_core use dispatch_me_methods, only: dispatch_core_update, dispatch_core_restore use sf_base_ut, only: sf_test_data_t <> <> <> contains <> <> end module dispatch_uti @ %def dispatch_uti @ API: driver for the unit tests below. <>= public :: dispatch_test <>= subroutine dispatch_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine dispatch_test @ %def dispatch_test @ \subsubsection{Select type: process definition} <>= call test (dispatch_1, "dispatch_1", & "process configuration method", & u, results) <>= public :: dispatch_1 <>= subroutine dispatch_1 (u) integer, intent(in) :: u type(string_t), dimension(2) :: prt_in, prt_out type(rt_data_t), target :: global class(prc_core_def_t), allocatable :: core_def write (u, "(A)") "* Test output: dispatch_1" write (u, "(A)") "* Purpose: select process configuration method" write (u, "(A)") call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) prt_in = [var_str ("a"), var_str ("b")] prt_out = [var_str ("c"), var_str ("d")] write (u, "(A)") "* Allocate core_def as prc_test_def" call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call dispatch_core_def (core_def, prt_in, prt_out, global%model, global%var_list) select type (core_def) type is (prc_test_def_t) call core_def%write (u) end select deallocate (core_def) write (u, "(A)") write (u, "(A)") "* Allocate core_def as omega_def" write (u, "(A)") call global%set_string (var_str ("$method"), & var_str ("omega"), is_known = .true.) call dispatch_core_def (core_def, prt_in, prt_out, global%model, global%var_list) select type (core_def) type is (omega_def_t) call core_def%write (u) end select call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: dispatch_1" end subroutine dispatch_1 @ %def dispatch_1 @ \subsubsection{Select type: process core} <>= call test (dispatch_2, "dispatch_2", & "process core", & u, results) <>= public :: dispatch_2 <>= subroutine dispatch_2 (u) integer, intent(in) :: u type(string_t), dimension(2) :: prt_in, prt_out type(rt_data_t), target :: global class(prc_core_def_t), allocatable :: core_def class(prc_core_t), allocatable :: core write (u, "(A)") "* Test output: dispatch_2" write (u, "(A)") "* Purpose: select process configuration method" write (u, "(A)") " and allocate process core" write (u, "(A)") call syntax_model_file_init () call global%global_init () prt_in = [var_str ("a"), var_str ("b")] prt_out = [var_str ("c"), var_str ("d")] write (u, "(A)") "* Allocate core as test_t" write (u, "(A)") call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call dispatch_core_def (core_def, prt_in, prt_out, global%model, global%var_list) call dispatch_core (core, core_def) select type (core) type is (test_t) call core%write (u) end select deallocate (core) deallocate (core_def) write (u, "(A)") write (u, "(A)") "* Allocate core as prc_omega_t" write (u, "(A)") call global%set_string (var_str ("$method"), & var_str ("omega"), is_known = .true.) call dispatch_core_def (core_def, prt_in, prt_out, global%model, global%var_list) call global%select_model (var_str ("Test")) call global%set_log (& var_str ("?helicity_selection_active"), & .true., is_known = .true.) call global%set_real (& var_str ("helicity_selection_threshold"), & 1e9_default, is_known = .true.) call global%set_int (& var_str ("helicity_selection_cutoff"), & 10, is_known = .true.) call dispatch_core (core, core_def, & global%model, & global%get_helicity_selection ()) call core_def%allocate_driver (core%driver, var_str ("")) select type (core) type is (prc_omega_t) call core%write (u) end select call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: dispatch_2" end subroutine dispatch_2 @ %def dispatch_2 @ \subsubsection{Select type: structure-function data} This is an extra dispatcher that enables the test structure functions. This procedure should be assigned to the [[dispatch_sf_data_extra]] hook before any tests are executed. <>= public :: dispatch_sf_data_test <>= subroutine dispatch_sf_data_test (data, sf_method, i_beam, sf_prop, & var_list, var_list_global, model, os_data, sqrts, pdg_in, pdg_prc, polarized) class(sf_data_t), allocatable, intent(inout) :: data type(string_t), intent(in) :: sf_method integer, dimension(:), intent(in) :: i_beam type(var_list_t), intent(in) :: var_list type(var_list_t), intent(inout) :: var_list_global class(model_data_t), target, intent(in) :: model type(os_data_t), intent(in) :: os_data real(default), intent(in) :: sqrts type(pdg_array_t), dimension(:), intent(inout) :: pdg_in type(pdg_array_t), dimension(:,:), intent(in) :: pdg_prc type(sf_prop_t), intent(inout) :: sf_prop logical, intent(in) :: polarized select case (char (sf_method)) case ("sf_test_0", "sf_test_1") allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) select case (char (sf_method)) case ("sf_test_0"); call data%init (model, pdg_in(i_beam(1))) case ("sf_test_1"); call data%init (model, pdg_in(i_beam(1)),& mode = 1) end select end select end select end subroutine dispatch_sf_data_test @ %def dispatch_sf_data_test @ The actual test. We can't move this to [[beams]] as it depends on [[model_features]] for the [[model_list_t]]. <>= call test (dispatch_7, "dispatch_7", & "structure-function data", & u, results) <>= public :: dispatch_7 <>= subroutine dispatch_7 (u) integer, intent(in) :: u type(rt_data_t), target :: global type(os_data_t) :: os_data type(string_t) :: prt, sf_method type(sf_prop_t) :: sf_prop class(sf_data_t), allocatable :: data type(pdg_array_t), dimension(1) :: pdg_in type(pdg_array_t), dimension(1,1) :: pdg_prc type(pdg_array_t), dimension(1) :: pdg_out integer, dimension(:), allocatable :: pdg1 write (u, "(A)") "* Test output: dispatch_7" write (u, "(A)") "* Purpose: select and configure & &structure function data" write (u, "(A)") call global%global_init () call os_data%init () call syntax_model_file_init () call global%select_model (var_str ("QCD")) call reset_interaction_counter () call global%set_real (var_str ("sqrts"), & 14000._default, is_known = .true.) prt = "p" call global%beam_structure%init_sf ([prt, prt], [1]) pdg_in = 2212 write (u, "(A)") "* Allocate data as sf_pdf_builtin_t" write (u, "(A)") sf_method = "pdf_builtin" call dispatch_sf_data (data, sf_method, [1], sf_prop, & global%get_var_list_ptr (), global%var_list, & global%model, global%os_data, global%get_sqrts (), & pdg_in, pdg_prc, .false.) call data%write (u) call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(A)") write (u, "(1x,A,99(1x,I0))") "PDG(out) = ", pdg1 deallocate (data) write (u, "(A)") write (u, "(A)") "* Allocate data for different PDF set" write (u, "(A)") pdg_in = 2212 call global%set_string (var_str ("$pdf_builtin_set"), & var_str ("CTEQ6M"), is_known = .true.) sf_method = "pdf_builtin" call dispatch_sf_data (data, sf_method, [1], sf_prop, & global%get_var_list_ptr (), global%var_list, & global%model, global%os_data, global%get_sqrts (), & pdg_in, pdg_prc, .false.) call data%write (u) call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(A)") write (u, "(1x,A,99(1x,I0))") "PDG(out) = ", pdg1 deallocate (data) call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: dispatch_7" end subroutine dispatch_7 @ %def dispatch_7 @ \subsubsection{Beam structure} The actual test. We can't move this to [[beams]] as it depends on [[model_features]] for the [[model_list_t]]. <>= call test (dispatch_8, "dispatch_8", & "beam structure", & u, results) <>= public :: dispatch_8 <>= subroutine dispatch_8 (u) integer, intent(in) :: u type(rt_data_t), target :: global type(os_data_t) :: os_data type(flavor_t), dimension(2) :: flv type(sf_config_t), dimension(:), allocatable :: sf_config type(sf_prop_t) :: sf_prop type(sf_channel_t), dimension(:), allocatable :: sf_channel type(phs_channel_collection_t) :: coll type(string_t) :: sf_string integer :: i type(pdg_array_t), dimension (2,1) :: pdg_prc write (u, "(A)") "* Test output: dispatch_8" write (u, "(A)") "* Purpose: configure a structure-function chain" write (u, "(A)") call global%global_init () call os_data%init () call syntax_model_file_init () call global%select_model (var_str ("QCD")) write (u, "(A)") "* Allocate LHC beams with PDF builtin" write (u, "(A)") call flv(1)%init (PROTON, global%model) call flv(2)%init (PROTON, global%model) call reset_interaction_counter () call global%set_real (var_str ("sqrts"), & 14000._default, is_known = .true.) call global%beam_structure%init_sf (flv%get_name (), [1]) call global%beam_structure%set_sf (1, 1, var_str ("pdf_builtin")) call dispatch_sf_config (sf_config, sf_prop, global%beam_structure, & global%get_var_list_ptr (), global%var_list, & global%model, global%os_data, global%get_sqrts (), pdg_prc) do i = 1, size (sf_config) call sf_config(i)%write (u) end do call dispatch_sf_channels (sf_channel, sf_string, sf_prop, coll, & global%var_list, global%get_sqrts(), global%beam_structure) write (u, "(1x,A)") "Mapping configuration:" do i = 1, size (sf_channel) write (u, "(2x)", advance = "no") call sf_channel(i)%write (u) end do write (u, "(A)") write (u, "(A)") "* Allocate ILC beams with CIRCE1" write (u, "(A)") call global%select_model (var_str ("QED")) call flv(1)%init ( ELECTRON, global%model) call flv(2)%init (-ELECTRON, global%model) call reset_interaction_counter () call global%set_real (var_str ("sqrts"), & 500._default, is_known = .true.) call global%set_log (var_str ("?circe1_generate"), & .false., is_known = .true.) call global%beam_structure%init_sf (flv%get_name (), [1]) call global%beam_structure%set_sf (1, 1, var_str ("circe1")) call dispatch_sf_config (sf_config, sf_prop, global%beam_structure, & global%get_var_list_ptr (), global%var_list, & global%model, global%os_data, global%get_sqrts (), pdg_prc) do i = 1, size (sf_config) call sf_config(i)%write (u) end do call dispatch_sf_channels (sf_channel, sf_string, sf_prop, coll, & global%var_list, global%get_sqrts(), global%beam_structure) write (u, "(1x,A)") "Mapping configuration:" do i = 1, size (sf_channel) write (u, "(2x)", advance = "no") call sf_channel(i)%write (u) end do write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: dispatch_8" end subroutine dispatch_8 @ %def dispatch_8 @ \subsubsection{Update process core parameters} This test dispatches a process core, temporarily modifies parameters, then restores the original. <>= call test (dispatch_10, "dispatch_10", & "process core update", & u, results) <>= public :: dispatch_10 <>= subroutine dispatch_10 (u) integer, intent(in) :: u type(string_t), dimension(2) :: prt_in, prt_out type(rt_data_t), target :: global class(prc_core_def_t), allocatable :: core_def class(prc_core_t), allocatable :: core, saved_core type(var_list_t), pointer :: model_vars write (u, "(A)") "* Test output: dispatch_10" write (u, "(A)") "* Purpose: select process configuration method," write (u, "(A)") " allocate process core," write (u, "(A)") " temporarily reset parameters" write (u, "(A)") call syntax_model_file_init () call global%global_init () prt_in = [var_str ("a"), var_str ("b")] prt_out = [var_str ("c"), var_str ("d")] write (u, "(A)") "* Allocate core as prc_omega_t" write (u, "(A)") call global%set_string (var_str ("$method"), & var_str ("omega"), is_known = .true.) call dispatch_core_def (core_def, prt_in, prt_out, global%model, global%var_list) call global%select_model (var_str ("Test")) call dispatch_core (core, core_def, global%model) call core_def%allocate_driver (core%driver, var_str ("")) select type (core) type is (prc_omega_t) call core%write (u) end select write (u, "(A)") write (u, "(A)") "* Update core with modified model and helicity selection" write (u, "(A)") model_vars => global%model%get_var_list_ptr () call model_vars%set_real (var_str ("gy"), 2._default, & is_known = .true.) call global%model%update_parameters () call global%set_log (& var_str ("?helicity_selection_active"), & .true., is_known = .true.) call global%set_real (& var_str ("helicity_selection_threshold"), & 2e10_default, is_known = .true.) call global%set_int (& var_str ("helicity_selection_cutoff"), & 5, is_known = .true.) call dispatch_core_update (core, & global%model, & global%get_helicity_selection (), & saved_core = saved_core) select type (core) type is (prc_omega_t) call core%write (u) end select write (u, "(A)") write (u, "(A)") "* Restore core from save" write (u, "(A)") call dispatch_core_restore (core, saved_core) select type (core) type is (prc_omega_t) call core%write (u) end select call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: dispatch_10" end subroutine dispatch_10 @ %def dispatch_10 @ \subsubsection{QCD Coupling} This test dispatches an [[qcd]] object, which is used to compute the (running) coupling by one of several possible methods. We can't move this to [[beams]] as it depends on [[model_features]] for the [[model_list_t]]. <>= call test (dispatch_11, "dispatch_11", & "QCD coupling", & u, results) <>= public :: dispatch_11 <>= subroutine dispatch_11 (u) integer, intent(in) :: u type(rt_data_t), target :: global type(var_list_t), pointer :: model_vars type(qcd_t) :: qcd write (u, "(A)") "* Test output: dispatch_11" write (u, "(A)") "* Purpose: select QCD coupling formula" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%select_model (var_str ("SM")) model_vars => global%get_var_list_ptr () write (u, "(A)") "* Allocate alpha_s as fixed" write (u, "(A)") call global%set_log (var_str ("?alphas_is_fixed"), & .true., is_known = .true.) call dispatch_qcd (qcd, global%get_var_list_ptr (), global%os_data) call qcd%write (u) write (u, "(A)") write (u, "(A)") "* Allocate alpha_s as running (built-in)" write (u, "(A)") call global%set_log (var_str ("?alphas_is_fixed"), & .false., is_known = .true.) call global%set_log (var_str ("?alphas_from_mz"), & .true., is_known = .true.) call global%set_int & (var_str ("alphas_order"), 1, is_known = .true.) call model_vars%set_real (var_str ("alphas"), 0.1234_default, & is_known=.true.) call model_vars%set_real (var_str ("mZ"), 91.234_default, & is_known=.true.) call dispatch_qcd (qcd, global%get_var_list_ptr (), global%os_data) call qcd%write (u) write (u, "(A)") write (u, "(A)") "* Allocate alpha_s as running (built-in, Lambda defined)" write (u, "(A)") call global%set_log (var_str ("?alphas_from_mz"), & .false., is_known = .true.) call global%set_log (& var_str ("?alphas_from_lambda_qcd"), & .true., is_known = .true.) call global%set_real & (var_str ("lambda_qcd"), 250.e-3_default, & is_known=.true.) call global%set_int & (var_str ("alphas_order"), 2, is_known = .true.) call global%set_int & (var_str ("alphas_nf"), 4, is_known = .true.) call dispatch_qcd (qcd, global%get_var_list_ptr (), global%os_data) call qcd%write (u) write (u, "(A)") write (u, "(A)") "* Allocate alpha_s as running (using builtin PDF set)" write (u, "(A)") call global%set_log (& var_str ("?alphas_from_lambda_qcd"), & .false., is_known = .true.) call global%set_log & (var_str ("?alphas_from_pdf_builtin"), & .true., is_known = .true.) call dispatch_qcd (qcd, global%get_var_list_ptr (), global%os_data) call qcd%write (u) call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: dispatch_11" end subroutine dispatch_11 @ %def dispatch_11 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Process Configuration} This module communicates between the toplevel command structure with its runtime data set and the process-library handling modules which collect the definition of individual processes. Its primary purpose is to select from the available matrix-element generating methods and configure the entry in the process library accordingly. <<[[process_configurations.f90]]>>= <> module process_configurations <> <> use diagnostics use io_units use physics_defs, only: BORN, NLO_VIRTUAL, NLO_REAL, NLO_DGLAP, & NLO_SUBTRACTION, NLO_MISMATCH use models use prc_core_def use particle_specifiers use process_libraries use rt_data use variables, only: var_list_t use dispatch_me_methods, only: dispatch_core_def use prc_external, only: prc_external_def_t <> <> <> contains <> end module process_configurations @ %def process_configurations @ \subsection{Data Type} <>= public :: process_configuration_t <>= type :: process_configuration_t type(process_def_entry_t), pointer :: entry => null () type(string_t) :: id integer :: num_id = 0 contains <> end type process_configuration_t @ %def process_configuration_t @ Output (for unit tests). <>= procedure :: write => process_configuration_write <>= subroutine process_configuration_write (config, unit) class(process_configuration_t), intent(in) :: config integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(A)") "Process configuration:" if (associated (config%entry)) then call config%entry%write (u) else write (u, "(1x,3A)") "ID = '", char (config%id), "'" write (u, "(1x,A,1x,I0)") "num ID =", config%num_id write (u, "(2x,A)") "[no entry]" end if end subroutine process_configuration_write @ %def process_configuration_write @ Initialize a process. We only need the name, the number of incoming particles, and the number of components. <>= procedure :: init => process_configuration_init <>= subroutine process_configuration_init & (config, prc_name, n_in, n_components, model, var_list, & nlo_process, negative_sf) class(process_configuration_t), intent(out) :: config type(string_t), intent(in) :: prc_name integer, intent(in) :: n_in integer, intent(in) :: n_components type(model_t), intent(in), pointer :: model type(var_list_t), intent(in) :: var_list logical, intent(in), optional :: nlo_process, negative_sf logical :: nlo_proc, neg_sf logical :: requires_resonances if (debug_on) call msg_debug (D_CORE, "process_configuration_init") config%id = prc_name if (present (nlo_process)) then nlo_proc = nlo_process else nlo_proc = .false. end if if (present (negative_sf)) then neg_sf = negative_sf else neg_sf = .false. end if requires_resonances = var_list%get_lval (var_str ("?resonance_history")) if (debug_on) call msg_debug (D_CORE, "nlo_process", nlo_proc) allocate (config%entry) if (var_list%is_known (var_str ("process_num_id"))) then config%num_id = & var_list%get_ival (var_str ("process_num_id")) call config%entry%init (prc_name, & model = model, n_in = n_in, n_components = n_components, & num_id = config%num_id, & nlo_process = nlo_proc, & negative_sf = neg_sf, & requires_resonances = requires_resonances) else call config%entry%init (prc_name, & model = model, n_in = n_in, n_components = n_components, & nlo_process = nlo_proc, & negative_sf = neg_sf, & requires_resonances = requires_resonances) end if end subroutine process_configuration_init @ %def process_configuration_init @ Initialize a process component. The details depend on the process method, which determines the type of the process component core. We set the incoming and outgoing particles (as strings, to be interpreted by the process driver). All other information is taken from the variable list. The dispatcher gets only the names of the particles. The process component definition gets the complete specifiers which contains a polarization flag and names of decay processes, where applicable. <>= procedure :: setup_component => process_configuration_setup_component <>= subroutine process_configuration_setup_component & (config, i_component, prt_in, prt_out, model, var_list, & nlo_type, can_be_integrated) class(process_configuration_t), intent(inout) :: config integer, intent(in) :: i_component type(prt_spec_t), dimension(:), intent(in) :: prt_in type(prt_spec_t), dimension(:), intent(in) :: prt_out type(model_t), pointer, intent(in) :: model type(var_list_t), intent(in) :: var_list integer, intent(in), optional :: nlo_type logical, intent(in), optional :: can_be_integrated type(string_t), dimension(:), allocatable :: prt_str_in type(string_t), dimension(:), allocatable :: prt_str_out class(prc_core_def_t), allocatable :: core_def type(string_t) :: method type(string_t) :: born_me_method type(string_t) :: real_tree_me_method type(string_t) :: loop_me_method type(string_t) :: correlation_me_method type(string_t) :: dglap_me_method integer :: i if (debug_on) call msg_debug2 (D_CORE, "process_configuration_setup_component") allocate (prt_str_in (size (prt_in))) allocate (prt_str_out (size (prt_out))) forall (i = 1:size (prt_in)) prt_str_in(i) = prt_in(i)% get_name () forall (i = 1:size (prt_out)) prt_str_out(i) = prt_out(i)%get_name () method = var_list%get_sval (var_str ("$method")) if (present (nlo_type)) then select case (nlo_type) case (BORN) born_me_method = var_list%get_sval (var_str ("$born_me_method")) if (born_me_method /= var_str ("")) then method = born_me_method end if case (NLO_VIRTUAL) loop_me_method = var_list%get_sval (var_str ("$loop_me_method")) if (loop_me_method /= var_str ("")) then method = loop_me_method end if case (NLO_REAL) real_tree_me_method = & var_list%get_sval (var_str ("$real_tree_me_method")) if (real_tree_me_method /= var_str ("")) then method = real_tree_me_method end if case (NLO_DGLAP) dglap_me_method = & var_list%get_sval (var_str ("$dglap_me_method")) if (dglap_me_method /= var_str ("")) then method = dglap_me_method end if case (NLO_SUBTRACTION,NLO_MISMATCH) correlation_me_method = & var_list%get_sval (var_str ("$correlation_me_method")) if (correlation_me_method /= var_str ("")) then method = correlation_me_method end if case default end select end if call dispatch_core_def (core_def, prt_str_in, prt_str_out, & model, var_list, config%id, nlo_type, method) select type (core_def) class is (prc_external_def_t) if (present (can_be_integrated)) then call core_def%set_active_writer (can_be_integrated) else call msg_fatal ("Cannot decide if external core is integrated!") end if end select if (debug_on) call msg_debug2 (D_CORE, "import_component with method ", method) call config%entry%import_component (i_component, & n_out = size (prt_out), & prt_in = prt_in, & prt_out = prt_out, & method = method, & variant = core_def, & nlo_type = nlo_type, & can_be_integrated = can_be_integrated) end subroutine process_configuration_setup_component @ %def process_configuration_setup_component @ <>= procedure :: set_fixed_emitter => process_configuration_set_fixed_emitter <>= subroutine process_configuration_set_fixed_emitter (config, i, emitter) class(process_configuration_t), intent(inout) :: config integer, intent(in) :: i, emitter call config%entry%set_fixed_emitter (i, emitter) end subroutine process_configuration_set_fixed_emitter @ %def process_configuration_set_fixed_emitter @ <>= procedure :: set_coupling_powers => process_configuration_set_coupling_powers <>= subroutine process_configuration_set_coupling_powers & (config, alpha_power, alphas_power) class(process_configuration_t), intent(inout) :: config integer, intent(in) :: alpha_power, alphas_power call config%entry%set_coupling_powers (alpha_power, alphas_power) end subroutine process_configuration_set_coupling_powers @ %def process_configuration_set_coupling_powers @ <>= procedure :: set_component_associations => & process_configuration_set_component_associations <>= subroutine process_configuration_set_component_associations & (config, i_list, remnant, use_real_finite, mismatch) class(process_configuration_t), intent(inout) :: config integer, dimension(:), intent(in) :: i_list logical, intent(in) :: remnant, use_real_finite, mismatch integer :: i_component do i_component = 1, config%entry%get_n_components () if (any (i_list == i_component)) then call config%entry%set_associated_components (i_component, & i_list, remnant, use_real_finite, mismatch) end if end do end subroutine process_configuration_set_component_associations @ %def process_configuration_set_component_associations @ Record a process configuration: append it to the currently selected process definition library. <>= procedure :: record => process_configuration_record <>= subroutine process_configuration_record (config, global) class(process_configuration_t), intent(inout) :: config type(rt_data_t), intent(inout) :: global if (associated (global%prclib)) then call global%prclib%open () call global%prclib%append (config%entry) if (config%num_id /= 0) then write (msg_buffer, "(5A,I0,A)") "Process library '", & char (global%prclib%get_name ()), & "': recorded process '", char (config%id), "' (", & config%num_id, ")" else write (msg_buffer, "(5A)") "Process library '", & char (global%prclib%get_name ()), & "': recorded process '", char (config%id), "'" end if call msg_message () else call msg_fatal ("Recording process '" // char (config%id) & // "': active process library undefined") end if end subroutine process_configuration_record @ %def process_configuration_record @ \subsection{Unit Tests} Test module, followed by the corresponding implementation module. <<[[process_configurations_ut.f90]]>>= <> module process_configurations_ut use unit_tests use process_configurations_uti <> <> <> contains <> end module process_configurations_ut @ %def process_configurations_ut @ <<[[process_configurations_uti.f90]]>>= <> module process_configurations_uti <> use particle_specifiers, only: new_prt_spec use prclib_stacks use models use rt_data use process_configurations <> <> <> contains <> <> end module process_configurations_uti @ %def process_configurations_uti @ API: driver for the unit tests below. <>= public :: process_configurations_test <>= subroutine process_configurations_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine process_configurations_test @ %def process_configurations_test @ \subsubsection{Minimal setup} The workflow for setting up a minimal process configuration with the test matrix element method. We wrap this in a public procedure, so we can reuse it in later modules. The procedure prepares a process definition list for two processes (one [[prc_test]] and one [[omega]] type) and appends this to the process library stack in the global data set. The [[mode]] argument determines which processes to build. The [[procname]] argument replaces the predefined procname(s). This is re-exported by the UT module. <>= public :: prepare_test_library <>= subroutine prepare_test_library (global, libname, mode, procname) type(rt_data_t), intent(inout), target :: global type(string_t), intent(in) :: libname integer, intent(in) :: mode type(string_t), intent(in), dimension(:), optional :: procname type(prclib_entry_t), pointer :: lib type(string_t) :: prc_name type(string_t), dimension(:), allocatable :: prt_in, prt_out integer :: n_components type(process_configuration_t) :: prc_config if (.not. associated (global%prclib_stack%get_first_ptr ())) then allocate (lib) call lib%init (libname) call global%add_prclib (lib) end if if (btest (mode, 0)) then call global%select_model (var_str ("Test")) if (present (procname)) then prc_name = procname(1) else prc_name = "prc_config_a" end if n_components = 1 allocate (prt_in (2), prt_out (2)) prt_in = [var_str ("s"), var_str ("s")] prt_out = [var_str ("s"), var_str ("s")] call global%set_string (var_str ("$method"),& var_str ("unit_test"), is_known = .true.) call prc_config%init (prc_name, & size (prt_in), n_components, & global%model, global%var_list) call prc_config%setup_component (1, & new_prt_spec (prt_in), new_prt_spec (prt_out), & global%model, global%var_list) call prc_config%record (global) deallocate (prt_in, prt_out) end if if (btest (mode, 1)) then call global%select_model (var_str ("QED")) if (present (procname)) then prc_name = procname(2) else prc_name = "prc_config_b" end if n_components = 1 allocate (prt_in (2), prt_out (2)) prt_in = [var_str ("e+"), var_str ("e-")] prt_out = [var_str ("m+"), var_str ("m-")] call global%set_string (var_str ("$method"),& var_str ("omega"), is_known = .true.) call prc_config%init (prc_name, & size (prt_in), n_components, & global%model, global%var_list) call prc_config%setup_component (1, & new_prt_spec (prt_in), new_prt_spec (prt_out), & global%model, global%var_list) call prc_config%record (global) deallocate (prt_in, prt_out) end if if (btest (mode, 2)) then call global%select_model (var_str ("Test")) if (present (procname)) then prc_name = procname(1) else prc_name = "prc_config_a" end if n_components = 1 allocate (prt_in (1), prt_out (2)) prt_in = [var_str ("s")] prt_out = [var_str ("f"), var_str ("fbar")] call global%set_string (var_str ("$method"),& var_str ("unit_test"), is_known = .true.) call prc_config%init (prc_name, & size (prt_in), n_components, & global%model, global%var_list) call prc_config%setup_component (1, & new_prt_spec (prt_in), new_prt_spec (prt_out), & global%model, global%var_list) call prc_config%record (global) deallocate (prt_in, prt_out) end if end subroutine prepare_test_library @ %def prepare_test_library @ The actual test: the previous procedure with some prelude and postlude. In the global variable list, just before printing we reset the variables where the value may depend on the system and run environment. <>= call test (process_configurations_1, "process_configurations_1", & "test processes", & u, results) <>= public :: process_configurations_1 <>= subroutine process_configurations_1 (u) integer, intent(in) :: u type(rt_data_t), target :: global write (u, "(A)") "* Test output: process_configurations_1" write (u, "(A)") "* Purpose: configure test processes" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) write (u, "(A)") "* Configure processes as prc_test, model Test" write (u, "(A)") "* and omega, model QED" write (u, *) call global%set_int (var_str ("process_num_id"), & 42, is_known = .true.) call prepare_test_library (global, var_str ("prc_config_lib_1"), 3) global%os_data%fc = "Fortran-compiler" global%os_data%fcflags = "Fortran-flags" global%os_data%fclibs = "Fortran-libs" call global%write_libraries (u) call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: process_configurations_1" end subroutine process_configurations_1 @ %def process_configurations_1 @ \subsubsection{\oMega\ options} Slightly extended example where we pass \oMega\ options to the library. The [[prepare_test_library]] contents are spelled out. <>= call test (process_configurations_2, "process_configurations_2", & "omega options", & u, results) <>= public :: process_configurations_2 <>= subroutine process_configurations_2 (u) integer, intent(in) :: u type(rt_data_t), target :: global type(string_t) :: libname type(prclib_entry_t), pointer :: lib type(string_t) :: prc_name type(string_t), dimension(:), allocatable :: prt_in, prt_out integer :: n_components type(process_configuration_t) :: prc_config write (u, "(A)") "* Test output: process_configurations_2" write (u, "(A)") "* Purpose: configure test processes with options" write (u, "(A)") call syntax_model_file_init () call global%global_init () write (u, "(A)") "* Configure processes as omega, model QED" write (u, *) libname = "prc_config_lib_2" allocate (lib) call lib%init (libname) call global%add_prclib (lib) call global%select_model (var_str ("QED")) prc_name = "prc_config_c" n_components = 2 allocate (prt_in (2), prt_out (2)) prt_in = [var_str ("e+"), var_str ("e-")] prt_out = [var_str ("m+"), var_str ("m-")] call global%set_string (var_str ("$method"),& var_str ("omega"), is_known = .true.) call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call prc_config%init (prc_name, size (prt_in), n_components, & global%model, global%var_list) call global%set_log (var_str ("?report_progress"), & .true., is_known = .true.) call prc_config%setup_component (1, & new_prt_spec (prt_in), new_prt_spec (prt_out), global%model, global%var_list) call global%set_log (var_str ("?report_progress"), & .false., is_known = .true.) call global%set_log (var_str ("?omega_openmp"), & .true., is_known = .true.) call global%set_string (var_str ("$restrictions"),& var_str ("3+4~A"), is_known = .true.) call global%set_string (var_str ("$omega_flags"), & var_str ("-fusion:progress_file omega_prc_config.log"), & is_known = .true.) call prc_config%setup_component (2, & new_prt_spec (prt_in), new_prt_spec (prt_out), global%model, global%var_list) call prc_config%record (global) deallocate (prt_in, prt_out) global%os_data%fc = "Fortran-compiler" global%os_data%fcflags = "Fortran-flags" global%os_data%fclibs = "Fortran-libs" call global%write_vars (u, [ & var_str ("$model_name"), & var_str ("$method"), & var_str ("?report_progress"), & var_str ("$restrictions"), & var_str ("$omega_flags")]) write (u, "(A)") call global%write_libraries (u) call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: process_configurations_2" end subroutine process_configurations_2 @ %def process_configurations_2 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Compilation} This module manages compilation and loading of of process libraries. It is needed as a separate module because integration depends on it. <<[[compilations.f90]]>>= <> module compilations <> use io_units use system_defs, only: TAB use system_dependencies, only: OS_IS_DARWIN use diagnostics use os_interface use variables, only: var_list_t use model_data use process_libraries use prclib_stacks use rt_data <> <> <> <> contains <> end module compilations @ %def compilations @ \subsection{The data type} The compilation item handles the compilation and loading of a single process library. <>= public :: compilation_item_t <>= type :: compilation_item_t private type(string_t) :: libname type(string_t) :: static_external_tag type(process_library_t), pointer :: lib => null () logical :: recompile_library = .false. logical :: verbose = .false. logical :: use_workspace = .false. type(string_t) :: workspace contains <> end type compilation_item_t @ %def compilation_item_t @ Initialize. Set flags and global properties of the library. Establish the workspace name, if defined. <>= procedure :: init => compilation_item_init <>= subroutine compilation_item_init (comp, libname, stack, var_list) class(compilation_item_t), intent(out) :: comp type(string_t), intent(in) :: libname type(prclib_stack_t), intent(inout) :: stack type(var_list_t), intent(in) :: var_list comp%libname = libname comp%lib => stack%get_library_ptr (comp%libname) if (.not. associated (comp%lib)) then call msg_fatal ("Process library '" // char (comp%libname) & // "' has not been declared.") end if comp%recompile_library = & var_list%get_lval (var_str ("?recompile_library")) comp%verbose = & var_list%get_lval (var_str ("?me_verbose")) comp%use_workspace = & var_list%is_known (var_str ("$compile_workspace")) if (comp%use_workspace) then comp%workspace = & var_list%get_sval (var_str ("$compile_workspace")) if (comp%workspace == "") comp%use_workspace = .false. else comp%workspace = "" end if end subroutine compilation_item_init @ %def compilation_item_init @ Compile the current library. The [[force]] flag has the effect that we first delete any previous files, as far as accessible by the current makefile. It also guarantees that previous files not accessible by a makefile will be overwritten. <>= procedure :: compile => compilation_item_compile <>= subroutine compilation_item_compile (comp, model, os_data, force, recompile) class(compilation_item_t), intent(inout) :: comp class(model_data_t), intent(in), target :: model type(os_data_t), intent(in) :: os_data logical, intent(in) :: force, recompile if (associated (comp%lib)) then if (comp%use_workspace) call setup_workspace (comp%workspace, os_data) call msg_message ("Process library '" & // char (comp%libname) // "': compiling ...") call comp%lib%configure (os_data) if (signal_is_pending ()) return call comp%lib%compute_md5sum (model) call comp%lib%write_makefile & (os_data, force, verbose=comp%verbose, workspace=comp%workspace) if (signal_is_pending ()) return if (force) then call comp%lib%clean & (os_data, distclean = .false., workspace=comp%workspace) if (signal_is_pending ()) return end if call comp%lib%write_driver (force, workspace=comp%workspace) if (signal_is_pending ()) return if (recompile) then call comp%lib%load & (os_data, keep_old_source = .true., workspace=comp%workspace) if (signal_is_pending ()) return end if call comp%lib%update_status (os_data, workspace=comp%workspace) end if end subroutine compilation_item_compile @ %def compilation_item_compile @ The workspace directory is created if it does not exist. (Applies only if the use has set the workspace directory.) <>= character(*), parameter :: ALLOWED_IN_DIRNAME = & "abcdefghijklmnopqrstuvwxyz& &ABCDEFGHIJKLMNOPQRSTUVWXYZ& &1234567890& &.,_-+=" @ %def ALLOWED_IN_DIRNAME <>= subroutine setup_workspace (workspace, os_data) type(string_t), intent(in) :: workspace type(os_data_t), intent(in) :: os_data if (verify (workspace, ALLOWED_IN_DIRNAME) == 0) then call msg_message ("Compile: preparing workspace directory '" & // char (workspace) // "'") call os_system_call ("mkdir -p '" // workspace // "'") else call msg_fatal ("compile: workspace name '" & // char (workspace) // "' contains illegal characters") end if end subroutine setup_workspace @ %def setup_workspace @ Load the current library, just after compiling it. <>= procedure :: load => compilation_item_load <>= subroutine compilation_item_load (comp, os_data) class(compilation_item_t), intent(inout) :: comp type(os_data_t), intent(in) :: os_data if (associated (comp%lib)) then call comp%lib%load (os_data, workspace=comp%workspace) end if end subroutine compilation_item_load @ %def compilation_item_load @ Message as a separate call: <>= procedure :: success => compilation_item_success <>= subroutine compilation_item_success (comp) class(compilation_item_t), intent(in) :: comp if (associated (comp%lib)) then call msg_message ("Process library '" // char (comp%libname) & // "': ... success.") else call msg_fatal ("Process library '" // char (comp%libname) & // "': ... failure.") end if end subroutine compilation_item_success @ %def compilation_item_success @ %def compilation_item_failure @ \subsection{API for library compilation and loading} This is a shorthand for compiling and loading a single library. The [[compilation_item]] object is used only internally. The [[global]] data set may actually be local to the caller. The compilation affects the library specified by its name if it is on the stack, but it does not reset the currently selected library. <>= public :: compile_library <>= subroutine compile_library (libname, global) type(string_t), intent(in) :: libname type(rt_data_t), intent(inout), target :: global type(compilation_item_t) :: comp logical :: force, recompile force = & global%var_list%get_lval (var_str ("?rebuild_library")) recompile = & global%var_list%get_lval (var_str ("?recompile_library")) if (associated (global%model)) then call comp%init (libname, global%prclib_stack, global%var_list) call comp%compile (global%model, global%os_data, force, recompile) if (signal_is_pending ()) return call comp%load (global%os_data) if (signal_is_pending ()) return else call msg_fatal ("Process library compilation: " & // " model is undefined.") end if call comp%success () end subroutine compile_library @ %def compile_library @ \subsection{Compiling static executable} This object handles the creation of a static executable which should contain a set of static process libraries. <>= public :: compilation_t <>= type :: compilation_t private type(string_t) :: exe_name type(string_t), dimension(:), allocatable :: lib_name contains <> end type compilation_t @ %def compilation_t @ Output. <>= procedure :: write => compilation_write <>= subroutine compilation_write (object, unit) class(compilation_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) write (u, "(1x,A)") "Compilation object:" write (u, "(3x,3A)") "executable = '", & char (object%exe_name), "'" write (u, "(3x,A)", advance="no") "process libraries =" do i = 1, size (object%lib_name) write (u, "(1x,3A)", advance="no") "'", char (object%lib_name(i)), "'" end do write (u, *) end subroutine compilation_write @ %def compilation_write @ Initialize: we know the names of the executable and of the libraries. Optionally, we may provide a workspace directory. <>= procedure :: init => compilation_init <>= subroutine compilation_init (compilation, exe_name, lib_name) class(compilation_t), intent(out) :: compilation type(string_t), intent(in) :: exe_name type(string_t), dimension(:), intent(in) :: lib_name compilation%exe_name = exe_name allocate (compilation%lib_name (size (lib_name))) compilation%lib_name = lib_name end subroutine compilation_init @ %def compilation_init @ Write the dispatcher subroutine for the compiled libraries. Also write a subroutine which returns the names of the compiled libraries. <>= procedure :: write_dispatcher => compilation_write_dispatcher <>= subroutine compilation_write_dispatcher (compilation) class(compilation_t), intent(in) :: compilation type(string_t) :: file integer :: u, i file = compilation%exe_name // "_prclib_dispatcher.f90" call msg_message ("Static executable '" // char (compilation%exe_name) & // "': writing library dispatcher") u = free_unit () open (u, file = char (file), status="replace", action="write") write (u, "(3A)") "! Whizard: process libraries for executable '", & char (compilation%exe_name), "'" write (u, "(A)") "! Automatically generated file, do not edit" write (u, "(A)") "subroutine dispatch_prclib_static " // & "(driver, basename, modellibs_ldflags)" write (u, "(A)") " use iso_varying_string, string_t => varying_string" write (u, "(A)") " use prclib_interfaces" do i = 1, size (compilation%lib_name) associate (lib_name => compilation%lib_name(i)) write (u, "(A)") " use " // char (lib_name) // "_driver" end associate end do write (u, "(A)") " implicit none" write (u, "(A)") " class(prclib_driver_t), intent(inout), allocatable & &:: driver" write (u, "(A)") " type(string_t), intent(in) :: basename" write (u, "(A)") " logical, intent(in), optional :: " // & "modellibs_ldflags" write (u, "(A)") " select case (char (basename))" do i = 1, size (compilation%lib_name) associate (lib_name => compilation%lib_name(i)) write (u, "(3A)") " case ('", char (lib_name), "')" write (u, "(3A)") " allocate (", char (lib_name), "_driver_t & &:: driver)" end associate end do write (u, "(A)") " end select" write (u, "(A)") "end subroutine dispatch_prclib_static" write (u, *) write (u, "(A)") "subroutine get_prclib_static (libname)" write (u, "(A)") " use iso_varying_string, string_t => varying_string" write (u, "(A)") " implicit none" write (u, "(A)") " type(string_t), dimension(:), intent(inout), & &allocatable :: libname" write (u, "(A,I0,A)") " allocate (libname (", & size (compilation%lib_name), "))" do i = 1, size (compilation%lib_name) associate (lib_name => compilation%lib_name(i)) write (u, "(A,I0,A,A,A)") " libname(", i, ") = '", & char (lib_name), "'" end associate end do write (u, "(A)") "end subroutine get_prclib_static" close (u) end subroutine compilation_write_dispatcher @ %def compilation_write_dispatcher @ Write the Makefile subroutine for the compiled libraries. <>= procedure :: write_makefile => compilation_write_makefile <>= subroutine compilation_write_makefile & (compilation, os_data, ext_libtag, verbose, overwrite_os) class(compilation_t), intent(in) :: compilation type(os_data_t), intent(in) :: os_data logical, intent(in) :: verbose logical, intent(in), optional :: overwrite_os logical :: overwrite type(string_t), intent(in), optional :: ext_libtag type(string_t) :: file, ext_tag integer :: u, i overwrite = .false. if (present (overwrite_os)) overwrite = overwrite_os if (present (ext_libtag)) then ext_tag = ext_libtag else ext_tag = "" end if file = compilation%exe_name // ".makefile" call msg_message ("Static executable '" // char (compilation%exe_name) & // "': writing makefile") u = free_unit () open (u, file = char (file), status="replace", action="write") write (u, "(3A)") "# WHIZARD: Makefile for executable '", & char (compilation%exe_name), "'" write (u, "(A)") "# Automatically generated file, do not edit" write (u, "(A)") "" write (u, "(A)") "# Executable name" write (u, "(A)") "EXE = " // char (compilation%exe_name) write (u, "(A)") "" write (u, "(A)") "# Compiler" write (u, "(A)") "FC = " // char (os_data%fc) write (u, "(A)") "CXX = " // char (os_data%cxx) write (u, "(A)") "" write (u, "(A)") "# Included libraries" write (u, "(A)") "FCINCL = " // char (os_data%whizard_includes) write (u, "(A)") "" write (u, "(A)") "# Compiler flags" write (u, "(A)") "FCFLAGS = " // char (os_data%fcflags) write (u, "(A)") "FCLIBS = " // char (os_data%fclibs) write (u, "(A)") "CXXFLAGS = " // char (os_data%cxxflags) write (u, "(A)") "CXXLIBSS = " // char (os_data%cxxlibs) write (u, "(A)") "LDFLAGS = " // char (os_data%ldflags) write (u, "(A)") "LDFLAGS_STATIC = " // char (os_data%ldflags_static) write (u, "(A)") "LDFLAGS_HEPMC = " // char (os_data%ldflags_hepmc) write (u, "(A)") "LDFLAGS_LCIO = " // char (os_data%ldflags_lcio) write (u, "(A)") "LDFLAGS_HOPPET = " // char (os_data%ldflags_hoppet) write (u, "(A)") "LDFLAGS_LOOPTOOLS = " // char (os_data%ldflags_looptools) write (u, "(A)") "LDWHIZARD = " // char (os_data%whizard_ldflags) write (u, "(A)") "" write (u, "(A)") "# Libtool" write (u, "(A)") "LIBTOOL = " // char (os_data%whizard_libtool) if (verbose) then write (u, "(A)") "FCOMPILE = $(LIBTOOL) --tag=FC --mode=compile" if (OS_IS_DARWIN .and. .not. overwrite) then write (u, "(A)") "LINK = $(LIBTOOL) --tag=CXX --mode=link" else write (u, "(A)") "LINK = $(LIBTOOL) --tag=FC --mode=link" end if else write (u, "(A)") "FCOMPILE = @$(LIBTOOL) --silent --tag=FC --mode=compile" if (OS_IS_DARWIN .and. .not. overwrite) then write (u, "(A)") "LINK = @$(LIBTOOL) --silent --tag=CXX --mode=link" else write (u, "(A)") "LINK = @$(LIBTOOL) --silent --tag=FC --mode=link" end if end if write (u, "(A)") "" write (u, "(A)") "# Compile commands (default)" write (u, "(A)") "LTFCOMPILE = $(FCOMPILE) $(FC) -c $(FCINCL) $(FCFLAGS)" write (u, "(A)") "" write (u, "(A)") "# Default target" write (u, "(A)") "all: link" write (u, "(A)") "" write (u, "(A)") "# Libraries" do i = 1, size (compilation%lib_name) associate (lib_name => compilation%lib_name(i)) write (u, "(A)") "LIBRARIES += " // char (lib_name) // ".la" write (u, "(A)") char (lib_name) // ".la:" write (u, "(A)") TAB // "$(MAKE) -f " // char (lib_name) // ".makefile" end associate end do write (u, "(A)") "" write (u, "(A)") "# Library dispatcher" write (u, "(A)") "DISP = $(EXE)_prclib_dispatcher" write (u, "(A)") "$(DISP).lo: $(DISP).f90 $(LIBRARIES)" if (.not. verbose) then write (u, "(A)") TAB // '@echo " FC " $@' end if write (u, "(A)") TAB // "$(LTFCOMPILE) $<" write (u, "(A)") "" write (u, "(A)") "# Executable" write (u, "(A)") "$(EXE): $(DISP).lo $(LIBRARIES)" if (.not. verbose) then if (OS_IS_DARWIN .and. .not. overwrite) then write (u, "(A)") TAB // '@echo " CXXLD " $@' else write (u, "(A)") TAB // '@echo " FCLD " $@' end if end if if (OS_IS_DARWIN .and. .not. overwrite) then write (u, "(A)") TAB // "$(LINK) $(CXX) -static $(CXXFLAGS) \" else write (u, "(A)") TAB // "$(LINK) $(FC) -static $(FCFLAGS) \" end if write (u, "(A)") TAB // " $(LDWHIZARD) $(LDFLAGS) \" write (u, "(A)") TAB // " -o $(EXE) $^ \" write (u, "(A)") TAB // " $(LDFLAGS_HEPMC) $(LDFLAGS_LCIO) $(LDFLAGS_HOPPET) \" if (OS_IS_DARWIN .and. .not. overwrite) then write (u, "(A)") TAB // " $(LDFLAGS_LOOPTOOLS) $(LDFLAGS_STATIC) \" write (u, "(A)") TAB // " $(CXXLIBS) $(FCLIBS)" // char (ext_tag) else write (u, "(A)") TAB // " $(LDFLAGS_LOOPTOOLS) $(LDFLAGS_STATIC)" // char (ext_tag) end if write (u, "(A)") "" write (u, "(A)") "# Main targets" write (u, "(A)") "link: compile $(EXE)" write (u, "(A)") "compile: $(LIBRARIES) $(DISP).lo" write (u, "(A)") ".PHONY: link compile" write (u, "(A)") "" write (u, "(A)") "# Cleanup targets" write (u, "(A)") "clean-exe:" write (u, "(A)") TAB // "rm -f $(EXE)" write (u, "(A)") "clean-objects:" write (u, "(A)") TAB // "rm -f $(DISP).lo" write (u, "(A)") "clean-source:" write (u, "(A)") TAB // "rm -f $(DISP).f90" write (u, "(A)") "clean-makefile:" write (u, "(A)") TAB // "rm -f $(EXE).makefile" write (u, "(A)") "" write (u, "(A)") "clean: clean-exe clean-objects clean-source" write (u, "(A)") "distclean: clean clean-makefile" write (u, "(A)") ".PHONY: clean distclean" close (u) end subroutine compilation_write_makefile @ %def compilation_write_makefile @ Compile the dispatcher source code. <>= procedure :: make_compile => compilation_make_compile <>= subroutine compilation_make_compile (compilation, os_data) class(compilation_t), intent(in) :: compilation type(os_data_t), intent(in) :: os_data call os_system_call ("make compile " // os_data%makeflags & // " -f " // compilation%exe_name // ".makefile") end subroutine compilation_make_compile @ %def compilation_make_compile @ Link the dispatcher together with all matrix-element code and the \whizard\ and \oMega\ main libraries, to generate a static executable. <>= procedure :: make_link => compilation_make_link <>= subroutine compilation_make_link (compilation, os_data) class(compilation_t), intent(in) :: compilation type(os_data_t), intent(in) :: os_data call os_system_call ("make link " // os_data%makeflags & // " -f " // compilation%exe_name // ".makefile") end subroutine compilation_make_link @ %def compilation_make_link @ Cleanup. <>= procedure :: make_clean_exe => compilation_make_clean_exe <>= subroutine compilation_make_clean_exe (compilation, os_data) class(compilation_t), intent(in) :: compilation type(os_data_t), intent(in) :: os_data call os_system_call ("make clean-exe " // os_data%makeflags & // " -f " // compilation%exe_name // ".makefile") end subroutine compilation_make_clean_exe @ %def compilation_make_clean_exe @ \subsection{API for executable compilation} This is a shorthand for compiling and loading an executable, including the enclosed libraries. The [[compilation]] object is used only internally. The [[global]] data set may actually be local to the caller. The compilation affects the library specified by its name if it is on the stack, but it does not reset the currently selected library. <>= public :: compile_executable <>= subroutine compile_executable (exename, libname, global) type(string_t), intent(in) :: exename type(string_t), dimension(:), intent(in) :: libname type(rt_data_t), intent(inout), target :: global type(compilation_t) :: compilation type(compilation_item_t) :: item type(string_t) :: ext_libtag logical :: force, recompile, verbose integer :: i ext_libtag = "" force = & global%var_list%get_lval (var_str ("?rebuild_library")) recompile = & global%var_list%get_lval (var_str ("?recompile_library")) verbose = & global%var_list%get_lval (var_str ("?me_verbose")) call compilation%init (exename, [libname]) if (signal_is_pending ()) return call compilation%write_dispatcher () if (signal_is_pending ()) return do i = 1, size (libname) call item%init (libname(i), global%prclib_stack, global%var_list) call item%compile (global%model, global%os_data, & force=force, recompile=recompile) ext_libtag = "" // item%lib%get_static_modelname (global%os_data) if (signal_is_pending ()) return call item%success () end do call compilation%write_makefile & (global%os_data, ext_libtag=ext_libtag, verbose=verbose) if (signal_is_pending ()) return call compilation%make_compile (global%os_data) if (signal_is_pending ()) return call compilation%make_link (global%os_data) end subroutine compile_executable @ %def compile_executable @ \subsection{Unit Tests} Test module, followed by the stand-alone unit-test procedures. <<[[compilations_ut.f90]]>>= <> module compilations_ut use unit_tests use compilations_uti <> <> contains <> end module compilations_ut @ %def compilations_ut @ <<[[compilations_uti.f90]]>>= <> module compilations_uti <> use io_units use models use rt_data use process_configurations_ut, only: prepare_test_library use compilations <> <> contains <> end module compilations_uti @ %def compilations_uti @ API: driver for the unit tests below. <>= public :: compilations_test <>= subroutine compilations_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine compilations_test @ %def compilations_test @ \subsubsection{Intrinsic Matrix Element} Compile an intrinsic test matrix element ([[prc_test]] type). Note: In this and the following test, we reset the Fortran compiler and flag variables immediately before they are printed, so the test is portable. <>= call test (compilations_1, "compilations_1", & "intrinsic test processes", & u, results) <>= public :: compilations_1 <>= subroutine compilations_1 (u) integer, intent(in) :: u type(string_t) :: libname, procname type(rt_data_t), target :: global write (u, "(A)") "* Test output: compilations_1" write (u, "(A)") "* Purpose: configure and compile test process" write (u, "(A)") call syntax_model_file_init () call global%global_init () libname = "compilation_1" procname = "prc_comp_1" call prepare_test_library (global, libname, 1, [procname]) call compile_library (libname, global) call global%write_libraries (u) call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: compilations_1" end subroutine compilations_1 @ %def compilations_1 @ \subsubsection{External Matrix Element} Compile an external test matrix element ([[omega]] type) <>= call test (compilations_2, "compilations_2", & "external process (omega)", & u, results) <>= public :: compilations_2 <>= subroutine compilations_2 (u) integer, intent(in) :: u type(string_t) :: libname, procname type(rt_data_t), target :: global write (u, "(A)") "* Test output: compilations_2" write (u, "(A)") "* Purpose: configure and compile test process" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) libname = "compilation_2" procname = "prc_comp_2" call prepare_test_library (global, libname, 2, [procname,procname]) call compile_library (libname, global) call global%write_libraries (u, libpath = .false.) call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: compilations_2" end subroutine compilations_2 @ %def compilations_2 @ \subsubsection{External Matrix Element} Compile an external test matrix element ([[omega]] type) and create driver files for a static executable. <>= call test (compilations_3, "compilations_3", & "static executable: driver", & u, results) <>= public :: compilations_3 <>= subroutine compilations_3 (u) integer, intent(in) :: u type(string_t) :: libname, procname, exename type(rt_data_t), target :: global type(compilation_t) :: compilation integer :: u_file character(80) :: buffer write (u, "(A)") "* Test output: compilations_3" write (u, "(A)") "* Purpose: make static executable" write (u, "(A)") write (u, "(A)") "* Initialize library" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) libname = "compilations_3_lib" procname = "prc_comp_3" exename = "compilations_3" call prepare_test_library (global, libname, 2, [procname,procname]) call compilation%init (exename, [libname]) call compilation%write (u) write (u, "(A)") write (u, "(A)") "* Write dispatcher" write (u, "(A)") call compilation%write_dispatcher () u_file = free_unit () open (u_file, file = char (exename) // "_prclib_dispatcher.f90", & status = "old", action = "read") do read (u_file, "(A)", end = 1) buffer write (u, "(A)") trim (buffer) end do 1 close (u_file) write (u, "(A)") write (u, "(A)") "* Write Makefile" write (u, "(A)") associate (os_data => global%os_data) os_data%fc = "fortran-compiler" os_data%cxx = "c++-compiler" os_data%whizard_includes = "my-includes" os_data%fcflags = "my-fcflags" os_data%fclibs = "my-fclibs" os_data%cxxflags = "my-cxxflags" os_data%cxxlibs = "my-cxxlibs" os_data%ldflags = "my-ldflags" os_data%ldflags_static = "my-ldflags-static" os_data%ldflags_hepmc = "my-ldflags-hepmc" os_data%ldflags_lcio = "my-ldflags-lcio" os_data%ldflags_hoppet = "my-ldflags-hoppet" os_data%ldflags_looptools = "my-ldflags-looptools" os_data%whizard_ldflags = "my-ldwhizard" os_data%whizard_libtool = "my-libtool" end associate call compilation%write_makefile & (global%os_data, verbose = .true., overwrite_os = .true.) open (u_file, file = char (exename) // ".makefile", & status = "old", action = "read") do read (u_file, "(A)", end = 2) buffer write (u, "(A)") trim (buffer) end do 2 close (u_file) write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: compilations_3" end subroutine compilations_3 @ %def compilations_3 @ \subsection{Test static build} The tests for building a static executable are separate, since they should be skipped if the \whizard\ build itself has static libraries disabled. <>= public :: compilations_static_test <>= subroutine compilations_static_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine compilations_static_test @ %def compilations_static_test @ \subsubsection{External Matrix Element} Compile an external test matrix element ([[omega]] type) and incorporate this in a new static WHIZARD executable. <>= call test (compilations_static_1, "compilations_static_1", & "static executable: compilation", & u, results) <>= public :: compilations_static_1 <>= subroutine compilations_static_1 (u) integer, intent(in) :: u type(string_t) :: libname, procname, exename type(rt_data_t), target :: global type(compilation_item_t) :: item type(compilation_t) :: compilation logical :: exist write (u, "(A)") "* Test output: compilations_static_1" write (u, "(A)") "* Purpose: make static executable" write (u, "(A)") write (u, "(A)") "* Initialize library" call syntax_model_file_init () call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) libname = "compilations_static_1_lib" procname = "prc_comp_stat_1" exename = "compilations_static_1" call prepare_test_library (global, libname, 2, [procname,procname]) call compilation%init (exename, [libname]) write (u, "(A)") write (u, "(A)") "* Write dispatcher" call compilation%write_dispatcher () write (u, "(A)") write (u, "(A)") "* Write Makefile" call compilation%write_makefile (global%os_data, verbose = .true.) write (u, "(A)") write (u, "(A)") "* Build libraries" call item%init (libname, global%prclib_stack, global%var_list) call item%compile & (global%model, global%os_data, force=.true., recompile=.false.) call item%success () write (u, "(A)") write (u, "(A)") "* Check executable (should be absent)" write (u, "(A)") call compilation%make_clean_exe (global%os_data) inquire (file = char (exename), exist = exist) write (u, "(A,A,L1)") char (exename), " exists = ", exist write (u, "(A)") write (u, "(A)") "* Build executable" write (u, "(A)") call compilation%make_compile (global%os_data) call compilation%make_link (global%os_data) write (u, "(A)") "* Check executable (should be present)" write (u, "(A)") inquire (file = char (exename), exist = exist) write (u, "(A,A,L1)") char (exename), " exists = ", exist write (u, "(A)") write (u, "(A)") "* Cleanup" call compilation%make_clean_exe (global%os_data) call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: compilations_static_1" end subroutine compilations_static_1 @ %def compilations_static_1 @ \subsubsection{External Matrix Element} Compile an external test matrix element ([[omega]] type) and incorporate this in a new static WHIZARD executable. In this version, we use the wrapper [[compile_executable]] procedure. <>= call test (compilations_static_2, "compilations_static_2", & "static executable: shortcut", & u, results) <>= public :: compilations_static_2 <>= subroutine compilations_static_2 (u) integer, intent(in) :: u type(string_t) :: libname, procname, exename type(rt_data_t), target :: global logical :: exist integer :: u_file write (u, "(A)") "* Test output: compilations_static_2" write (u, "(A)") "* Purpose: make static executable" write (u, "(A)") write (u, "(A)") "* Initialize library and compile" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) libname = "compilations_static_2_lib" procname = "prc_comp_stat_2" exename = "compilations_static_2" call prepare_test_library (global, libname, 2, [procname,procname]) call compile_executable (exename, [libname], global) write (u, "(A)") "* Check executable (should be present)" write (u, "(A)") inquire (file = char (exename), exist = exist) write (u, "(A,A,L1)") char (exename), " exists = ", exist write (u, "(A)") write (u, "(A)") "* Cleanup" u_file = free_unit () open (u_file, file = char (exename), status = "old", action = "write") close (u_file, status = "delete") call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: compilations_static_2" end subroutine compilations_static_2 @ %def compilations_static_2 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Integration} This module manages phase space setup, matrix-element evaluation and integration, as far as it is not done by lower-level routines, in particular in the [[processes]] module. <<[[integrations.f90]]>>= <> module integrations <> <> <> use io_units use diagnostics use os_interface use cputime use sm_qcd use physics_defs use model_data use pdg_arrays use variables, only: var_list_t use eval_trees use sf_mappings use sf_base use phs_base use rng_base use mci_base use process_libraries use prc_core use process_config, only: COMP_MASTER, COMP_REAL_FIN, & COMP_MISMATCH, COMP_PDF, COMP_REAL, COMP_SUB, COMP_VIRT, & COMP_REAL_SING use process use pcm_base, only: pcm_t use instances use process_stacks use models use iterations use rt_data use dispatch_me_methods, only: dispatch_core use dispatch_beams, only: dispatch_qcd, sf_prop_t, dispatch_sf_config use dispatch_phase_space, only: dispatch_sf_channels use dispatch_phase_space, only: dispatch_phs use dispatch_mci, only: dispatch_mci_s, setup_grid_path use dispatch_transforms, only: dispatch_evt_shower_hook use compilations, only: compile_library use dispatch_fks, only: dispatch_fks_s use nlo_data <> <> <> <> contains <> end module integrations @ %def integrations @ \subsection{The integration type} This type holds all relevant data, the integration methods operates on this. In contrast to the [[simulation_t]] introduced later, the [[integration_t]] applies to a single process. <>= public :: integration_t <>= type :: integration_t private type(string_t) :: process_id type(string_t) :: run_id type(process_t), pointer :: process => null () logical :: rebuild_phs = .false. logical :: ignore_phs_mismatch = .false. logical :: phs_only = .false. logical :: process_has_me = .true. integer :: n_calls_test = 0 logical :: vis_history = .true. type(string_t) :: history_filename type(string_t) :: log_filename type(helicity_selection_t) :: helicity_selection logical :: use_color_factors = .false. logical :: has_beam_pol = .false. logical :: combined_integration = .false. type(iteration_multipliers_t) :: iteration_multipliers type(nlo_settings_t) :: nlo_settings contains <> end type integration_t @ %def integration_t @ @ \subsection{Initialization} Initialization, first part: Create a process entry. Push it on the stack if the [[global]] environment is supplied. <>= procedure :: create_process => integration_create_process <>= subroutine integration_create_process (intg, process_id, global) class(integration_t), intent(out) :: intg type(rt_data_t), intent(inout), optional, target :: global type(string_t), intent(in) :: process_id type(process_entry_t), pointer :: process_entry if (debug_on) call msg_debug (D_CORE, "integration_create_process") intg%process_id = process_id if (present (global)) then allocate (process_entry) intg%process => process_entry%process_t call global%process_stack%push (process_entry) else allocate (process_t :: intg%process) end if end subroutine integration_create_process @ %def integration_create_process @ Initialization, second part: Initialize the process object, using the local environment. We allocate a RNG factory and a QCD object. We also fetch a pointer to the model that the process uses. The process initializer will create a snapshot of that model. This procedure does not modify the [[local]] stack directly. The intent(inout) attribute for the [[local]] data set is due to the random generator seed which may be incremented during initialization. NOTE: Changes to model parameters within the current context are respected only if the process model coincides with the current model. This is the usual case. If not, we read the model from the global model library, which has default parameters. To become more flexible, we should implement a local model library which records local changes to currently inactive models. <>= procedure :: init_process => integration_init_process <>= subroutine integration_init_process (intg, local) class(integration_t), intent(inout) :: intg type(rt_data_t), intent(inout), target :: local type(string_t) :: model_name type(model_t), pointer :: model class(model_data_t), pointer :: model_instance type(var_list_t), pointer :: var_list if (debug_on) call msg_debug (D_CORE, "integration_init_process") if (.not. local%prclib%contains (intg%process_id)) then call msg_fatal ("Process '" // char (intg%process_id) // "' not found" & // " in library '" // char (local%prclib%get_name ()) // "'") return end if model_name = local%prclib%get_model_name (intg%process_id) if (local%get_sval (var_str ("$model_name")) == model_name) then model => local%model else model => local%model_list%get_model_ptr (model_name) end if var_list => local%get_var_list_ptr () call intg%process%init (intg%process_id, & local%prclib, & local%os_data, & model, & var_list, & local%beam_structure) intg%run_id = intg%process%get_run_id () end subroutine integration_init_process @ %def integration_init_process @ Initialization, third part: complete process configuration. <>= procedure :: setup_process => integration_setup_process <>= subroutine integration_setup_process (intg, local, verbose, init_only) class(integration_t), intent(inout) :: intg type(rt_data_t), intent(inout), target :: local logical, intent(in), optional :: verbose logical, intent(in), optional :: init_only type(var_list_t), pointer :: var_list class(mci_t), allocatable :: mci_template type(sf_config_t), dimension(:), allocatable :: sf_config type(sf_prop_t) :: sf_prop type(sf_channel_t), dimension(:), allocatable :: sf_channel type(phs_channel_collection_t) :: phs_channel_collection logical :: sf_trace logical :: verb, initialize_only type(string_t) :: sf_string type(string_t) :: workspace real(default) :: sqrts verb = .true.; if (present (verbose)) verb = verbose initialize_only = .false. if (present (init_only)) initialize_only = init_only call display_init_message (verb) var_list => local%get_var_list_ptr () call setup_log_and_history () associate (process => intg%process) call set_intg_parameters (process) call process%setup_cores (dispatch_core, & intg%helicity_selection, intg%use_color_factors, intg%has_beam_pol) call process%init_phs_config () call process%init_components () call process%record_inactive_components () intg%process_has_me = process%has_matrix_element () if (.not. intg%process_has_me) then call msg_warning ("Process '" & // char (intg%process_id) // "': matrix element vanishes") end if call setup_beams () call setup_structure_functions () workspace = var_list%get_sval (var_str ("$integrate_workspace")) if (workspace == "") then call process%configure_phs & (intg%rebuild_phs, & intg%ignore_phs_mismatch, & intg%combined_integration) else call setup_grid_path (workspace) call process%configure_phs & (intg%rebuild_phs, & intg%ignore_phs_mismatch, & intg%combined_integration, & workspace) end if call process%complete_pcm_setup () call process%prepare_blha_cores () call process%create_blha_interface () call process%prepare_any_external_code () call process%setup_terms (with_beams = intg%has_beam_pol) call process%check_masses () call process%optimize_nlo_singular_regions () if (verb) then call process%write (screen = .true.) call process%print_phs_startup_message () end if if (intg%process_has_me) then if (size (sf_config) > 0) then call process%collect_channels (phs_channel_collection) else if (.not. initialize_only & .and. process%contains_trivial_component ()) then call msg_fatal ("Integrate: 2 -> 1 process can't be handled & &with fixed-energy beams") end if if (local%beam_structure%asymmetric ()) then sqrts = process%get_sqrts () else sqrts = local%get_sqrts () end if call dispatch_sf_channels & (sf_channel, sf_string, sf_prop, phs_channel_collection, & local%var_list, sqrts, local%beam_structure) if (allocated (sf_channel)) then if (size (sf_channel) > 0) then call process%set_sf_channel (sf_channel) end if end if call phs_channel_collection%final () if (verb) call process%sf_startup_message (sf_string) end if call process%setup_mci (dispatch_mci_s) call setup_expressions () call process%compute_md5sum () end associate contains subroutine setup_log_and_history () if (intg%run_id /= "") then intg%history_filename = intg%process_id // "." // intg%run_id & // ".history" intg%log_filename = intg%process_id // "." // intg%run_id // ".log" else intg%history_filename = intg%process_id // ".history" intg%log_filename = intg%process_id // ".log" end if intg%vis_history = & var_list%get_lval (var_str ("?vis_history")) end subroutine setup_log_and_history subroutine set_intg_parameters (process) type(process_t), intent(in) :: process intg%n_calls_test = & var_list%get_ival (var_str ("n_calls_test")) intg%combined_integration = & var_list%get_lval (var_str ('?combined_nlo_integration')) & .and. process%is_nlo_calculation () intg%use_color_factors = & var_list%get_lval (var_str ("?read_color_factors")) intg%has_beam_pol = & local%beam_structure%has_polarized_beams () intg%helicity_selection = & local%get_helicity_selection () intg%rebuild_phs = & var_list%get_lval (var_str ("?rebuild_phase_space")) intg%ignore_phs_mismatch = & .not. var_list%get_lval (var_str ("?check_phs_file")) intg%phs_only = & var_list%get_lval (var_str ("?phs_only")) end subroutine set_intg_parameters subroutine display_init_message (verb) logical, intent(in) :: verb if (verb) then call msg_message ("Initializing integration for process " & // char (intg%process_id) // ":") if (intg%run_id /= "") & call msg_message ("Run ID = " // '"' // char (intg%run_id) // '"') end if end subroutine display_init_message subroutine setup_beams () real(default) :: sqrts logical :: decay_rest_frame sqrts = local%get_sqrts () decay_rest_frame = & var_list%get_lval (var_str ("?decay_rest_frame")) if (intg%process_has_me) then call intg%process%setup_beams_beam_structure & (local%beam_structure, sqrts, decay_rest_frame) end if if (verb .and. intg%process_has_me) then call intg%process%beams_startup_message & (beam_structure = local%beam_structure) end if end subroutine setup_beams subroutine setup_structure_functions () integer :: n_in type(pdg_array_t), dimension(:,:), allocatable :: pdg_prc type(string_t) :: sf_trace_file if (intg%process_has_me) then call intg%process%get_pdg_in (pdg_prc) else n_in = intg%process%get_n_in () allocate (pdg_prc (n_in, intg%process%get_n_components ())) pdg_prc = 0 end if call dispatch_sf_config (sf_config, sf_prop, local%beam_structure, & local%get_var_list_ptr (), local%var_list, & local%model, local%os_data, local%get_sqrts (), pdg_prc) sf_trace = & var_list%get_lval (var_str ("?sf_trace")) sf_trace_file = & var_list%get_sval (var_str ("$sf_trace_file")) if (sf_trace) then call intg%process%init_sf_chain (sf_config, sf_trace_file) else call intg%process%init_sf_chain (sf_config) end if end subroutine setup_structure_functions subroutine setup_expressions () type(eval_tree_factory_t) :: expr_factory if (associated (local%pn%cuts_lexpr)) then if (verb) call msg_message ("Applying user-defined cuts.") call expr_factory%init (local%pn%cuts_lexpr) call intg%process%set_cuts (expr_factory) else if (verb) call msg_warning ("No cuts have been defined.") end if if (associated (local%pn%scale_expr)) then if (verb) call msg_message ("Using user-defined general scale.") call expr_factory%init (local%pn%scale_expr) call intg%process%set_scale (expr_factory) end if if (associated (local%pn%fac_scale_expr)) then if (verb) call msg_message ("Using user-defined factorization scale.") call expr_factory%init (local%pn%fac_scale_expr) call intg%process%set_fac_scale (expr_factory) end if if (associated (local%pn%ren_scale_expr)) then if (verb) call msg_message ("Using user-defined renormalization scale.") call expr_factory%init (local%pn%ren_scale_expr) call intg%process%set_ren_scale (expr_factory) end if if (associated (local%pn%weight_expr)) then if (verb) call msg_message ("Using user-defined reweighting factor.") call expr_factory%init (local%pn%weight_expr) call intg%process%set_weight (expr_factory) end if end subroutine setup_expressions end subroutine integration_setup_process @ %def integration_setup_process @ \subsection{Integration} Integrate: do the final integration. Here, we do a multi-iteration integration. Again, we skip iterations that are already on file. Record the results in the global variable list. <>= procedure :: evaluate => integration_evaluate <>= subroutine integration_evaluate & (intg, process_instance, i_mci, pass, it_list, pacify) class(integration_t), intent(inout) :: intg type(process_instance_t), intent(inout), target :: process_instance integer, intent(in) :: i_mci integer, intent(in) :: pass type(iterations_list_t), intent(in) :: it_list logical, intent(in), optional :: pacify integer :: n_calls, n_it logical :: adapt_grids, adapt_weights, final n_it = it_list%get_n_it (pass) n_calls = it_list%get_n_calls (pass) adapt_grids = it_list%adapt_grids (pass) adapt_weights = it_list%adapt_weights (pass) final = pass == it_list%get_n_pass () call process_instance%integrate ( & i_mci, n_it, n_calls, adapt_grids, adapt_weights, & final, pacify) end subroutine integration_evaluate @ %def integration_evaluate @ In case the user has not provided a list of iterations, make a reasonable default. This can depend on the process. The usual approach is to define two distinct passes, one for adaptation and one for integration. <>= procedure :: make_iterations_list => integration_make_iterations_list <>= subroutine integration_make_iterations_list (intg, it_list) class(integration_t), intent(in) :: intg type(iterations_list_t), intent(out) :: it_list integer :: pass, n_pass integer, dimension(:), allocatable :: n_it, n_calls logical, dimension(:), allocatable :: adapt_grids, adapt_weights n_pass = intg%process%get_n_pass_default () allocate (n_it (n_pass), n_calls (n_pass)) allocate (adapt_grids (n_pass), adapt_weights (n_pass)) do pass = 1, n_pass n_it(pass) = intg%process%get_n_it_default (pass) n_calls(pass) = intg%process%get_n_calls_default (pass) adapt_grids(pass) = intg%process%adapt_grids_default (pass) adapt_weights(pass) = intg%process%adapt_weights_default (pass) end do call it_list%init (n_it, n_calls, & adapt_grids = adapt_grids, adapt_weights = adapt_weights) end subroutine integration_make_iterations_list @ %def integration_make_iterations_list @ In NLO calculations, the individual components might scale very differently with the number of calls. This especially applies to the real-subtracted component, which usually fluctuates more than the Born and virtual component, making it a bottleneck of the calculation. Thus, the calculation is throttled twice, first by the number of calls for the real component, second by the number of surplus calls of computation-intense virtual matrix elements. Therefore, we want to set a different number of calls for each component, which is done by the subroutine [[integration_apply_call_multipliers]]. <>= procedure :: init_iteration_multipliers => integration_init_iteration_multipliers <>= subroutine integration_init_iteration_multipliers (intg, local) class(integration_t), intent(inout) :: intg type(rt_data_t), intent(in) :: local integer :: n_pass, pass type(iterations_list_t) :: it_list n_pass = local%it_list%get_n_pass () if (n_pass == 0) then call intg%make_iterations_list (it_list) n_pass = it_list%get_n_pass () end if associate (it_multipliers => intg%iteration_multipliers) allocate (it_multipliers%n_calls0 (n_pass)) do pass = 1, n_pass it_multipliers%n_calls0(pass) = local%it_list%get_n_calls (pass) end do it_multipliers%mult_real = local%var_list%get_rval & (var_str ("mult_call_real")) it_multipliers%mult_virt = local%var_list%get_rval & (var_str ("mult_call_virt")) it_multipliers%mult_dglap = local%var_list%get_rval & (var_str ("mult_call_dglap")) end associate end subroutine integration_init_iteration_multipliers @ %def integration_init_iteration_multipliers @ <>= procedure :: apply_call_multipliers => integration_apply_call_multipliers <>= subroutine integration_apply_call_multipliers (intg, n_pass, i_component, it_list) class(integration_t), intent(in) :: intg integer, intent(in) :: n_pass, i_component type(iterations_list_t), intent(inout) :: it_list integer :: nlo_type integer :: n_calls0, n_calls integer :: pass real(default) :: multiplier nlo_type = intg%process%get_component_nlo_type (i_component) do pass = 1, n_pass associate (multipliers => intg%iteration_multipliers) select case (nlo_type) case (NLO_REAL) multiplier = multipliers%mult_real case (NLO_VIRTUAL) multiplier = multipliers%mult_virt case (NLO_DGLAP) multiplier = multipliers%mult_dglap case default return end select end associate if (n_pass <= size (intg%iteration_multipliers%n_calls0)) then n_calls0 = intg%iteration_multipliers%n_calls0 (pass) n_calls = floor (multiplier * n_calls0) call it_list%set_n_calls (pass, n_calls) end if end do end subroutine integration_apply_call_multipliers @ %def integration_apply_call_multipliers @ \subsection{API for integration objects} This initializer does everything except assigning cuts/scale/weight expressions. <>= procedure :: init => integration_init <>= subroutine integration_init & (intg, process_id, local, global, local_stack, init_only) class(integration_t), intent(out) :: intg type(string_t), intent(in) :: process_id type(rt_data_t), intent(inout), target :: local type(rt_data_t), intent(inout), optional, target :: global logical, intent(in), optional :: init_only logical, intent(in), optional :: local_stack logical :: use_local use_local = .false.; if (present (local_stack)) use_local = local_stack if (present (global)) then call intg%create_process (process_id, global) else if (use_local) then call intg%create_process (process_id, local) else call intg%create_process (process_id) end if call intg%init_process (local) call intg%setup_process (local, init_only = init_only) call intg%init_iteration_multipliers (local) end subroutine integration_init @ %def integration_init @ Do the integration for a single process, both warmup and final evaluation. The [[eff_reset]] flag is to suppress numerical noise in the graphical output of the integration history. <>= procedure :: integrate => integration_integrate <>= subroutine integration_integrate (intg, local, eff_reset) class(integration_t), intent(inout) :: intg type(rt_data_t), intent(in), target :: local logical, intent(in), optional :: eff_reset type(string_t) :: log_filename type(var_list_t), pointer :: var_list type(process_instance_t), allocatable, target :: process_instance type(iterations_list_t) :: it_list logical :: pacify integer :: pass, i_mci, n_mci, n_pass integer :: i_component integer :: nlo_type logical :: display_summed logical :: nlo_active type(string_t) :: component_output allocate (process_instance) call process_instance%init (intg%process) var_list => intg%process%get_var_list_ptr () call openmp_set_num_threads_verbose & (var_list%get_ival (var_str ("openmp_num_threads")), & var_list%get_lval (var_str ("?openmp_logging"))) pacify = var_list%get_lval (var_str ("?pacify")) display_summed = .true. n_mci = intg%process%get_n_mci () if (n_mci == 1) then write (msg_buffer, "(A,A,A)") & "Starting integration for process '", & char (intg%process%get_id ()), "'" call msg_message () end if call setup_hooks () nlo_active = any (intg%process%get_component_nlo_type & ([(i_mci, i_mci = 1, n_mci)]) /= BORN) do i_mci = 1, n_mci i_component = intg%process%get_master_component (i_mci) nlo_type = intg%process%get_component_nlo_type (i_component) if (intg%process%component_can_be_integrated (i_component)) then if (n_mci > 1) then if (nlo_active) then if (intg%combined_integration .and. nlo_type == BORN) then component_output = var_str ("Combined") else component_output = component_status (nlo_type) end if write (msg_buffer, "(A,A,A,A,A)") & "Starting integration for process '", & char (intg%process%get_id ()), "' part '", & char (component_output), "'" else write (msg_buffer, "(A,A,A,I0)") & "Starting integration for process '", & char (intg%process%get_id ()), "' part ", i_mci end if call msg_message () end if n_pass = local%it_list%get_n_pass () if (n_pass == 0) then call msg_message ("Integrate: iterations not specified, & &using default") call intg%make_iterations_list (it_list) n_pass = it_list%get_n_pass () else it_list = local%it_list end if call intg%apply_call_multipliers (n_pass, i_mci, it_list) call msg_message ("Integrate: " // char (it_list%to_string ())) do pass = 1, n_pass call intg%evaluate (process_instance, i_mci, pass, it_list, pacify) if (signal_is_pending ()) return end do call intg%process%final_integration (i_mci) if (intg%vis_history) then call intg%process%display_integration_history & (i_mci, intg%history_filename, local%os_data, eff_reset) end if if (local%logfile == intg%log_filename) then if (intg%run_id /= "") then log_filename = intg%process_id // "." // intg%run_id // & ".var.log" else log_filename = intg%process_id // ".var.log" end if call msg_message ("Name clash for global logfile and process log: ", & arr =[var_str ("| Renaming log file from ") // local%logfile, & var_str ("| to ") // log_filename // var_str (" .")]) else log_filename = intg%log_filename end if call intg%process%write_logfile (i_mci, log_filename) end if end do if (n_mci > 1 .and. display_summed) then call msg_message ("Integrate: sum of all components") call intg%process%display_summed_results (pacify) end if call process_instance%final () deallocate (process_instance) contains subroutine setup_hooks () class(process_instance_hook_t), pointer :: hook call dispatch_evt_shower_hook (hook, var_list, process_instance) if (associated (hook)) then call process_instance%append_after_hook (hook) end if end subroutine setup_hooks end subroutine integration_integrate @ %def integration_integrate @ Do a dummy integration for a process which could not be initialized (e.g., has no matrix element). The result is zero. <>= procedure :: integrate_dummy => integration_integrate_dummy <>= subroutine integration_integrate_dummy (intg) class(integration_t), intent(inout) :: intg call intg%process%integrate_dummy () end subroutine integration_integrate_dummy @ %def integration_integrate_dummy @ Just sample the matrix element under realistic conditions (but no cuts); throw away the results. <>= procedure :: sampler_test => integration_sampler_test <>= subroutine integration_sampler_test (intg) class(integration_t), intent(inout) :: intg type(process_instance_t), allocatable, target :: process_instance integer :: n_mci, i_mci type(timer_t) :: timer_mci, timer_tot real(default) :: t_mci, t_tot allocate (process_instance) call process_instance%init (intg%process) n_mci = intg%process%get_n_mci () if (n_mci == 1) then write (msg_buffer, "(A,A,A)") & "Test: probing process '", & char (intg%process%get_id ()), "'" call msg_message () end if call timer_tot%start () do i_mci = 1, n_mci if (n_mci > 1) then write (msg_buffer, "(A,A,A,I0)") & "Test: probing process '", & char (intg%process%get_id ()), "' part ", i_mci call msg_message () end if call timer_mci%start () call process_instance%sampler_test (i_mci, intg%n_calls_test) call timer_mci%stop () t_mci = timer_mci write (msg_buffer, "(A,ES12.5)") "Test: " & // "time in seconds (wallclock): ", t_mci call msg_message () end do call timer_tot%stop () t_tot = timer_tot if (n_mci > 1) then write (msg_buffer, "(A,ES12.5)") "Test: " & // "total time (wallclock): ", t_tot call msg_message () end if call process_instance%final () end subroutine integration_sampler_test @ %def integration_sampler_test @ Return the process pointer (needed by simulate): <>= procedure :: get_process_ptr => integration_get_process_ptr <>= function integration_get_process_ptr (intg) result (ptr) class(integration_t), intent(in) :: intg type(process_t), pointer :: ptr ptr => intg%process end function integration_get_process_ptr @ %def integration_get_process_ptr @ Simply integrate, do a dummy integration if necessary. The [[integration]] object exists only internally. If the [[global]] environment is provided, the process object is appended to the global stack. Otherwise, if [[local_stack]] is set, we append to the local process stack. If this is unset, the [[process]] object is not recorded permanently. The [[init_only]] flag can be used to skip the actual integration part. We will end up with a process object that is completely initialized, including phase space configuration. The [[eff_reset]] flag is to suppress numerical noise in the visualization of the integration history. <>= public :: integrate_process <>= subroutine integrate_process (process_id, local, global, local_stack, init_only, eff_reset) type(string_t), intent(in) :: process_id type(rt_data_t), intent(inout), target :: local type(rt_data_t), intent(inout), optional, target :: global logical, intent(in), optional :: local_stack, init_only, eff_reset type(string_t) :: prclib_name type(integration_t) :: intg character(32) :: buffer <> <> if (.not. associated (local%prclib)) then call msg_fatal ("Integrate: current process library is undefined") return end if if (.not. local%prclib%is_active ()) then call msg_message ("Integrate: current process library needs compilation") prclib_name = local%prclib%get_name () call compile_library (prclib_name, local) if (signal_is_pending ()) return call msg_message ("Integrate: compilation done") end if call intg%init (process_id, local, global, local_stack, init_only) if (signal_is_pending ()) return if (present (init_only)) then if (init_only) return end if if (intg%n_calls_test > 0) then write (buffer, "(I0)") intg%n_calls_test call msg_message ("Integrate: test (" // trim (buffer) // " calls) ...") call intg%sampler_test () call msg_message ("Integrate: ... test complete.") if (signal_is_pending ()) return end if <> if (intg%phs_only) then call msg_message ("Integrate: phase space only, skipping integration") else if (intg%process_has_me) then call intg%integrate (local, eff_reset) else call intg%integrate_dummy () end if end if end subroutine integrate_process @ %def integrate_process <>= @ <>= @ <>= @ @ The parallelization leads to undefined behavior while writing simultaneously to one file. The master worker has to initialize single-handed the corresponding library files and the phase space file. The slave worker will wait with a blocking [[MPI_BCAST]] until they receive a logical flag. <>= type(var_list_t), pointer :: var_list logical :: mpi_logging, process_init integer :: rank, n_size <>= if (debug_on) call msg_debug (D_MPI, "integrate_process") var_list => local%get_var_list_ptr () process_init = .false. call mpi_get_comm_id (n_size, rank) mpi_logging = (("vamp2" == char (var_list%get_sval (var_str ("$integration_method"))) .and. & & (n_size > 1)) .or. var_list%get_lval (var_str ("?mpi_logging"))) if (debug_on) call msg_debug (D_MPI, "n_size", rank) if (debug_on) call msg_debug (D_MPI, "rank", rank) if (debug_on) call msg_debug (D_MPI, "mpi_logging", mpi_logging) if (rank /= 0) then if (mpi_logging) then call msg_message ("MPI: wait for master to finish process initialization ...") end if call MPI_bcast (process_init, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD) else process_init = .true. end if if (process_init) then <>= if (rank == 0) then if (mpi_logging) then call msg_message ("MPI: finish process initialization, load slaves ...") end if call MPI_bcast (process_init, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD) end if end if call MPI_barrier (MPI_COMM_WORLD) call mpi_set_logging (mpi_logging) @ %def integrate_process_mpi @ \subsection{Unit Tests} Test module, followed by the stand-alone unit-test procedures. <<[[integrations_ut.f90]]>>= <> module integrations_ut use unit_tests use integrations_uti <> <> contains <> end module integrations_ut @ %def integrations_ut @ <<[[integrations_uti.f90]]>>= <> module integrations_uti <> <> use io_units use ifiles use lexers use parser use flavors use interactions, only: reset_interaction_counter use phs_forests use eval_trees use models use rt_data use process_configurations_ut, only: prepare_test_library use compilations, only: compile_library use integrations use phs_wood_ut, only: write_test_phs_file <> <> contains <> end module integrations_uti @ %def integrations_uti @ API: driver for the unit tests below. <>= public :: integrations_test <>= subroutine integrations_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine integrations_test @ %def integrations_test @ <>= public :: integrations_history_test <>= subroutine integrations_history_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine integrations_history_test @ %def integrations_history_test @ \subsubsection{Integration of test process} Compile and integrate an intrinsic test matrix element ([[prc_test]] type). The phase-space implementation is [[phs_single]] (single-particle phase space), the integrator is [[mci_midpoint]]. The cross section for the $2\to 2$ process $ss\to ss$ with its constant matrix element is given by \begin{equation} \sigma = c\times f\times \Phi_2 \times |M|^2. \end{equation} $c$ is the conversion constant \begin{equation} c = 0.3894\times 10^{12}\;\mathrm{fb}\,\mathrm{GeV}^2. \end{equation} $f$ is the flux of the incoming particles with mass $m=125\,\mathrm{GeV}$ and energy $\sqrt{s}=1000\,\mathrm{GeV}$ \begin{equation} f = \frac{(2\pi)^4}{2\lambda^{1/2}(s,m^2,m^2)} = \frac{(2\pi)^4}{2\sqrt{s}\,\sqrt{s - 4m^2}} = 8.048\times 10^{-4}\;\mathrm{GeV}^{-2} \end{equation} $\Phi_2$ is the volume of the two-particle phase space \begin{equation} \Phi_2 = \frac{1}{4(2\pi)^5} = 2.5529\times 10^{-5}. \end{equation} The squared matrix element $|M|^2$ is unity. Combining everything, we obtain \begin{equation} \sigma = 8000\;\mathrm{fb} \end{equation} This number should appear as the final result. Note: In this and the following test, we reset the Fortran compiler and flag variables immediately before they are printed, so the test is portable. <>= call test (integrations_1, "integrations_1", & "intrinsic test process", & u, results) <>= public :: integrations_1 <>= subroutine integrations_1 (u) integer, intent(in) :: u type(string_t) :: libname, procname type(rt_data_t), target :: global write (u, "(A)") "* Test output: integrations_1" write (u, "(A)") "* Purpose: integrate test process" write (u, "(A)") call syntax_model_file_init () call global%global_init () libname = "integration_1" procname = "prc_config_a" call prepare_test_library (global, libname, 1) call compile_library (libname, global) call global%set_string (var_str ("$run_id"), & var_str ("integrations1"), is_known = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("single"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known=.true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%it_list%init ([1], [1000]) call reset_interaction_counter () call integrate_process (procname, global, local_stack=.true.) call global%write (u, vars = [ & var_str ("$method"), & var_str ("sqrts"), & var_str ("$integration_method"), & var_str ("$phs_method"), & var_str ("$run_id")]) call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: integrations_1" end subroutine integrations_1 @ %def integrations_1 @ \subsubsection{Integration with cuts} Compile and integrate an intrinsic test matrix element ([[prc_test]] type) with cuts set. <>= call test (integrations_2, "integrations_2", & "intrinsic test process with cut", & u, results) <>= public :: integrations_2 <>= subroutine integrations_2 (u) integer, intent(in) :: u type(string_t) :: libname, procname type(rt_data_t), target :: global type(string_t) :: cut_expr_text type(ifile_t) :: ifile type(stream_t) :: stream type(parse_tree_t) :: parse_tree type(string_t), dimension(0) :: empty_string_array write (u, "(A)") "* Test output: integrations_2" write (u, "(A)") "* Purpose: integrate test process with cut" write (u, "(A)") call syntax_model_file_init () call global%global_init () write (u, "(A)") "* Prepare a cut expression" write (u, "(A)") call syntax_pexpr_init () cut_expr_text = "all Pt > 100 [s]" call ifile_append (ifile, cut_expr_text) call stream_init (stream, ifile) call parse_tree_init_lexpr (parse_tree, stream, .true.) global%pn%cuts_lexpr => parse_tree%get_root_ptr () write (u, "(A)") "* Build and initialize a test process" write (u, "(A)") libname = "integration_3" procname = "prc_config_a" call prepare_test_library (global, libname, 1) call compile_library (libname, global) call global%set_string (var_str ("$run_id"), & var_str ("integrations1"), is_known = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("single"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known=.true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%it_list%init ([1], [1000]) call reset_interaction_counter () call integrate_process (procname, global, local_stack=.true.) call global%write (u, vars = empty_string_array) call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: integrations_2" end subroutine integrations_2 @ %def integrations_2 @ \subsubsection{Standard phase space} Compile and integrate an intrinsic test matrix element ([[prc_test]] type) using the default ([[phs_wood]]) phase-space implementation. We use an explicit phase-space configuration file with a single channel and integrate by [[mci_midpoint]]. <>= call test (integrations_3, "integrations_3", & "standard phase space", & u, results) <>= public :: integrations_3 <>= subroutine integrations_3 (u) <> <> use interactions, only: reset_interaction_counter use models use rt_data use process_configurations_ut, only: prepare_test_library use compilations, only: compile_library use integrations implicit none integer, intent(in) :: u type(string_t) :: libname, procname type(rt_data_t), target :: global integer :: u_phs write (u, "(A)") "* Test output: integrations_3" write (u, "(A)") "* Purpose: integrate test process" write (u, "(A)") write (u, "(A)") "* Initialize process and parameters" write (u, "(A)") call syntax_model_file_init () call syntax_phs_forest_init () call global%global_init () libname = "integration_3" procname = "prc_config_a" call prepare_test_library (global, libname, 1) call compile_library (libname, global) call global%set_string (var_str ("$run_id"), & var_str ("integrations1"), is_known = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("default"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_log (var_str ("?phs_s_mapping"),& .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known=.true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) write (u, "(A)") "* Create a scratch phase-space file" write (u, "(A)") u_phs = free_unit () open (u_phs, file = "integrations_3.phs", & status = "replace", action = "write") call write_test_phs_file (u_phs, var_str ("prc_config_a_i1")) close (u_phs) call global%set_string (var_str ("$phs_file"),& var_str ("integrations_3.phs"), is_known = .true.) call global%it_list%init ([1], [1000]) write (u, "(A)") "* Integrate" write (u, "(A)") call reset_interaction_counter () call integrate_process (procname, global, local_stack=.true.) call global%write (u, vars = [ & var_str ("$phs_method"), & var_str ("$phs_file")]) write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () call syntax_phs_forest_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: integrations_3" end subroutine integrations_3 @ %def integrations_3 @ \subsubsection{VAMP integration} Compile and integrate an intrinsic test matrix element ([[prc_test]] type) using the single-channel ([[phs_single]]) phase-space implementation. The integration method is [[vamp]]. <>= call test (integrations_4, "integrations_4", & "VAMP integration (one iteration)", & u, results) <>= public :: integrations_4 <>= subroutine integrations_4 (u) integer, intent(in) :: u type(string_t) :: libname, procname type(rt_data_t), target :: global write (u, "(A)") "* Test output: integrations_4" write (u, "(A)") "* Purpose: integrate test process using VAMP" write (u, "(A)") write (u, "(A)") "* Initialize process and parameters" write (u, "(A)") call syntax_model_file_init () call global%global_init () libname = "integrations_4_lib" procname = "integrations_4" call prepare_test_library (global, libname, 1, [procname]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_grids"), .true., intrinsic = .true.) call global%set_string (var_str ("$run_id"), & var_str ("r1"), is_known = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("single"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("vamp"), is_known = .true.) call global%set_log (var_str ("?use_vamp_equivalences"),& .false., is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known=.true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%it_list%init ([1], [1000]) write (u, "(A)") "* Integrate" write (u, "(A)") call reset_interaction_counter () call integrate_process (procname, global, local_stack=.true.) call global%pacify (efficiency_reset = .true., error_reset = .true.) call global%write (u, vars = [var_str ("$integration_method")], & pacify = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: integrations_4" end subroutine integrations_4 @ %def integrations_4 @ \subsubsection{Multiple iterations integration} Compile and integrate an intrinsic test matrix element ([[prc_test]] type) using the single-channel ([[phs_single]]) phase-space implementation. The integration method is [[vamp]]. We launch three iterations. <>= call test (integrations_5, "integrations_5", & "VAMP integration (three iterations)", & u, results) <>= public :: integrations_5 <>= subroutine integrations_5 (u) integer, intent(in) :: u type(string_t) :: libname, procname type(rt_data_t), target :: global write (u, "(A)") "* Test output: integrations_5" write (u, "(A)") "* Purpose: integrate test process using VAMP" write (u, "(A)") write (u, "(A)") "* Initialize process and parameters" write (u, "(A)") call syntax_model_file_init () call global%global_init () libname = "integrations_5_lib" procname = "integrations_5" call prepare_test_library (global, libname, 1, [procname]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_grids"), .true., intrinsic = .true.) call global%set_string (var_str ("$run_id"), & var_str ("r1"), is_known = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("single"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("vamp"), is_known = .true.) call global%set_log (var_str ("?use_vamp_equivalences"),& .false., is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known=.true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%it_list%init ([3], [1000]) write (u, "(A)") "* Integrate" write (u, "(A)") call reset_interaction_counter () call integrate_process (procname, global, local_stack=.true.) call global%pacify (efficiency_reset = .true., error_reset = .true.) call global%write (u, vars = [var_str ("$integration_method")], & pacify = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: integrations_5" end subroutine integrations_5 @ %def integrations_5 @ \subsubsection{Multiple passes integration} Compile and integrate an intrinsic test matrix element ([[prc_test]] type) using the single-channel ([[phs_single]]) phase-space implementation. The integration method is [[vamp]]. We launch three passes with three iterations each. <>= call test (integrations_6, "integrations_6", & "VAMP integration (three passes)", & u, results) <>= public :: integrations_6 <>= subroutine integrations_6 (u) integer, intent(in) :: u type(string_t) :: libname, procname type(rt_data_t), target :: global type(string_t), dimension(0) :: no_vars write (u, "(A)") "* Test output: integrations_6" write (u, "(A)") "* Purpose: integrate test process using VAMP" write (u, "(A)") write (u, "(A)") "* Initialize process and parameters" write (u, "(A)") call syntax_model_file_init () call global%global_init () libname = "integrations_6_lib" procname = "integrations_6" call prepare_test_library (global, libname, 1, [procname]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_grids"), .true., intrinsic = .true.) call global%set_string (var_str ("$run_id"), & var_str ("r1"), is_known = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("single"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("vamp"), is_known = .true.) call global%set_log (var_str ("?use_vamp_equivalences"),& .false., is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known=.true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%it_list%init ([3, 3, 3], [1000, 1000, 1000], & adapt = [.true., .true., .false.], & adapt_code = [var_str ("wg"), var_str ("g"), var_str ("")]) write (u, "(A)") "* Integrate" write (u, "(A)") call reset_interaction_counter () call integrate_process (procname, global, local_stack=.true.) call global%pacify (efficiency_reset = .true., error_reset = .true.) call global%write (u, vars = no_vars, pacify = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: integrations_6" end subroutine integrations_6 @ %def integrations_6 @ \subsubsection{VAMP and default phase space} Compile and integrate an intrinsic test matrix element ([[prc_test]] type) using the default ([[phs_wood]]) phase-space implementation. The integration method is [[vamp]]. We launch three passes with three iterations each. We enable channel equivalences and groves. <>= call test (integrations_7, "integrations_7", & "VAMP integration with wood phase space", & u, results) <>= public :: integrations_7 <>= subroutine integrations_7 (u) integer, intent(in) :: u type(string_t) :: libname, procname type(rt_data_t), target :: global type(string_t), dimension(0) :: no_vars integer :: iostat, u_phs character(95) :: buffer type(string_t) :: phs_file logical :: exist write (u, "(A)") "* Test output: integrations_7" write (u, "(A)") "* Purpose: integrate test process using VAMP" write (u, "(A)") write (u, "(A)") "* Initialize process and parameters" write (u, "(A)") call syntax_model_file_init () call syntax_phs_forest_init () call global%global_init () libname = "integrations_7_lib" procname = "integrations_7" call prepare_test_library (global, libname, 1, [procname]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_grids"), .true., intrinsic = .true.) call global%set_string (var_str ("$run_id"), & var_str ("r1"), is_known = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("wood"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("vamp"), is_known = .true.) call global%set_log (var_str ("?use_vamp_equivalences"),& .true., is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_log (var_str ("?phs_s_mapping"),& .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known=.true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%it_list%init ([3, 3, 3], [1000, 1000, 1000], & adapt = [.true., .true., .false.], & adapt_code = [var_str ("wg"), var_str ("g"), var_str ("")]) write (u, "(A)") "* Integrate" write (u, "(A)") call reset_interaction_counter () call integrate_process (procname, global, local_stack=.true.) call global%pacify (efficiency_reset = .true., error_reset = .true.) call global%write (u, vars = no_vars, pacify = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () call syntax_phs_forest_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Generated phase-space file" write (u, "(A)") phs_file = procname // ".r1.i1.phs" inquire (file = char (phs_file), exist = exist) if (exist) then u_phs = free_unit () open (u_phs, file = char (phs_file), action = "read", status = "old") iostat = 0 do while (iostat == 0) read (u_phs, "(A)", iostat = iostat) buffer if (iostat == 0) write (u, "(A)") trim (buffer) end do close (u_phs) else write (u, "(A)") "[file is missing]" end if write (u, "(A)") write (u, "(A)") "* Test output end: integrations_7" end subroutine integrations_7 @ %def integrations_7 @ \subsubsection{Structure functions} Compile and integrate an intrinsic test matrix element ([[prc_test]] type) using the default ([[phs_wood]]) phase-space implementation. The integration method is [[vamp]]. There is a structure function of type [[unit_test]]. We use a test structure function $f(x)=x$ for both beams. Together with the $1/x_1x_2$ factor from the phase-space flux and a unit matrix element, we should get the same result as previously for the process without structure functions. There is a slight correction due to the $m_s$ mass which we set to zero here. <>= call test (integrations_8, "integrations_8", & "integration with structure function", & u, results) <>= public :: integrations_8 <>= subroutine integrations_8 (u) <> <> use interactions, only: reset_interaction_counter use phs_forests use models use rt_data use process_configurations_ut, only: prepare_test_library use compilations, only: compile_library use integrations implicit none integer, intent(in) :: u type(string_t) :: libname, procname type(rt_data_t), target :: global type(flavor_t) :: flv type(string_t) :: name write (u, "(A)") "* Test output: integrations_8" write (u, "(A)") "* Purpose: integrate test process using VAMP & &with structure function" write (u, "(A)") write (u, "(A)") "* Initialize process and parameters" write (u, "(A)") call syntax_model_file_init () call syntax_phs_forest_init () call global%global_init () libname = "integrations_8_lib" procname = "integrations_8" call prepare_test_library (global, libname, 1, [procname]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_grids"), .true., intrinsic = .true.) call global%set_string (var_str ("$run_id"), & var_str ("r1"), is_known = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("wood"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("vamp"), is_known = .true.) call global%set_log (var_str ("?use_vamp_equivalences"),& .true., is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_log (var_str ("?phs_s_mapping"),& .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known=.true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%model_set_real (var_str ("ms"), 0._default) call reset_interaction_counter () call flv%init (25, global%model) name = flv%get_name () call global%beam_structure%init_sf ([name, name], [1]) call global%beam_structure%set_sf (1, 1, var_str ("sf_test_1")) write (u, "(A)") "* Integrate" write (u, "(A)") call global%it_list%init ([1], [1000]) call integrate_process (procname, global, local_stack=.true.) call global%write (u, vars = [var_str ("ms")]) write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () call syntax_phs_forest_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: integrations_8" end subroutine integrations_8 @ %def integrations_8 @ \subsubsection{Integration with sign change} Compile and integrate an intrinsic test matrix element ([[prc_test]] type). The phase-space implementation is [[phs_single]] (single-particle phase space), the integrator is [[mci_midpoint]]. The weight that is applied changes the sign in half of phase space. The weight is $-3$ and $1$, respectively, so the total result is equal to the original, but negative sign. The efficiency should (approximately) become the average of $1$ and $1/3$, that is $2/3$. <>= call test (integrations_9, "integrations_9", & "handle sign change", & u, results) <>= public :: integrations_9 <>= subroutine integrations_9 (u) integer, intent(in) :: u type(string_t) :: libname, procname type(rt_data_t), target :: global type(string_t) :: wgt_expr_text type(ifile_t) :: ifile type(stream_t) :: stream type(parse_tree_t) :: parse_tree write (u, "(A)") "* Test output: integrations_9" write (u, "(A)") "* Purpose: integrate test process" write (u, "(A)") call syntax_model_file_init () call global%global_init () write (u, "(A)") "* Prepare a weight expression" write (u, "(A)") call syntax_pexpr_init () wgt_expr_text = "eval 2 * sgn (Pz) - 1 [s]" call ifile_append (ifile, wgt_expr_text) call stream_init (stream, ifile) call parse_tree_init_expr (parse_tree, stream, .true.) global%pn%weight_expr => parse_tree%get_root_ptr () write (u, "(A)") "* Build and evaluate a test process" write (u, "(A)") libname = "integration_9" procname = "prc_config_a" call prepare_test_library (global, libname, 1) call compile_library (libname, global) call global%set_string (var_str ("$run_id"), & var_str ("integrations1"), is_known = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("single"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known=.true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%it_list%init ([1], [1000]) call reset_interaction_counter () call integrate_process (procname, global, local_stack=.true.) call global%write (u, vars = [ & var_str ("$method"), & var_str ("sqrts"), & var_str ("$integration_method"), & var_str ("$phs_method"), & var_str ("$run_id")]) call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: integrations_9" end subroutine integrations_9 @ %def integrations_9 @ \subsubsection{Integration history for VAMP integration with default phase space} This test is only run when event analysis can be done. <>= call test (integrations_history_1, "integrations_history_1", & "Test integration history files", & u, results) <>= public :: integrations_history_1 <>= subroutine integrations_history_1 (u) integer, intent(in) :: u type(string_t) :: libname, procname type(rt_data_t), target :: global type(string_t), dimension(0) :: no_vars integer :: iostat, u_his character(91) :: buffer type(string_t) :: his_file, ps_file, pdf_file logical :: exist, exist_ps, exist_pdf write (u, "(A)") "* Test output: integrations_history_1" write (u, "(A)") "* Purpose: test integration history files" write (u, "(A)") write (u, "(A)") "* Initialize process and parameters" write (u, "(A)") call syntax_model_file_init () call syntax_phs_forest_init () call global%global_init () libname = "integrations_history_1_lib" procname = "integrations_history_1" call global%set_log (var_str ("?vis_history"), & .true., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_log (var_str ("?phs_s_mapping"),& .false., is_known = .true.) call prepare_test_library (global, libname, 1, [procname]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_grids"), .true., intrinsic = .true.) call global%set_string (var_str ("$run_id"), & var_str ("r1"), is_known = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("wood"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("vamp"), is_known = .true.) call global%set_log (var_str ("?use_vamp_equivalences"),& .true., is_known = .true.) call global%set_real (var_str ("error_threshold"),& 5E-6_default, is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known=.true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%it_list%init ([2, 2, 2], [1000, 1000, 1000], & adapt = [.true., .true., .false.], & adapt_code = [var_str ("wg"), var_str ("g"), var_str ("")]) write (u, "(A)") "* Integrate" write (u, "(A)") call reset_interaction_counter () call integrate_process (procname, global, local_stack=.true., & eff_reset = .true.) call global%pacify (efficiency_reset = .true., error_reset = .true.) call global%write (u, vars = no_vars, pacify = .true.) write (u, "(A)") write (u, "(A)") "* Generated history files" write (u, "(A)") his_file = procname // ".r1.history.tex" ps_file = procname // ".r1.history.ps" pdf_file = procname // ".r1.history.pdf" inquire (file = char (his_file), exist = exist) if (exist) then u_his = free_unit () open (u_his, file = char (his_file), action = "read", status = "old") iostat = 0 do while (iostat == 0) read (u_his, "(A)", iostat = iostat) buffer if (iostat == 0) write (u, "(A)") trim (buffer) end do close (u_his) else write (u, "(A)") "[History LaTeX file is missing]" end if inquire (file = char (ps_file), exist = exist_ps) if (exist_ps) then write (u, "(A)") "[History Postscript file exists and is nonempty]" else write (u, "(A)") "[History Postscript file is missing/non-regular]" end if inquire (file = char (pdf_file), exist = exist_pdf) if (exist_pdf) then write (u, "(A)") "[History PDF file exists and is nonempty]" else write (u, "(A)") "[History PDF file is missing/non-regular]" end if write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () call syntax_phs_forest_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: integrations_history_1" end subroutine integrations_history_1 @ %def integrations_history_1 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Event Streams} This module manages I/O from/to multiple concurrent event streams. Usually, there is at most one input stream, but several output streams. For the latter, we set up an array which can hold [[eio_t]] (event I/O) objects of different dynamic types simultaneously. One of them may be marked as an input channel. <<[[event_streams.f90]]>>= <> module event_streams <> use io_units use diagnostics use events use event_handles, only: event_handle_t use eio_data use eio_base use rt_data use dispatch_transforms, only: dispatch_eio <> <> <> contains <> end module event_streams @ %def event_streams @ \subsection{Event Stream Array} Each entry is an [[eio_t]] object. Since the type is dynamic, we need a wrapper: <>= type :: event_stream_entry_t class(eio_t), allocatable :: eio end type event_stream_entry_t @ %def event_stream_entry_t @ An array of event-stream entry objects. If one of the entries is an input channel, [[i_in]] is the corresponding index. <>= public :: event_stream_array_t <>= type :: event_stream_array_t type(event_stream_entry_t), dimension(:), allocatable :: entry integer :: i_in = 0 contains <> end type event_stream_array_t @ %def event_stream_array_t @ Output. <>= procedure :: write => event_stream_array_write <>= subroutine event_stream_array_write (object, unit) class(event_stream_array_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) write (u, "(1x,A)") "Event stream array:" if (allocated (object%entry)) then select case (size (object%entry)) case (0) write (u, "(3x,A)") "[empty]" case default do i = 1, size (object%entry) if (i == object%i_in) write (u, "(1x,A)") "Input stream:" call object%entry(i)%eio%write (u) end do end select else write (u, "(3x,A)") "[undefined]" end if end subroutine event_stream_array_write @ %def event_stream_array_write @ Check if there is content. <>= procedure :: is_valid => event_stream_array_is_valid <>= function event_stream_array_is_valid (es_array) result (flag) class(event_stream_array_t), intent(in) :: es_array logical :: flag flag = allocated (es_array%entry) end function event_stream_array_is_valid @ %def event_stream_array_is_valid @ Finalize all streams. <>= procedure :: final => event_stream_array_final <>= subroutine event_stream_array_final (es_array) class(event_stream_array_t), intent(inout) :: es_array integer :: i if (allocated (es_array%entry)) then do i = 1, size (es_array%entry) call es_array%entry(i)%eio%final () end do end if end subroutine event_stream_array_final @ %def event_stream_array_final @ Initialization. We use a generic [[sample]] name, open event I/O objects for all provided stream types (using the [[dispatch_eio]] routine), and initialize for the given list of process pointers. If there is an [[input]] argument, this channel is initialized as an input channel and appended to the array. The [[input_data]] or, if not present, [[data]] may be modified. This happens if we open a stream for reading and get new information there. <>= procedure :: init => event_stream_array_init <>= subroutine event_stream_array_init & (es_array, sample, stream_fmt, global, & data, input, input_sample, input_data, allow_switch, & checkpoint, callback, & error) class(event_stream_array_t), intent(out) :: es_array type(string_t), intent(in) :: sample type(string_t), dimension(:), intent(in) :: stream_fmt type(rt_data_t), intent(in) :: global type(event_sample_data_t), intent(inout), optional :: data type(string_t), intent(in), optional :: input type(string_t), intent(in), optional :: input_sample type(event_sample_data_t), intent(inout), optional :: input_data logical, intent(in), optional :: allow_switch integer, intent(in), optional :: checkpoint integer, intent(in), optional :: callback logical, intent(out), optional :: error type(string_t) :: sample_in integer :: n, i, n_output, i_input, i_checkpoint, i_callback logical :: success, switch if (present (input_sample)) then sample_in = input_sample else sample_in = sample end if if (present (allow_switch)) then switch = allow_switch else switch = .true. end if if (present (error)) then error = .false. end if n = size (stream_fmt) n_output = n if (present (input)) then n = n + 1 i_input = n else i_input = 0 end if if (present (checkpoint)) then n = n + 1 i_checkpoint = n else i_checkpoint = 0 end if if (present (callback)) then n = n + 1 i_callback = n else i_callback = 0 end if allocate (es_array%entry (n)) if (i_checkpoint > 0) then call dispatch_eio & (es_array%entry(i_checkpoint)%eio, var_str ("checkpoint"), & global%var_list, global%fallback_model, & global%event_callback) call es_array%entry(i_checkpoint)%eio%init_out (sample, data) end if if (i_callback > 0) then call dispatch_eio & (es_array%entry(i_callback)%eio, var_str ("callback"), & global%var_list, global%fallback_model, & global%event_callback) call es_array%entry(i_callback)%eio%init_out (sample, data) end if if (i_input > 0) then call dispatch_eio (es_array%entry(i_input)%eio, input, & global%var_list, global%fallback_model, & global%event_callback) if (present (input_data)) then call es_array%entry(i_input)%eio%init_in & (sample_in, input_data, success) else call es_array%entry(i_input)%eio%init_in & (sample_in, data, success) end if if (success) then es_array%i_in = i_input else if (present (input_sample)) then if (present (error)) then error = .true. else call msg_fatal ("Events: & ¶meter mismatch in input, aborting") end if else call msg_message ("Events: & ¶meter mismatch, discarding old event set") call es_array%entry(i_input)%eio%final () if (switch) then call msg_message ("Events: generating new events") call es_array%entry(i_input)%eio%init_out (sample, data) end if end if end if do i = 1, n_output call dispatch_eio (es_array%entry(i)%eio, stream_fmt(i), & global%var_list, global%fallback_model, & global%event_callback) call es_array%entry(i)%eio%init_out (sample, data) end do end subroutine event_stream_array_init @ %def event_stream_array_init @ Switch the (only) input channel to an output channel, so further events are appended to the respective stream. <>= procedure :: switch_inout => event_stream_array_switch_inout <>= subroutine event_stream_array_switch_inout (es_array) class(event_stream_array_t), intent(inout) :: es_array integer :: n if (es_array%has_input ()) then n = es_array%i_in call es_array%entry(n)%eio%switch_inout () es_array%i_in = 0 else call msg_bug ("Reading events: switch_inout: no input stream selected") end if end subroutine event_stream_array_switch_inout @ %def event_stream_array_switch_inout @ Output an event (with given process number) to all output streams. If there is no output stream, do nothing. <>= procedure :: output => event_stream_array_output <>= subroutine event_stream_array_output & (es_array, event, i_prc, event_index, passed, pacify, event_handle) class(event_stream_array_t), intent(inout) :: es_array type(event_t), intent(in), target :: event integer, intent(in) :: i_prc, event_index logical, intent(in), optional :: passed, pacify class(event_handle_t), intent(inout), optional :: event_handle logical :: increased integer :: i do i = 1, size (es_array%entry) if (i /= es_array%i_in) then associate (eio => es_array%entry(i)%eio) if (eio%split) then if (eio%split_n_evt > 0 .and. event_index > 1) then if (mod (event_index, eio%split_n_evt) == 1) then call eio%split_out () end if else if (eio%split_n_kbytes > 0) then call eio%update_split_count (increased) if (increased) call eio%split_out () end if end if call eio%output (event, i_prc, reading = es_array%i_in /= 0, & passed = passed, & pacify = pacify, & event_handle = event_handle) end associate end if end do end subroutine event_stream_array_output @ %def event_stream_array_output @ Input the [[i_prc]] index which selects the process for the current event. This is separated from reading the event, because it determines which event record to read. [[iostat]] may indicate an error or an EOF condition, as usual. <>= procedure :: input_i_prc => event_stream_array_input_i_prc <>= subroutine event_stream_array_input_i_prc (es_array, i_prc, iostat) class(event_stream_array_t), intent(inout) :: es_array integer, intent(out) :: i_prc integer, intent(out) :: iostat integer :: n if (es_array%has_input ()) then n = es_array%i_in call es_array%entry(n)%eio%input_i_prc (i_prc, iostat) else call msg_fatal ("Reading events: no input stream selected") end if end subroutine event_stream_array_input_i_prc @ %def event_stream_array_input_i_prc @ Input an event from the selected input stream. [[iostat]] may indicate an error or an EOF condition, as usual. <>= procedure :: input_event => event_stream_array_input_event <>= subroutine event_stream_array_input_event & (es_array, event, iostat, event_handle) class(event_stream_array_t), intent(inout) :: es_array type(event_t), intent(inout), target :: event integer, intent(out) :: iostat class(event_handle_t), intent(inout), optional :: event_handle integer :: n if (es_array%has_input ()) then n = es_array%i_in call es_array%entry(n)%eio%input_event (event, iostat, event_handle) else call msg_fatal ("Reading events: no input stream selected") end if end subroutine event_stream_array_input_event @ %def event_stream_array_input_event @ Skip an entry of eio\_t. Used to synchronize the event read-in for NLO events. <>= procedure :: skip_eio_entry => event_stream_array_skip_eio_entry <>= subroutine event_stream_array_skip_eio_entry (es_array, iostat) class(event_stream_array_t), intent(inout) :: es_array integer, intent(out) :: iostat integer :: n if (es_array%has_input ()) then n = es_array%i_in call es_array%entry(n)%eio%skip (iostat) else call msg_fatal ("Reading events: no input stream selected") end if end subroutine event_stream_array_skip_eio_entry @ %def event_stream_array_skip_eio_entry @ Return true if there is an input channel among the event streams. <>= procedure :: has_input => event_stream_array_has_input <>= function event_stream_array_has_input (es_array) result (flag) class(event_stream_array_t), intent(in) :: es_array logical :: flag flag = es_array%i_in /= 0 end function event_stream_array_has_input @ %def event_stream_array_has_input @ \subsection{Unit Tests} Test module, followed by the stand-alone unit-test procedures. <<[[event_streams_ut.f90]]>>= <> module event_streams_ut use unit_tests use event_streams_uti <> <> contains <> end module event_streams_ut @ <<[[event_streams_uti.f90]]>>= <> module event_streams_uti <> <> use model_data use eio_data use process, only: process_t use instances, only: process_instance_t use models use rt_data use events use event_streams <> <> contains <> end module event_streams_uti @ %def event_streams_uti @ API: driver for the unit tests below. <>= public :: event_streams_test <>= subroutine event_streams_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine event_streams_test @ %def event_streams_test @ \subsubsection{Empty event stream} This should set up an empty event output stream array, including initialization, output, and finalization (which are all no-ops). <>= call test (event_streams_1, "event_streams_1", & "empty event stream array", & u, results) <>= public :: event_streams_1 <>= subroutine event_streams_1 (u) integer, intent(in) :: u type(event_stream_array_t) :: es_array type(rt_data_t) :: global type(event_t) :: event type(string_t) :: sample type(string_t), dimension(0) :: empty_string_array write (u, "(A)") "* Test output: event_streams_1" write (u, "(A)") "* Purpose: handle empty event stream array" write (u, "(A)") sample = "event_streams_1" call es_array%init (sample, empty_string_array, global) call es_array%output (event, 42, 1) call es_array%write (u) call es_array%final () write (u, "(A)") write (u, "(A)") "* Test output end: event_streams_1" end subroutine event_streams_1 @ %def event_streams_1 @ \subsubsection{Nontrivial event stream} Here we generate a trivial event and choose [[raw]] output as an entry in the stream array. <>= call test (event_streams_2, "event_streams_2", & "nontrivial event stream array", & u, results) <>= public :: event_streams_2 <>= subroutine event_streams_2 (u) use processes_ut, only: prepare_test_process integer, intent(in) :: u type(event_stream_array_t) :: es_array type(rt_data_t) :: global type(model_data_t), target :: model type(event_t), allocatable, target :: event type(process_t), allocatable, target :: process type(process_instance_t), allocatable, target :: process_instance type(string_t) :: sample type(string_t), dimension(0) :: empty_string_array integer :: i_prc, iostat write (u, "(A)") "* Test output: event_streams_2" write (u, "(A)") "* Purpose: handle empty event stream array" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%init_fallback_model & (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl")) call model%init_test () write (u, "(A)") "* Generate test process event" write (u, "(A)") allocate (process) allocate (process_instance) call prepare_test_process (process, process_instance, model, & run_id = var_str ("run_test")) call process_instance%setup_event_data () allocate (event) call event%basic_init () call event%connect (process_instance, process%get_model_ptr ()) call event%generate (1, [0.4_default, 0.4_default]) call event%set_index (42) call event%evaluate_expressions () call event%write (u) write (u, "(A)") write (u, "(A)") "* Allocate raw eio stream and write event to file" write (u, "(A)") sample = "event_streams_2" call es_array%init (sample, [var_str ("raw")], global) call es_array%output (event, 1, 1) call es_array%write (u) call es_array%final () write (u, "(A)") write (u, "(A)") "* Reallocate raw eio stream for reading" write (u, "(A)") sample = "foo" call es_array%init (sample, empty_string_array, global, & input = var_str ("raw"), input_sample = var_str ("event_streams_2")) call es_array%write (u) write (u, "(A)") write (u, "(A)") "* Reread event" write (u, "(A)") call es_array%input_i_prc (i_prc, iostat) write (u, "(1x,A,I0)") "i_prc = ", i_prc write (u, "(A)") call es_array%input_event (event, iostat) call es_array%final () call event%write (u) call global%final () call model%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: event_streams_2" end subroutine event_streams_2 @ %def event_streams_2 @ \subsubsection{Switch in/out} Here we generate an event file and test switching from writing to reading when the file is exhausted. <>= call test (event_streams_3, "event_streams_3", & "switch input/output", & u, results) <>= public :: event_streams_3 <>= subroutine event_streams_3 (u) use processes_ut, only: prepare_test_process integer, intent(in) :: u type(event_stream_array_t) :: es_array type(rt_data_t) :: global type(model_data_t), target :: model type(event_t), allocatable, target :: event type(process_t), allocatable, target :: process type(process_instance_t), allocatable, target :: process_instance type(string_t) :: sample type(string_t), dimension(0) :: empty_string_array integer :: i_prc, iostat write (u, "(A)") "* Test output: event_streams_3" write (u, "(A)") "* Purpose: handle in/out switching" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%init_fallback_model & (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl")) call model%init_test () write (u, "(A)") "* Generate test process event" write (u, "(A)") allocate (process) allocate (process_instance) call prepare_test_process (process, process_instance, model, & run_id = var_str ("run_test")) call process_instance%setup_event_data () allocate (event) call event%basic_init () call event%connect (process_instance, process%get_model_ptr ()) call event%generate (1, [0.4_default, 0.4_default]) call event%increment_index () call event%evaluate_expressions () write (u, "(A)") "* Allocate raw eio stream and write event to file" write (u, "(A)") sample = "event_streams_3" call es_array%init (sample, [var_str ("raw")], global) call es_array%output (event, 1, 1) call es_array%write (u) call es_array%final () write (u, "(A)") write (u, "(A)") "* Reallocate raw eio stream for reading" write (u, "(A)") call es_array%init (sample, empty_string_array, global, & input = var_str ("raw")) call es_array%write (u) write (u, "(A)") write (u, "(A)") "* Reread event" write (u, "(A)") call es_array%input_i_prc (i_prc, iostat) call es_array%input_event (event, iostat) write (u, "(A)") "* Attempt to read another event (fail), then generate" write (u, "(A)") call es_array%input_i_prc (i_prc, iostat) if (iostat < 0) then call es_array%switch_inout () call event%generate (1, [0.3_default, 0.3_default]) call event%increment_index () call event%evaluate_expressions () call es_array%output (event, 1, 2) end if call es_array%write (u) call es_array%final () write (u, "(A)") call event%write (u) write (u, "(A)") write (u, "(A)") "* Reallocate raw eio stream for reading" write (u, "(A)") call es_array%init (sample, empty_string_array, global, & input = var_str ("raw")) call es_array%write (u) write (u, "(A)") write (u, "(A)") "* Reread two events and display 2nd event" write (u, "(A)") call es_array%input_i_prc (i_prc, iostat) call es_array%input_event (event, iostat) call es_array%input_i_prc (i_prc, iostat) call es_array%input_event (event, iostat) call es_array%final () call event%write (u) call global%final () call model%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: event_streams_3" end subroutine event_streams_3 @ %def event_streams_3 @ \subsubsection{Checksum} Here we generate an event file and repeat twice, once with identical parameters and once with modified parameters. <>= call test (event_streams_4, "event_streams_4", & "check MD5 sum", & u, results) <>= public :: event_streams_4 <>= subroutine event_streams_4 (u) integer, intent(in) :: u type(event_stream_array_t) :: es_array type(rt_data_t) :: global type(process_t), allocatable, target :: process type(string_t) :: sample type(string_t), dimension(0) :: empty_string_array type(event_sample_data_t) :: data write (u, "(A)") "* Test output: event_streams_4" write (u, "(A)") "* Purpose: handle in/out switching" write (u, "(A)") write (u, "(A)") "* Generate test process event" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%init_fallback_model & (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl")) call global%set_log (var_str ("?check_event_file"), & .true., is_known = .true.) allocate (process) write (u, "(A)") "* Allocate raw eio stream for writing" write (u, "(A)") sample = "event_streams_4" data%md5sum_cfg = "1234567890abcdef1234567890abcdef" call es_array%init (sample, [var_str ("raw")], global, data) call es_array%write (u) call es_array%final () write (u, "(A)") write (u, "(A)") "* Reallocate raw eio stream for reading" write (u, "(A)") call es_array%init (sample, empty_string_array, global, & data, input = var_str ("raw")) call es_array%write (u) call es_array%final () write (u, "(A)") write (u, "(A)") "* Reallocate modified raw eio stream for reading (fail)" write (u, "(A)") data%md5sum_cfg = "1234567890______1234567890______" call es_array%init (sample, empty_string_array, global, & data, input = var_str ("raw")) call es_array%write (u) call es_array%final () write (u, "(A)") write (u, "(A)") "* Repeat ignoring checksum" write (u, "(A)") call global%set_log (var_str ("?check_event_file"), & .false., is_known = .true.) call es_array%init (sample, empty_string_array, global, & data, input = var_str ("raw")) call es_array%write (u) call es_array%final () call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: event_streams_4" end subroutine event_streams_4 @ %def event_streams_4 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Restricted Subprocesses} This module provides an automatic means to construct restricted subprocesses of a current process object. A restricted subprocess has the same initial and final state as the current process, but a restricted set of Feynman graphs. The actual application extracts the set of resonance histories that apply to the process and uses this to construct subprocesses that are restricted to one of those histories, respectively. The resonance histories are derived from the phase-space setup. This implies that the method is tied to the OMega matrix element generator and to the wood phase space method. The processes are collected in a new process library that is generated on-the-fly. The [[resonant_subprocess_t]] object is intended as a component of the event record, which manages all operations regarding resonance handling. The run-time calculations are delegated to an event transform ([[evt_resonance_t]]), as a part of the event transform chain. The transform selects one (or none) of the resonance histories, given the momentum configuration, computes matrix elements and inserts resonances into the particle set. <<[[restricted_subprocesses.f90]]>>= <> module restricted_subprocesses <> <> use diagnostics, only: msg_message, msg_fatal, msg_bug use diagnostics, only: signal_is_pending use io_units, only: given_output_unit use format_defs, only: FMT_14, FMT_19 use string_utils, only: str use lorentz, only: vector4_t use particle_specifiers, only: prt_spec_t use particles, only: particle_set_t use resonances, only: resonance_history_t, resonance_history_set_t use variables, only: var_list_t use models, only: model_t use process_libraries, only: process_component_def_t use process_libraries, only: process_library_t use process_libraries, only: STAT_ACTIVE use prclib_stacks, only: prclib_entry_t use event_transforms, only: evt_t use resonance_insertion, only: evt_resonance_t use rt_data, only: rt_data_t use compilations, only: compile_library use process_configurations, only: process_configuration_t use process, only: process_t, process_ptr_t use instances, only: process_instance_t, process_instance_ptr_t use integrations, only: integrate_process <> <> <> <> <> contains <> end module restricted_subprocesses @ %def restricted_subprocesses @ \subsection{Process configuration} We extend the [[process_configuration_t]] by another method for initialization that takes into account a resonance history. <>= public :: restricted_process_configuration_t <>= type, extends (process_configuration_t) :: restricted_process_configuration_t private contains <> end type restricted_process_configuration_t @ %def restricted_process_configuration_t @ Resonance history as an argument. We use it to override the [[restrictions]] setting in a local variable list. Since we can construct the restricted process only by using OMega, we enforce it as the ME method. Other settings are taken from the variable list. The model will most likely be set, but we insert a safeguard just in case. Also, the resonant subprocess should not itself spawn resonant subprocesses, so we unset [[?resonance_history]]. We have to create a local copy of the model here, via pointer allocation. The reason is that the model as stored (via pointer) in the base type will be finalized and deallocated. The current implementation will generate a LO process, the optional [[nlo_process]] is unset. (It is not obvious whether the construction makes sense beyond LO.) <>= procedure :: init_resonant_process <>= subroutine init_resonant_process & (prc_config, prc_name, prt_in, prt_out, res_history, model, var_list) class(restricted_process_configuration_t), intent(out) :: prc_config type(string_t), intent(in) :: prc_name type(prt_spec_t), dimension(:), intent(in) :: prt_in type(prt_spec_t), dimension(:), intent(in) :: prt_out type(resonance_history_t), intent(in) :: res_history type(model_t), intent(in), target :: model type(var_list_t), intent(in), target :: var_list type(model_t), pointer :: local_model type(var_list_t) :: local_var_list allocate (local_model) call local_model%init_instance (model) call local_var_list%link (var_list) call local_var_list%append_string (var_str ("$model_name"), & sval = local_model%get_name (), & intrinsic=.true.) call local_var_list%append_string (var_str ("$method"), & sval = var_str ("omega"), & intrinsic=.true.) call local_var_list%append_string (var_str ("$restrictions"), & sval = res_history%as_omega_string (size (prt_in)), & intrinsic = .true.) call local_var_list%append_log (var_str ("?resonance_history"), & lval = .false., & intrinsic = .true.) call prc_config%init (prc_name, size (prt_in), 1, & local_model, local_var_list) call prc_config%setup_component (1, & prt_in, prt_out, & local_model, local_var_list) end subroutine init_resonant_process @ %def init_resonant_process @ \subsection{Resonant-subprocess set manager} This data type enables generation of a library of resonant subprocesses for a given master process, and it allows for convenient access. The matrix elements from the subprocesses can be used as channel weights to activate a selector, which then returns a preferred channel via some random number generator. <>= public :: resonant_subprocess_set_t <>= type :: resonant_subprocess_set_t private integer, dimension(:), allocatable :: n_history type(resonance_history_set_t), dimension(:), allocatable :: res_history_set logical :: lib_active = .false. type(string_t) :: libname type(string_t), dimension(:), allocatable :: proc_id type(process_ptr_t), dimension(:), allocatable :: subprocess type(process_instance_ptr_t), dimension(:), allocatable :: instance logical :: filled = .false. type(evt_resonance_t), pointer :: evt => null () contains <> end type resonant_subprocess_set_t @ %def resonant_subprocess_set_t @ Output <>= procedure :: write => resonant_subprocess_set_write <>= subroutine resonant_subprocess_set_write (prc_set, unit, testflag) class(resonant_subprocess_set_t), intent(in) :: prc_set integer, intent(in), optional :: unit logical, intent(in), optional :: testflag logical :: truncate integer :: u, i u = given_output_unit (unit) truncate = .false.; if (present (testflag)) truncate = testflag write (u, "(1x,A)") "Resonant subprocess set:" if (allocated (prc_set%n_history)) then if (any (prc_set%n_history > 0)) then do i = 1, size (prc_set%n_history) if (prc_set%n_history(i) > 0) then write (u, "(1x,A,I0)") "Component #", i call prc_set%res_history_set(i)%write (u, indent=1) end if end do if (prc_set%lib_active) then write (u, "(3x,A,A,A)") "Process library = '", & char (prc_set%libname), "'" else write (u, "(3x,A)") "Process library: [inactive]" end if if (associated (prc_set%evt)) then if (truncate) then write (u, "(3x,A,1x," // FMT_14 // ")") & "Process sqme =", prc_set%get_master_sqme () else write (u, "(3x,A,1x," // FMT_19 // ")") & "Process sqme =", prc_set%get_master_sqme () end if end if if (associated (prc_set%evt)) then write (u, "(3x,A)") "Event transform: associated" write (u, "(2x)", advance="no") call prc_set%evt%write_selector (u, testflag) else write (u, "(3x,A)") "Event transform: not associated" end if else write (u, "(2x,A)") "[empty]" end if else write (u, "(3x,A)") "[not allocated]" end if end subroutine resonant_subprocess_set_write @ %def resonant_subprocess_set_write @ \subsection{Resonance history set} Initialize subprocess set with an array of pre-created resonance history sets. Safeguard: if there are no resonances in the input, initialize the local set as empty, but complete. <>= procedure :: init => resonant_subprocess_set_init procedure :: fill_resonances => resonant_subprocess_set_fill_resonances <>= subroutine resonant_subprocess_set_init (prc_set, n_component) class(resonant_subprocess_set_t), intent(out) :: prc_set integer, intent(in) :: n_component allocate (prc_set%res_history_set (n_component)) allocate (prc_set%n_history (n_component), source = 0) end subroutine resonant_subprocess_set_init subroutine resonant_subprocess_set_fill_resonances (prc_set, & res_history_set, i_component) class(resonant_subprocess_set_t), intent(inout) :: prc_set type(resonance_history_set_t), intent(in) :: res_history_set integer, intent(in) :: i_component prc_set%n_history(i_component) = res_history_set%get_n_history () if (prc_set%n_history(i_component) > 0) then prc_set%res_history_set(i_component) = res_history_set else call prc_set%res_history_set(i_component)%init (initial_size = 0) call prc_set%res_history_set(i_component)%freeze () end if end subroutine resonant_subprocess_set_fill_resonances @ %def resonant_subprocess_set_init @ %def resonant_subprocess_set_fill_resonances @ Return the resonance history set. <>= procedure :: get_resonance_history_set & => resonant_subprocess_set_get_resonance_history_set <>= function resonant_subprocess_set_get_resonance_history_set (prc_set) & result (res_history_set) class(resonant_subprocess_set_t), intent(in) :: prc_set type(resonance_history_set_t), dimension(:), allocatable :: res_history_set res_history_set = prc_set%res_history_set end function resonant_subprocess_set_get_resonance_history_set @ %def resonant_subprocess_set_get_resonance_history_set @ \subsection{Library for the resonance history set} The recommended library name: append [[_R]] to the process name. <>= public :: get_libname_res <>= elemental function get_libname_res (proc_id) result (libname) type(string_t), intent(in) :: proc_id type(string_t) :: libname libname = proc_id // "_R" end function get_libname_res @ %def get_libname_res @ Here we scan the global process library whether any processes require resonant subprocesses to be constructed. If yes, create process objects with phase space and construct the process libraries as usual. Then append the library names to the array. The temporary integration objects should carry the [[phs_only]] flag. We set this in the local environment. Once a process object with resonance histories (derived from phase space) has been created, we extract the resonance histories and use them, together with the process definition, to create the new library. Finally, compile the library. <>= public :: spawn_resonant_subprocess_libraries <>= subroutine spawn_resonant_subprocess_libraries & (libname, local, global, libname_res) type(string_t), intent(in) :: libname type(rt_data_t), intent(inout), target :: local type(rt_data_t), intent(inout), target :: global type(string_t), dimension(:), allocatable, intent(inout) :: libname_res type(process_library_t), pointer :: lib type(string_t), dimension(:), allocatable :: process_id_res type(process_t), pointer :: process type(resonance_history_set_t) :: res_history_set type(process_component_def_t), pointer :: process_component_def logical :: phs_only_saved, exist integer :: i_proc, i_component lib => global%prclib_stack%get_library_ptr (libname) call lib%get_process_id_req_resonant (process_id_res) if (size (process_id_res) > 0) then call msg_message ("Creating resonant-subprocess libraries & &for library '" // char (libname) // "'") libname_res = get_libname_res (process_id_res) phs_only_saved = local%var_list%get_lval (var_str ("?phs_only")) call local%var_list%set_log & (var_str ("?phs_only"), .true., is_known=.true.) do i_proc = 1, size (process_id_res) associate (proc_id => process_id_res (i_proc)) call msg_message ("Process '" // char (proc_id) // "': & &constructing phase space for resonance structure") call integrate_process (proc_id, local, global) process => global%process_stack%get_process_ptr (proc_id) call create_library (libname_res(i_proc), global, exist) if (.not. exist) then do i_component = 1, process%get_n_components () call process%extract_resonance_history_set & (res_history_set, i_component = i_component) process_component_def & => process%get_component_def_ptr (i_component) call add_to_library (libname_res(i_proc), & res_history_set, & process_component_def%get_prt_spec_in (), & process_component_def%get_prt_spec_out (), & global) end do call msg_message ("Process library '" & // char (libname_res(i_proc)) & // "': created") end if call global%update_prclib (lib) end associate end do call local%var_list%set_log & (var_str ("?phs_only"), phs_only_saved, is_known=.true.) end if end subroutine spawn_resonant_subprocess_libraries @ %def spawn_resonant_subprocess_libraries @ This is another version of the library constructor, bound to a restricted-subprocess set object. Create the appropriate process library, add processes, and close the library. <>= procedure :: create_library => resonant_subprocess_set_create_library procedure :: add_to_library => resonant_subprocess_set_add_to_library procedure :: freeze_library => resonant_subprocess_set_freeze_library <>= subroutine resonant_subprocess_set_create_library (prc_set, & libname, global, exist) class(resonant_subprocess_set_t), intent(inout) :: prc_set type(string_t), intent(in) :: libname type(rt_data_t), intent(inout), target :: global logical, intent(out) :: exist prc_set%libname = libname call create_library (prc_set%libname, global, exist) end subroutine resonant_subprocess_set_create_library subroutine resonant_subprocess_set_add_to_library (prc_set, & i_component, prt_in, prt_out, global) class(resonant_subprocess_set_t), intent(inout) :: prc_set integer, intent(in) :: i_component type(prt_spec_t), dimension(:), intent(in) :: prt_in type(prt_spec_t), dimension(:), intent(in) :: prt_out type(rt_data_t), intent(inout), target :: global call add_to_library (prc_set%libname, & prc_set%res_history_set(i_component), & prt_in, prt_out, global) end subroutine resonant_subprocess_set_add_to_library subroutine resonant_subprocess_set_freeze_library (prc_set, global) class(resonant_subprocess_set_t), intent(inout) :: prc_set type(rt_data_t), intent(inout), target :: global type(prclib_entry_t), pointer :: lib_entry type(process_library_t), pointer :: lib lib => global%prclib_stack%get_library_ptr (prc_set%libname) call lib%get_process_id_list (prc_set%proc_id) prc_set%lib_active = .true. end subroutine resonant_subprocess_set_freeze_library @ %def resonant_subprocess_set_create_library @ %def resonant_subprocess_set_add_to_library @ %def resonant_subprocess_set_freeze_library @ The common parts of the procedures above: (i) create a new process library or recover it, (ii) for each history, create a process configuration and record it. <>= subroutine create_library (libname, global, exist) type(string_t), intent(in) :: libname type(rt_data_t), intent(inout), target :: global logical, intent(out) :: exist type(prclib_entry_t), pointer :: lib_entry type(process_library_t), pointer :: lib type(resonance_history_t) :: res_history type(string_t), dimension(:), allocatable :: proc_id type(restricted_process_configuration_t) :: prc_config integer :: i lib => global%prclib_stack%get_library_ptr (libname) exist = associated (lib) if (.not. exist) then call msg_message ("Creating library for resonant subprocesses '" & // char (libname) // "'") allocate (lib_entry) call lib_entry%init (libname) lib => lib_entry%process_library_t call global%add_prclib (lib_entry) else call msg_message ("Using library for resonant subprocesses '" & // char (libname) // "'") call global%update_prclib (lib) end if end subroutine create_library subroutine add_to_library (libname, res_history_set, prt_in, prt_out, global) type(string_t), intent(in) :: libname type(resonance_history_set_t), intent(in) :: res_history_set type(prt_spec_t), dimension(:), intent(in) :: prt_in type(prt_spec_t), dimension(:), intent(in) :: prt_out type(rt_data_t), intent(inout), target :: global type(prclib_entry_t), pointer :: lib_entry type(process_library_t), pointer :: lib type(resonance_history_t) :: res_history type(string_t), dimension(:), allocatable :: proc_id type(restricted_process_configuration_t) :: prc_config integer :: n0, i lib => global%prclib_stack%get_library_ptr (libname) if (associated (lib)) then n0 = lib%get_n_processes () allocate (proc_id (res_history_set%get_n_history ())) do i = 1, size (proc_id) proc_id(i) = libname // str (n0 + i) res_history = res_history_set%get_history(i) call prc_config%init_resonant_process (proc_id(i), & prt_in, prt_out, & res_history, & global%model, global%var_list) call msg_message ("Resonant subprocess #" & // char (str(n0+i)) // ": " & // char (res_history%as_omega_string (size (prt_in)))) call prc_config%record (global) if (signal_is_pending ()) return end do else call msg_bug ("Adding subprocesses: library '" & // char (libname) // "' not found") end if end subroutine add_to_library @ %def create_library @ %def add_to_library @ Compile the generated library, required settings taken from the [[global]] data set. <>= procedure :: compile_library => resonant_subprocess_set_compile_library <>= subroutine resonant_subprocess_set_compile_library (prc_set, global) class(resonant_subprocess_set_t), intent(in) :: prc_set type(rt_data_t), intent(inout), target :: global type(process_library_t), pointer :: lib lib => global%prclib_stack%get_library_ptr (prc_set%libname) if (lib%get_status () < STAT_ACTIVE) then call compile_library (prc_set%libname, global) end if end subroutine resonant_subprocess_set_compile_library @ %def resonant_subprocess_set_compile_library @ Check if the library has been created / the process has been evaluated. <>= procedure :: is_active => resonant_subprocess_set_is_active <>= function resonant_subprocess_set_is_active (prc_set) result (flag) class(resonant_subprocess_set_t), intent(in) :: prc_set logical :: flag flag = prc_set%lib_active end function resonant_subprocess_set_is_active @ %def resonant_subprocess_set_is_active @ Return number of generated process objects, library, and process IDs. <>= procedure :: get_n_process => resonant_subprocess_set_get_n_process procedure :: get_libname => resonant_subprocess_set_get_libname procedure :: get_proc_id => resonant_subprocess_set_get_proc_id <>= function resonant_subprocess_set_get_n_process (prc_set) result (n) class(resonant_subprocess_set_t), intent(in) :: prc_set integer :: n if (prc_set%lib_active) then n = size (prc_set%proc_id) else n = 0 end if end function resonant_subprocess_set_get_n_process function resonant_subprocess_set_get_libname (prc_set) result (libname) class(resonant_subprocess_set_t), intent(in) :: prc_set type(string_t) :: libname if (prc_set%lib_active) then libname = prc_set%libname else libname = "" end if end function resonant_subprocess_set_get_libname function resonant_subprocess_set_get_proc_id (prc_set, i) result (proc_id) class(resonant_subprocess_set_t), intent(in) :: prc_set integer, intent(in) :: i type(string_t) :: proc_id if (allocated (prc_set%proc_id)) then proc_id = prc_set%proc_id(i) else proc_id = "" end if end function resonant_subprocess_set_get_proc_id @ %def resonant_subprocess_set_get_n_process @ %def resonant_subprocess_set_get_libname @ %def resonant_subprocess_set_get_proc_id @ \subsection{Process objects and instances} Prepare process objects for all entries in the resonant-subprocesses library. The process objects are appended to the global process stack. A local environment can be used where we place temporary variable settings that affect process-object generation. We initialize the processes, such that we can evaluate matrix elements, but we do not need to integrate them. The internal procedure [[prepare_process]] is an abridged version of the procedure with this name in the [[simulations]] module. <>= procedure :: prepare_process_objects & => resonant_subprocess_set_prepare_process_objects <>= subroutine resonant_subprocess_set_prepare_process_objects & (prc_set, local, global) class(resonant_subprocess_set_t), intent(inout) :: prc_set type(rt_data_t), intent(inout), target :: local type(rt_data_t), intent(inout), optional, target :: global type(rt_data_t), pointer :: current type(process_library_t), pointer :: lib type(string_t) :: phs_method_saved, integration_method_saved type(string_t) :: proc_id, libname_cur, libname_res integer :: i, n if (.not. prc_set%is_active ()) return if (present (global)) then current => global else current => local end if libname_cur = current%prclib%get_name () libname_res = prc_set%get_libname () lib => current%prclib_stack%get_library_ptr (libname_res) if (associated (lib)) call current%update_prclib (lib) phs_method_saved = local%get_sval (var_str ("$phs_method")) integration_method_saved = local%get_sval (var_str ("$integration_method")) call local%set_string (var_str ("$phs_method"), & var_str ("none"), is_known = .true.) call local%set_string (var_str ("$integration_method"), & var_str ("none"), is_known = .true.) n = prc_set%get_n_process () allocate (prc_set%subprocess (n)) do i = 1, n proc_id = prc_set%get_proc_id (i) call prepare_process (prc_set%subprocess(i)%p, proc_id) if (signal_is_pending ()) return end do call local%set_string (var_str ("$phs_method"), & phs_method_saved, is_known = .true.) call local%set_string (var_str ("$integration_method"), & integration_method_saved, is_known = .true.) lib => current%prclib_stack%get_library_ptr (libname_cur) if (associated (lib)) call current%update_prclib (lib) contains subroutine prepare_process (process, process_id) type(process_t), pointer, intent(out) :: process type(string_t), intent(in) :: process_id call msg_message ("Simulate: initializing resonant subprocess '" & // char (process_id) // "'") if (present (global)) then call integrate_process (process_id, local, global, & init_only = .true.) else call integrate_process (process_id, local, local_stack = .true., & init_only = .true.) end if process => current%process_stack%get_process_ptr (process_id) if (.not. associated (process)) then call msg_fatal ("Simulate: resonant subprocess '" & // char (process_id) // "' could not be initialized: aborting") end if end subroutine prepare_process end subroutine resonant_subprocess_set_prepare_process_objects @ %def resonant_subprocess_set_prepare_process_objects @ Workspace for the resonant subprocesses. <>= procedure :: prepare_process_instances & => resonant_subprocess_set_prepare_process_instances <>= subroutine resonant_subprocess_set_prepare_process_instances (prc_set, global) class(resonant_subprocess_set_t), intent(inout) :: prc_set type(rt_data_t), intent(in), target :: global integer :: i, n if (.not. prc_set%is_active ()) return n = size (prc_set%subprocess) allocate (prc_set%instance (n)) do i = 1, n allocate (prc_set%instance(i)%p) call prc_set%instance(i)%p%init (prc_set%subprocess(i)%p) call prc_set%instance(i)%p%setup_event_data (global%model) end do end subroutine resonant_subprocess_set_prepare_process_instances @ %def resonant_subprocess_set_prepare_process_instances @ \subsection{Event transform connection} The idea is that the resonance-insertion event transform has been allocated somewhere (namely, in the standard event-transform chain), but we maintain a link such that we can inject matrix-element results event by event. The event transform holds a selector, to choose one of the resonance histories (or none), and it manages resonance insertion for the particle set. The data that the event transform requires can be provided here. The resonance history set has already been assigned with the [[dispatch]] initializer. Here, we supply the set of subprocess instances that we have generated (see above). The master-process instance is set when we [[connect]] the transform by the standard method. <>= procedure :: connect_transform => & resonant_subprocess_set_connect_transform <>= subroutine resonant_subprocess_set_connect_transform (prc_set, evt) class(resonant_subprocess_set_t), intent(inout) :: prc_set class(evt_t), intent(in), target :: evt select type (evt) type is (evt_resonance_t) prc_set%evt => evt call prc_set%evt%set_subprocess_instances (prc_set%instance) class default call msg_bug ("Resonant subprocess set: event transform has wrong type") end select end subroutine resonant_subprocess_set_connect_transform @ %def resonant_subprocess_set_connect_transform @ Set the on-shell limit value in the connected transform. <>= procedure :: set_on_shell_limit => resonant_subprocess_set_on_shell_limit <>= subroutine resonant_subprocess_set_on_shell_limit (prc_set, on_shell_limit) class(resonant_subprocess_set_t), intent(inout) :: prc_set real(default), intent(in) :: on_shell_limit call prc_set%evt%set_on_shell_limit (on_shell_limit) end subroutine resonant_subprocess_set_on_shell_limit @ %def resonant_subprocess_set_on_shell_limit @ Set the Gaussian turnoff parameter in the connected transform. <>= procedure :: set_on_shell_turnoff => resonant_subprocess_set_on_shell_turnoff <>= subroutine resonant_subprocess_set_on_shell_turnoff & (prc_set, on_shell_turnoff) class(resonant_subprocess_set_t), intent(inout) :: prc_set real(default), intent(in) :: on_shell_turnoff call prc_set%evt%set_on_shell_turnoff (on_shell_turnoff) end subroutine resonant_subprocess_set_on_shell_turnoff @ %def resonant_subprocess_set_on_shell_turnoff @ Reweight (suppress) the background contribution probability, for the kinematics where a resonance history is active. <>= procedure :: set_background_factor & => resonant_subprocess_set_background_factor <>= subroutine resonant_subprocess_set_background_factor & (prc_set, background_factor) class(resonant_subprocess_set_t), intent(inout) :: prc_set real(default), intent(in) :: background_factor call prc_set%evt%set_background_factor (background_factor) end subroutine resonant_subprocess_set_background_factor @ %def resonant_subprocess_set_background_factor @ \subsection{Wrappers for runtime calculations} All runtime calculations are delegated to the event transform. The following procedures are essentially redundant wrappers. We retain them for a unit test below. Debugging aid: <>= procedure :: dump_instances => resonant_subprocess_set_dump_instances <>= subroutine resonant_subprocess_set_dump_instances (prc_set, unit, testflag) class(resonant_subprocess_set_t), intent(inout) :: prc_set integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: i, n, u u = given_output_unit (unit) write (u, "(A)") "*** Process instances of resonant subprocesses" write (u, *) n = size (prc_set%subprocess) do i = 1, n associate (instance => prc_set%instance(i)%p) call instance%write (u, testflag) write (u, *) write (u, *) end associate end do end subroutine resonant_subprocess_set_dump_instances @ %def resonant_subprocess_set_dump_instances @ Inject the current kinematics configuration, reading from the previous event transform or from the process instance. <>= procedure :: fill_momenta => resonant_subprocess_set_fill_momenta <>= subroutine resonant_subprocess_set_fill_momenta (prc_set) class(resonant_subprocess_set_t), intent(inout) :: prc_set integer :: i, n call prc_set%evt%fill_momenta () end subroutine resonant_subprocess_set_fill_momenta @ %def resonant_subprocess_set_fill_momenta @ Determine the indices of the resonance histories that can be considered on-shell for the current kinematics. <>= procedure :: determine_on_shell_histories & => resonant_subprocess_set_determine_on_shell_histories <>= subroutine resonant_subprocess_set_determine_on_shell_histories & (prc_set, i_component, index_array) class(resonant_subprocess_set_t), intent(in) :: prc_set integer, intent(in) :: i_component integer, dimension(:), allocatable, intent(out) :: index_array call prc_set%evt%determine_on_shell_histories (index_array) end subroutine resonant_subprocess_set_determine_on_shell_histories @ %def resonant_subprocess_set_determine_on_shell_histories @ Evaluate selected subprocesses. (In actual operation, the ones that have been tagged as on-shell.) <>= procedure :: evaluate_subprocess & => resonant_subprocess_set_evaluate_subprocess <>= subroutine resonant_subprocess_set_evaluate_subprocess (prc_set, index_array) class(resonant_subprocess_set_t), intent(inout) :: prc_set integer, dimension(:), intent(in) :: index_array call prc_set%evt%evaluate_subprocess (index_array) end subroutine resonant_subprocess_set_evaluate_subprocess @ %def resonant_subprocess_set_evaluate_subprocess @ Extract the matrix elements of the master process / the resonant subprocesses. After the previous routine has been executed, they should be available and stored in the corresponding process instances. <>= procedure :: get_master_sqme & => resonant_subprocess_set_get_master_sqme procedure :: get_subprocess_sqme & => resonant_subprocess_set_get_subprocess_sqme <>= function resonant_subprocess_set_get_master_sqme (prc_set) result (sqme) class(resonant_subprocess_set_t), intent(in) :: prc_set real(default) :: sqme sqme = prc_set%evt%get_master_sqme () end function resonant_subprocess_set_get_master_sqme subroutine resonant_subprocess_set_get_subprocess_sqme (prc_set, sqme) class(resonant_subprocess_set_t), intent(in) :: prc_set real(default), dimension(:), intent(inout) :: sqme integer :: i call prc_set%evt%get_subprocess_sqme (sqme) end subroutine resonant_subprocess_set_get_subprocess_sqme @ %def resonant_subprocess_set_get_master_sqme @ %def resonant_subprocess_set_get_subprocess_sqme @ We use the calculations of resonant matrix elements to determine probabilities for all resonance configurations. <>= procedure :: compute_probabilities & => resonant_subprocess_set_compute_probabilities <>= subroutine resonant_subprocess_set_compute_probabilities (prc_set, prob_array) class(resonant_subprocess_set_t), intent(inout) :: prc_set real(default), dimension(:), allocatable, intent(out) :: prob_array integer, dimension(:), allocatable :: index_array real(default) :: sqme, sqme_sum, sqme_bg real(default), dimension(:), allocatable :: sqme_res integer :: n n = size (prc_set%subprocess) allocate (prob_array (0:n), source = 0._default) call prc_set%evt%compute_probabilities () call prc_set%evt%get_selector_weights (prob_array) end subroutine resonant_subprocess_set_compute_probabilities @ %def resonant_subprocess_set_compute_probabilities @ \subsection{Unit tests} Test module, followed by the stand-alone unit-test procedures. <<[[restricted_subprocesses_ut.f90]]>>= <> module restricted_subprocesses_ut use unit_tests use restricted_subprocesses_uti <> <> contains <> end module restricted_subprocesses_ut @ %def restricted_subprocesses_ut @ <<[[restricted_subprocesses_uti.f90]]>>= <> module restricted_subprocesses_uti <> <> use io_units, only: free_unit use format_defs, only: FMT_10, FMT_12 use lorentz, only: vector4_t, vector3_moving, vector4_moving use particle_specifiers, only: new_prt_spec use process_libraries, only: process_library_t use resonances, only: resonance_info_t use resonances, only: resonance_history_t use resonances, only: resonance_history_set_t use state_matrices, only: FM_IGNORE_HELICITY use particles, only: particle_set_t use model_data, only: model_data_t use models, only: syntax_model_file_init, syntax_model_file_final use models, only: model_t use rng_base_ut, only: rng_test_factory_t use mci_base, only: mci_t use phs_base, only: phs_config_t use phs_forests, only: syntax_phs_forest_init, syntax_phs_forest_final use phs_wood, only: phs_wood_config_t use process_libraries, only: process_def_entry_t use process_libraries, only: process_component_def_t use prclib_stacks, only: prclib_entry_t use prc_core_def, only: prc_core_def_t use prc_omega, only: omega_def_t use process, only: process_t use instances, only: process_instance_t use process_stacks, only: process_entry_t use event_transforms, only: evt_trivial_t use resonance_insertion, only: evt_resonance_t use integrations, only: integrate_process use rt_data, only: rt_data_t use restricted_subprocesses <> <> <> <> contains <> <> end module restricted_subprocesses_uti @ %def restricted_subprocesses_uti @ API: driver for the unit tests below. <>= public :: restricted_subprocesses_test <>= subroutine restricted_subprocesses_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine restricted_subprocesses_test @ %def restricted_subprocesses_test @ \subsubsection{subprocess configuration} Initialize a [[restricted_subprocess_configuration_t]] object which represents a given process with a defined resonance history. <>= call test (restricted_subprocesses_1, "restricted_subprocesses_1", & "single subprocess", & u, results) <>= public :: restricted_subprocesses_1 <>= subroutine restricted_subprocesses_1 (u) integer, intent(in) :: u type(rt_data_t) :: global type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(string_t) :: prc_name type(string_t), dimension(2) :: prt_in type(string_t), dimension(3) :: prt_out type(restricted_process_configuration_t) :: prc_config write (u, "(A)") "* Test output: restricted_subprocesses_1" write (u, "(A)") "* Purpose: create subprocess list from resonances" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%select_model (var_str ("SM")) write (u, "(A)") "* Create resonance history" write (u, "(A)") call res_info%init (3, -24, global%model, 5) call res_history%add_resonance (res_info) call res_history%write (u) write (u, "(A)") write (u, "(A)") "* Create process configuration" write (u, "(A)") prc_name = "restricted_subprocesses_1_p" prt_in(1) = "e-" prt_in(2) = "e+" prt_out(1) = "d" prt_out(2) = "u" prt_out(3) = "W+" call prc_config%init_resonant_process (prc_name, & new_prt_spec (prt_in), new_prt_spec (prt_out), & res_history, global%model, global%var_list) call prc_config%write (u) write (u, *) write (u, "(A)") "* Cleanup" call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: restricted_subprocesses_1" end subroutine restricted_subprocesses_1 @ %def restricted_subprocesses_1 @ \subsubsection{Subprocess library configuration} Create a process library that represents restricted subprocesses for a given set of resonance histories <>= call test (restricted_subprocesses_2, "restricted_subprocesses_2", & "subprocess library", & u, results) <>= public :: restricted_subprocesses_2 <>= subroutine restricted_subprocesses_2 (u) integer, intent(in) :: u type(rt_data_t), target :: global type(resonance_info_t) :: res_info type(resonance_history_t), dimension(2) :: res_history type(resonance_history_set_t) :: res_history_set type(string_t) :: libname type(string_t), dimension(2) :: prt_in type(string_t), dimension(3) :: prt_out type(resonant_subprocess_set_t) :: prc_set type(process_library_t), pointer :: lib logical :: exist write (u, "(A)") "* Test output: restricted_subprocesses_2" write (u, "(A)") "* Purpose: create subprocess library from resonances" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%select_model (var_str ("SM")) write (u, "(A)") "* Create resonance histories" write (u, "(A)") call res_info%init (3, -24, global%model, 5) call res_history(1)%add_resonance (res_info) call res_history(1)%write (u) call res_info%init (7, 23, global%model, 5) call res_history(2)%add_resonance (res_info) call res_history(2)%write (u) call res_history_set%init () call res_history_set%enter (res_history(1)) call res_history_set%enter (res_history(2)) call res_history_set%freeze () write (u, "(A)") write (u, "(A)") "* Empty restricted subprocess set" write (u, "(A)") write (u, "(A,1x,L1)") "active =", prc_set%is_active () write (u, "(A)") call prc_set%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "* Fill restricted subprocess set" write (u, "(A)") libname = "restricted_subprocesses_2_p_R" prt_in(1) = "e-" prt_in(2) = "e+" prt_out(1) = "d" prt_out(2) = "u" prt_out(3) = "W+" call prc_set%init (1) call prc_set%fill_resonances (res_history_set, 1) call prc_set%create_library (libname, global, exist) if (.not. exist) then call prc_set%add_to_library (1, & new_prt_spec (prt_in), new_prt_spec (prt_out), & global) end if call prc_set%freeze_library (global) write (u, "(A,1x,L1)") "active =", prc_set%is_active () write (u, "(A)") call prc_set%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "* Queries" write (u, "(A)") write (u, "(A,1x,I0)") "n_process =", prc_set%get_n_process () write (u, "(A)") write (u, "(A,A,A)") "libname = '", char (prc_set%get_libname ()), "'" write (u, "(A)") write (u, "(A,A,A)") "proc_id(1) = '", char (prc_set%get_proc_id (1)), "'" write (u, "(A,A,A)") "proc_id(2) = '", char (prc_set%get_proc_id (2)), "'" write (u, "(A)") write (u, "(A)") "* Process library" write (u, "(A)") call prc_set%compile_library (global) lib => global%prclib_stack%get_library_ptr (libname) if (associated (lib)) call lib%write (u, libpath=.false.) write (u, *) write (u, "(A)") "* Cleanup" call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: restricted_subprocesses_2" end subroutine restricted_subprocesses_2 @ %def restricted_subprocesses_2 @ \subsubsection{Auxiliary: Test processes} Auxiliary subroutine that constructs the process library for the above test. This parallels a similar subroutine in [[processes_uti]], but this time we want an \oMega\ process. <>= public :: prepare_resonance_test_library <>= subroutine prepare_resonance_test_library & (lib, libname, procname, model, global, u) type(process_library_t), target, intent(out) :: lib type(string_t), intent(in) :: libname type(string_t), intent(in) :: procname class(model_data_t), intent(in), pointer :: model type(rt_data_t), intent(in), target :: global integer, intent(in) :: u type(string_t), dimension(:), allocatable :: prt_in, prt_out class(prc_core_def_t), allocatable :: def type(process_def_entry_t), pointer :: entry call lib%init (libname) allocate (prt_in (2), prt_out (3)) prt_in = [var_str ("e+"), var_str ("e-")] prt_out = [var_str ("d"), var_str ("ubar"), var_str ("W+")] allocate (omega_def_t :: def) select type (def) type is (omega_def_t) call def%init (model%get_name (), prt_in, prt_out, & ovm=.false., ufo=.false.) end select allocate (entry) call entry%init (procname, & model_name = model%get_name (), & n_in = 2, n_components = 1, & requires_resonances = .true.) call entry%import_component (1, n_out = size (prt_out), & prt_in = new_prt_spec (prt_in), & prt_out = new_prt_spec (prt_out), & method = var_str ("omega"), & variant = def) call entry%write (u) call lib%append (entry) call lib%configure (global%os_data) call lib%write_makefile (global%os_data, force = .true., verbose = .false.) call lib%clean (global%os_data, distclean = .false.) call lib%write_driver (force = .true.) call lib%load (global%os_data) end subroutine prepare_resonance_test_library @ %def prepare_resonance_test_library @ \subsubsection{Kinematics and resonance selection} Prepare an actual process with resonant subprocesses. Insert kinematics and apply the resonance selector in an associated event transform. <>= call test (restricted_subprocesses_3, "restricted_subprocesses_3", & "resonance kinematics and probability", & u, results) <>= public :: restricted_subprocesses_3 <>= subroutine restricted_subprocesses_3 (u) integer, intent(in) :: u type(rt_data_t), target :: global class(model_t), pointer :: model class(model_data_t), pointer :: model_data type(string_t) :: libname, libname_res type(string_t) :: procname type(process_component_def_t), pointer :: process_component_def type(prclib_entry_t), pointer :: lib_entry type(process_library_t), pointer :: lib logical :: exist type(process_t), pointer :: process type(process_instance_t), target :: process_instance type(resonance_history_set_t), dimension(1) :: res_history_set type(resonant_subprocess_set_t) :: prc_set type(particle_set_t) :: pset real(default) :: sqrts, mw, pp real(default), dimension(3) :: p3 type(vector4_t), dimension(:), allocatable :: p real(default), dimension(:), allocatable :: m integer, dimension(:), allocatable :: pdg real(default), dimension(:), allocatable :: sqme logical, dimension(:), allocatable :: mask real(default) :: on_shell_limit integer, dimension(:), allocatable :: i_array real(default), dimension(:), allocatable :: prob_array type(evt_resonance_t), target :: evt_resonance integer :: i, u_dump write (u, "(A)") "* Test output: restricted_subprocesses_3" write (u, "(A)") "* Purpose: handle process and resonance kinematics" write (u, "(A)") call syntax_model_file_init () call syntax_phs_forest_init () call global%global_init () call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%set_log (var_str ("?resonance_history"), & .true., is_known = .true.) call global%select_model (var_str ("SM")) allocate (model) call model%init_instance (global%model) model_data => model libname = "restricted_subprocesses_3_lib" libname_res = "restricted_subprocesses_3_lib_res" procname = "restricted_subprocesses_3_p" write (u, "(A)") "* Initialize process library and process" write (u, "(A)") allocate (lib_entry) call lib_entry%init (libname) lib => lib_entry%process_library_t call global%add_prclib (lib_entry) call prepare_resonance_test_library & (lib, libname, procname, model_data, global, u) call integrate_process (procname, global, & local_stack = .true., init_only = .true.) process => global%process_stack%get_process_ptr (procname) call process_instance%init (process) call process_instance%setup_event_data () write (u, "(A)") write (u, "(A)") "* Extract resonance history set" write (u, "(A)") call process%extract_resonance_history_set & (res_history_set(1), include_trivial=.true., i_component=1) call res_history_set(1)%write (u) write (u, "(A)") write (u, "(A)") "* Build resonant-subprocess library" write (u, "(A)") call prc_set%init (1) call prc_set%fill_resonances (res_history_set(1), 1) process_component_def => process%get_component_def_ptr (1) call prc_set%create_library (libname_res, global, exist) if (.not. exist) then call prc_set%add_to_library (1, & process_component_def%get_prt_spec_in (), & process_component_def%get_prt_spec_out (), & global) end if call prc_set%freeze_library (global) call prc_set%compile_library (global) call prc_set%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "* Build particle set" write (u, "(A)") sqrts = global%get_rval (var_str ("sqrts")) mw = 80._default ! deliberately slightly different from true mw pp = sqrt (sqrts**2 - 4 * mw**2) / 2 allocate (pdg (5), p (5), m (5)) pdg(1) = -11 p(1) = vector4_moving (sqrts/2, sqrts/2, 3) m(1) = 0 pdg(2) = 11 p(2) = vector4_moving (sqrts/2,-sqrts/2, 3) m(2) = 0 pdg(3) = 1 p3(1) = pp/2 p3(2) = mw/2 p3(3) = 0 p(3) = vector4_moving (sqrts/4, vector3_moving (p3)) m(3) = 0 p3(2) = -mw/2 pdg(4) = -2 p(4) = vector4_moving (sqrts/4, vector3_moving (p3)) m(4) = 0 pdg(5) = 24 p(5) = vector4_moving (sqrts/2,-pp, 1) m(5) = mw call pset%init_direct (0, 2, 0, 0, 3, pdg, model) call pset%set_momentum (p, m**2) call pset%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "* Fill process instance" ! workflow from event_recalculate call process_instance%choose_mci (1) call process_instance%set_trace (pset, 1) call process_instance%recover & (1, 1, update_sqme=.true., recover_phs=.false.) call process_instance%evaluate_event_data (weight = 1._default) write (u, "(A)") write (u, "(A)") "* Prepare resonant subprocesses" call prc_set%prepare_process_objects (global) call prc_set%prepare_process_instances (global) call evt_resonance%set_resonance_data (res_history_set) call evt_resonance%select_component (1) call prc_set%connect_transform (evt_resonance) call evt_resonance%connect (process_instance, model) call prc_set%fill_momenta () write (u, "(A)") write (u, "(A)") "* Show squared matrix element of master process," write (u, "(A)") " should coincide with 2nd subprocess sqme" write (u, "(A)") write (u, "(1x,I0,1x," // FMT_12 // ")") 0, prc_set%get_master_sqme () write (u, "(A)") write (u, "(A)") "* Compute squared matrix elements & &of selected resonant subprocesses [1,2]" write (u, "(A)") call prc_set%evaluate_subprocess ([1,2]) allocate (sqme (3), source = 0._default) call prc_set%get_subprocess_sqme (sqme) do i = 1, size (sqme) write (u, "(1x,I0,1x," // FMT_12 // ")") i, sqme(i) end do deallocate (sqme) write (u, "(A)") write (u, "(A)") "* Compute squared matrix elements & &of all resonant subprocesses" write (u, "(A)") call prc_set%evaluate_subprocess ([1,2,3]) allocate (sqme (3), source = 0._default) call prc_set%get_subprocess_sqme (sqme) do i = 1, size (sqme) write (u, "(1x,I0,1x," // FMT_12 // ")") i, sqme(i) end do deallocate (sqme) write (u, "(A)") write (u, "(A)") "* Write process instances to file & &restricted_subprocesses_3_lib_res.dat" u_dump = free_unit () open (unit = u_dump, file = "restricted_subprocesses_3_lib_res.dat", & action = "write", status = "replace") call prc_set%dump_instances (u_dump) close (u_dump) write (u, "(A)") write (u, "(A)") "* Determine on-shell resonant subprocesses" write (u, "(A)") on_shell_limit = 0 write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", on_shell_limit call prc_set%set_on_shell_limit (on_shell_limit) call prc_set%determine_on_shell_histories (1, i_array) write (u, "(1x,A,9(1x,I0))") "resonant =", i_array on_shell_limit = 0.1_default write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", on_shell_limit call prc_set%set_on_shell_limit (on_shell_limit) call prc_set%determine_on_shell_histories (1, i_array) write (u, "(1x,A,9(1x,I0))") "resonant =", i_array on_shell_limit = 10._default write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", on_shell_limit call prc_set%set_on_shell_limit (on_shell_limit) call prc_set%determine_on_shell_histories (1, i_array) write (u, "(1x,A,9(1x,I0))") "resonant =", i_array on_shell_limit = 10000._default write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", on_shell_limit call prc_set%set_on_shell_limit (on_shell_limit) call prc_set%determine_on_shell_histories (1, i_array) write (u, "(1x,A,9(1x,I0))") "resonant =", i_array write (u, "(A)") write (u, "(A)") "* Compute probabilities for applicable resonances" write (u, "(A)") " and initialize the process selector" write (u, "(A)") " (The first number is the probability for background)" write (u, "(A)") on_shell_limit = 0 write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", on_shell_limit call prc_set%set_on_shell_limit (on_shell_limit) call prc_set%determine_on_shell_histories (1, i_array) call prc_set%compute_probabilities (prob_array) write (u, "(1x,A,9(1x,"// FMT_12 // "))") "resonant =", prob_array call prc_set%write (u, testflag=.true.) write (u, *) on_shell_limit = 10._default write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", on_shell_limit call prc_set%set_on_shell_limit (on_shell_limit) call prc_set%determine_on_shell_histories (1, i_array) call prc_set%compute_probabilities (prob_array) write (u, "(1x,A,9(1x,"// FMT_12 // "))") "resonant =", prob_array call prc_set%write (u, testflag=.true.) write (u, *) on_shell_limit = 10000._default write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", on_shell_limit call prc_set%set_on_shell_limit (on_shell_limit) call prc_set%determine_on_shell_histories (1, i_array) call prc_set%compute_probabilities (prob_array) write (u, "(1x,A,9(1x,"// FMT_12 // "))") "resonant =", prob_array write (u, *) call prc_set%write (u, testflag=.true.) write (u, *) write (u, "(A)") "* Cleanup" call global%final () call syntax_phs_forest_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: restricted_subprocesses_3" end subroutine restricted_subprocesses_3 @ %def restricted_subprocesses_3 @ \subsubsection{Event transform} Prepare an actual process with resonant subprocesses. Prepare the resonance selector for a fixed event and apply the resonance-insertion event transform. <>= call test (restricted_subprocesses_4, "restricted_subprocesses_4", & "event transform", & u, results) <>= public :: restricted_subprocesses_4 <>= subroutine restricted_subprocesses_4 (u) integer, intent(in) :: u type(rt_data_t), target :: global class(model_t), pointer :: model class(model_data_t), pointer :: model_data type(string_t) :: libname, libname_res type(string_t) :: procname type(process_component_def_t), pointer :: process_component_def type(prclib_entry_t), pointer :: lib_entry type(process_library_t), pointer :: lib logical :: exist type(process_t), pointer :: process type(process_instance_t), target :: process_instance type(resonance_history_set_t), dimension(1) :: res_history_set type(resonant_subprocess_set_t) :: prc_set type(particle_set_t) :: pset real(default) :: sqrts, mw, pp real(default), dimension(3) :: p3 type(vector4_t), dimension(:), allocatable :: p real(default), dimension(:), allocatable :: m integer, dimension(:), allocatable :: pdg real(default) :: on_shell_limit type(evt_trivial_t), target :: evt_trivial type(evt_resonance_t), target :: evt_resonance real(default) :: probability integer :: i write (u, "(A)") "* Test output: restricted_subprocesses_4" write (u, "(A)") "* Purpose: employ event transform" write (u, "(A)") call syntax_model_file_init () call syntax_phs_forest_init () call global%global_init () call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%set_log (var_str ("?resonance_history"), & .true., is_known = .true.) call global%select_model (var_str ("SM")) allocate (model) call model%init_instance (global%model) model_data => model libname = "restricted_subprocesses_4_lib" libname_res = "restricted_subprocesses_4_lib_res" procname = "restricted_subprocesses_4_p" write (u, "(A)") "* Initialize process library and process" write (u, "(A)") allocate (lib_entry) call lib_entry%init (libname) lib => lib_entry%process_library_t call global%add_prclib (lib_entry) call prepare_resonance_test_library & (lib, libname, procname, model_data, global, u) call integrate_process (procname, global, & local_stack = .true., init_only = .true.) process => global%process_stack%get_process_ptr (procname) call process_instance%init (process) call process_instance%setup_event_data () write (u, "(A)") write (u, "(A)") "* Extract resonance history set" call process%extract_resonance_history_set & (res_history_set(1), include_trivial=.false., i_component=1) write (u, "(A)") write (u, "(A)") "* Build resonant-subprocess library" call prc_set%init (1) call prc_set%fill_resonances (res_history_set(1), 1) process_component_def => process%get_component_def_ptr (1) call prc_set%create_library (libname_res, global, exist) if (.not. exist) then call prc_set%add_to_library (1, & process_component_def%get_prt_spec_in (), & process_component_def%get_prt_spec_out (), & global) end if call prc_set%freeze_library (global) call prc_set%compile_library (global) write (u, "(A)") write (u, "(A)") "* Build particle set" write (u, "(A)") sqrts = global%get_rval (var_str ("sqrts")) mw = 80._default ! deliberately slightly different from true mw pp = sqrt (sqrts**2 - 4 * mw**2) / 2 allocate (pdg (5), p (5), m (5)) pdg(1) = -11 p(1) = vector4_moving (sqrts/2, sqrts/2, 3) m(1) = 0 pdg(2) = 11 p(2) = vector4_moving (sqrts/2,-sqrts/2, 3) m(2) = 0 pdg(3) = 1 p3(1) = pp/2 p3(2) = mw/2 p3(3) = 0 p(3) = vector4_moving (sqrts/4, vector3_moving (p3)) m(3) = 0 p3(2) = -mw/2 pdg(4) = -2 p(4) = vector4_moving (sqrts/4, vector3_moving (p3)) m(4) = 0 pdg(5) = 24 p(5) = vector4_moving (sqrts/2,-pp, 1) m(5) = mw call pset%init_direct (0, 2, 0, 0, 3, pdg, model) call pset%set_momentum (p, m**2) write (u, "(A)") "* Fill process instance" write (u, "(A)") ! workflow from event_recalculate call process_instance%choose_mci (1) call process_instance%set_trace (pset, 1) call process_instance%recover & (1, 1, update_sqme=.true., recover_phs=.false.) call process_instance%evaluate_event_data (weight = 1._default) write (u, "(A)") "* Prepare resonant subprocesses" write (u, "(A)") call prc_set%prepare_process_objects (global) call prc_set%prepare_process_instances (global) write (u, "(A)") "* Fill trivial event transform (deliberately w/o color)" write (u, "(A)") call evt_trivial%connect (process_instance, model) call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) write (u, "(A)") write (u, "(A)") "* Initialize resonance-insertion event transform" write (u, "(A)") evt_trivial%next => evt_resonance evt_resonance%previous => evt_trivial call evt_resonance%set_resonance_data (res_history_set) call evt_resonance%select_component (1) call evt_resonance%connect (process_instance, model) call prc_set%connect_transform (evt_resonance) call evt_resonance%write (u) write (u, "(A)") write (u, "(A)") "* Compute probabilities for applicable resonances" write (u, "(A)") " and initialize the process selector" write (u, "(A)") on_shell_limit = 10._default write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", on_shell_limit call evt_resonance%set_on_shell_limit (on_shell_limit) write (u, "(A)") write (u, "(A)") "* Evaluate resonance-insertion event transform" write (u, "(A)") call evt_resonance%prepare_new_event (1, 1) call evt_resonance%generate_weighted (probability) call evt_resonance%make_particle_set (1, .false.) call evt_resonance%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () call syntax_phs_forest_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: restricted_subprocesses_4" end subroutine restricted_subprocesses_4 @ %def restricted_subprocesses_4 @ \subsubsection{Gaussian turnoff} Identical to the previous process, except that we apply a Gaussian turnoff to the resonance kinematics, which affects the subprocess selector. <>= call test (restricted_subprocesses_5, "restricted_subprocesses_5", & "event transform with gaussian turnoff", & u, results) <>= public :: restricted_subprocesses_5 <>= subroutine restricted_subprocesses_5 (u) integer, intent(in) :: u type(rt_data_t), target :: global class(model_t), pointer :: model class(model_data_t), pointer :: model_data type(string_t) :: libname, libname_res type(string_t) :: procname type(process_component_def_t), pointer :: process_component_def type(prclib_entry_t), pointer :: lib_entry type(process_library_t), pointer :: lib logical :: exist type(process_t), pointer :: process type(process_instance_t), target :: process_instance type(resonance_history_set_t), dimension(1) :: res_history_set type(resonant_subprocess_set_t) :: prc_set type(particle_set_t) :: pset real(default) :: sqrts, mw, pp real(default), dimension(3) :: p3 type(vector4_t), dimension(:), allocatable :: p real(default), dimension(:), allocatable :: m integer, dimension(:), allocatable :: pdg real(default) :: on_shell_limit real(default) :: on_shell_turnoff type(evt_trivial_t), target :: evt_trivial type(evt_resonance_t), target :: evt_resonance real(default) :: probability integer :: i write (u, "(A)") "* Test output: restricted_subprocesses_5" write (u, "(A)") "* Purpose: employ event transform & &with gaussian turnoff" write (u, "(A)") call syntax_model_file_init () call syntax_phs_forest_init () call global%global_init () call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%set_log (var_str ("?resonance_history"), & .true., is_known = .true.) call global%select_model (var_str ("SM")) allocate (model) call model%init_instance (global%model) model_data => model libname = "restricted_subprocesses_5_lib" libname_res = "restricted_subprocesses_5_lib_res" procname = "restricted_subprocesses_5_p" write (u, "(A)") "* Initialize process library and process" write (u, "(A)") allocate (lib_entry) call lib_entry%init (libname) lib => lib_entry%process_library_t call global%add_prclib (lib_entry) call prepare_resonance_test_library & (lib, libname, procname, model_data, global, u) call integrate_process (procname, global, & local_stack = .true., init_only = .true.) process => global%process_stack%get_process_ptr (procname) call process_instance%init (process) call process_instance%setup_event_data () write (u, "(A)") write (u, "(A)") "* Extract resonance history set" call process%extract_resonance_history_set & (res_history_set(1), include_trivial=.false., i_component=1) write (u, "(A)") write (u, "(A)") "* Build resonant-subprocess library" call prc_set%init (1) call prc_set%fill_resonances (res_history_set(1), 1) process_component_def => process%get_component_def_ptr (1) call prc_set%create_library (libname_res, global, exist) if (.not. exist) then call prc_set%add_to_library (1, & process_component_def%get_prt_spec_in (), & process_component_def%get_prt_spec_out (), & global) end if call prc_set%freeze_library (global) call prc_set%compile_library (global) write (u, "(A)") write (u, "(A)") "* Build particle set" write (u, "(A)") sqrts = global%get_rval (var_str ("sqrts")) mw = 80._default ! deliberately slightly different from true mw pp = sqrt (sqrts**2 - 4 * mw**2) / 2 allocate (pdg (5), p (5), m (5)) pdg(1) = -11 p(1) = vector4_moving (sqrts/2, sqrts/2, 3) m(1) = 0 pdg(2) = 11 p(2) = vector4_moving (sqrts/2,-sqrts/2, 3) m(2) = 0 pdg(3) = 1 p3(1) = pp/2 p3(2) = mw/2 p3(3) = 0 p(3) = vector4_moving (sqrts/4, vector3_moving (p3)) m(3) = 0 p3(2) = -mw/2 pdg(4) = -2 p(4) = vector4_moving (sqrts/4, vector3_moving (p3)) m(4) = 0 pdg(5) = 24 p(5) = vector4_moving (sqrts/2,-pp, 1) m(5) = mw call pset%init_direct (0, 2, 0, 0, 3, pdg, model) call pset%set_momentum (p, m**2) write (u, "(A)") "* Fill process instance" write (u, "(A)") ! workflow from event_recalculate call process_instance%choose_mci (1) call process_instance%set_trace (pset, 1) call process_instance%recover & (1, 1, update_sqme=.true., recover_phs=.false.) call process_instance%evaluate_event_data (weight = 1._default) write (u, "(A)") "* Prepare resonant subprocesses" write (u, "(A)") call prc_set%prepare_process_objects (global) call prc_set%prepare_process_instances (global) write (u, "(A)") "* Fill trivial event transform (deliberately w/o color)" write (u, "(A)") call evt_trivial%connect (process_instance, model) call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) write (u, "(A)") write (u, "(A)") "* Initialize resonance-insertion event transform" write (u, "(A)") evt_trivial%next => evt_resonance evt_resonance%previous => evt_trivial call evt_resonance%set_resonance_data (res_history_set) call evt_resonance%select_component (1) call evt_resonance%connect (process_instance, model) call prc_set%connect_transform (evt_resonance) call evt_resonance%write (u) write (u, "(A)") write (u, "(A)") "* Compute probabilities for applicable resonances" write (u, "(A)") " and initialize the process selector" write (u, "(A)") on_shell_limit = 10._default write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", & on_shell_limit call evt_resonance%set_on_shell_limit (on_shell_limit) on_shell_turnoff = 1._default write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_turnoff =", & on_shell_turnoff call evt_resonance%set_on_shell_turnoff (on_shell_turnoff) write (u, "(A)") write (u, "(A)") "* Evaluate resonance-insertion event transform" write (u, "(A)") call evt_resonance%prepare_new_event (1, 1) call evt_resonance%generate_weighted (probability) call evt_resonance%make_particle_set (1, .false.) call evt_resonance%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () call syntax_phs_forest_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: restricted_subprocesses_5" end subroutine restricted_subprocesses_5 @ %def restricted_subprocesses_5 @ \subsubsection{Event transform} The same process and event again. This time, switch off the background contribution, so the selector becomes trivial. <>= call test (restricted_subprocesses_6, "restricted_subprocesses_6", & "event transform with background switched off", & u, results) <>= public :: restricted_subprocesses_6 <>= subroutine restricted_subprocesses_6 (u) integer, intent(in) :: u type(rt_data_t), target :: global class(model_t), pointer :: model class(model_data_t), pointer :: model_data type(string_t) :: libname, libname_res type(string_t) :: procname type(process_component_def_t), pointer :: process_component_def type(prclib_entry_t), pointer :: lib_entry type(process_library_t), pointer :: lib logical :: exist type(process_t), pointer :: process type(process_instance_t), target :: process_instance type(resonance_history_set_t), dimension(1) :: res_history_set type(resonant_subprocess_set_t) :: prc_set type(particle_set_t) :: pset real(default) :: sqrts, mw, pp real(default), dimension(3) :: p3 type(vector4_t), dimension(:), allocatable :: p real(default), dimension(:), allocatable :: m integer, dimension(:), allocatable :: pdg real(default) :: on_shell_limit real(default) :: background_factor type(evt_trivial_t), target :: evt_trivial type(evt_resonance_t), target :: evt_resonance real(default) :: probability integer :: i write (u, "(A)") "* Test output: restricted_subprocesses_6" write (u, "(A)") "* Purpose: employ event transform & &with background switched off" write (u, "(A)") call syntax_model_file_init () call syntax_phs_forest_init () call global%global_init () call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%set_log (var_str ("?resonance_history"), & .true., is_known = .true.) call global%select_model (var_str ("SM")) allocate (model) call model%init_instance (global%model) model_data => model libname = "restricted_subprocesses_6_lib" libname_res = "restricted_subprocesses_6_lib_res" procname = "restricted_subprocesses_6_p" write (u, "(A)") "* Initialize process library and process" write (u, "(A)") allocate (lib_entry) call lib_entry%init (libname) lib => lib_entry%process_library_t call global%add_prclib (lib_entry) call prepare_resonance_test_library & (lib, libname, procname, model_data, global, u) call integrate_process (procname, global, & local_stack = .true., init_only = .true.) process => global%process_stack%get_process_ptr (procname) call process_instance%init (process) call process_instance%setup_event_data () write (u, "(A)") write (u, "(A)") "* Extract resonance history set" call process%extract_resonance_history_set & (res_history_set(1), include_trivial=.false., i_component=1) write (u, "(A)") write (u, "(A)") "* Build resonant-subprocess library" call prc_set%init (1) call prc_set%fill_resonances (res_history_set(1), 1) process_component_def => process%get_component_def_ptr (1) call prc_set%create_library (libname_res, global, exist) if (.not. exist) then call prc_set%add_to_library (1, & process_component_def%get_prt_spec_in (), & process_component_def%get_prt_spec_out (), & global) end if call prc_set%freeze_library (global) call prc_set%compile_library (global) write (u, "(A)") write (u, "(A)") "* Build particle set" write (u, "(A)") sqrts = global%get_rval (var_str ("sqrts")) mw = 80._default ! deliberately slightly different from true mw pp = sqrt (sqrts**2 - 4 * mw**2) / 2 allocate (pdg (5), p (5), m (5)) pdg(1) = -11 p(1) = vector4_moving (sqrts/2, sqrts/2, 3) m(1) = 0 pdg(2) = 11 p(2) = vector4_moving (sqrts/2,-sqrts/2, 3) m(2) = 0 pdg(3) = 1 p3(1) = pp/2 p3(2) = mw/2 p3(3) = 0 p(3) = vector4_moving (sqrts/4, vector3_moving (p3)) m(3) = 0 p3(2) = -mw/2 pdg(4) = -2 p(4) = vector4_moving (sqrts/4, vector3_moving (p3)) m(4) = 0 pdg(5) = 24 p(5) = vector4_moving (sqrts/2,-pp, 1) m(5) = mw call pset%init_direct (0, 2, 0, 0, 3, pdg, model) call pset%set_momentum (p, m**2) write (u, "(A)") "* Fill process instance" write (u, "(A)") ! workflow from event_recalculate call process_instance%choose_mci (1) call process_instance%set_trace (pset, 1) call process_instance%recover & (1, 1, update_sqme=.true., recover_phs=.false.) call process_instance%evaluate_event_data (weight = 1._default) write (u, "(A)") "* Prepare resonant subprocesses" write (u, "(A)") call prc_set%prepare_process_objects (global) call prc_set%prepare_process_instances (global) write (u, "(A)") "* Fill trivial event transform (deliberately w/o color)" write (u, "(A)") call evt_trivial%connect (process_instance, model) call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) write (u, "(A)") write (u, "(A)") "* Initialize resonance-insertion event transform" write (u, "(A)") evt_trivial%next => evt_resonance evt_resonance%previous => evt_trivial call evt_resonance%set_resonance_data (res_history_set) call evt_resonance%select_component (1) call evt_resonance%connect (process_instance, model) call prc_set%connect_transform (evt_resonance) call evt_resonance%write (u) write (u, "(A)") write (u, "(A)") "* Compute probabilities for applicable resonances" write (u, "(A)") " and initialize the process selector" write (u, "(A)") on_shell_limit = 10._default write (u, "(1x,A,1x," // FMT_10 // ")") & "on_shell_limit =", on_shell_limit call evt_resonance%set_on_shell_limit (on_shell_limit) background_factor = 0 write (u, "(1x,A,1x," // FMT_10 // ")") & "background_factor =", background_factor call evt_resonance%set_background_factor (background_factor) write (u, "(A)") write (u, "(A)") "* Evaluate resonance-insertion event transform" write (u, "(A)") call evt_resonance%prepare_new_event (1, 1) call evt_resonance%generate_weighted (probability) call evt_resonance%make_particle_set (1, .false.) call evt_resonance%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () call syntax_phs_forest_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: restricted_subprocesses_6" end subroutine restricted_subprocesses_6 @ %def restricted_subprocesses_6 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Simulation} This module manages simulation: event generation and reading/writing of event files. The [[simulation]] object is intended to be used (via a pointer) outside of \whizard, if events are generated individually by an external driver. <<[[simulations.f90]]>>= <> module simulations <> <> <> use io_units use format_utils, only: write_separator use format_defs, only: FMT_15, FMT_19 use os_interface use numeric_utils use string_utils, only: str use diagnostics use lorentz, only: vector4_t use sm_qcd use md5 use variables, only: var_list_t use eval_trees use model_data use flavors use particles use state_matrices, only: FM_IGNORE_HELICITY use beam_structures, only: beam_structure_t use beams use rng_base use rng_stream, only: rng_stream_t use selectors use resonances, only: resonance_history_set_t use process_libraries, only: process_library_t use process_libraries, only: process_component_def_t use prc_core ! TODO: (bcn 2016-09-13) should be ideally only pcm_base use pcm, only: pcm_nlo_t, pcm_nlo_workspace_t ! TODO: (bcn 2016-09-13) details of process config should not be necessary here use process_config, only: COMP_REAL_FIN use process use instances use event_base use event_handles, only: event_handle_t use events use event_transforms use shower use eio_data use eio_base use rt_data use dispatch_beams, only: dispatch_qcd use dispatch_rng, only: dispatch_rng_factory use dispatch_rng, only: update_rng_seed_in_var_list use dispatch_me_methods, only: dispatch_core_update, dispatch_core_restore use dispatch_transforms, only: dispatch_evt_isr_epa_handler use dispatch_transforms, only: dispatch_evt_resonance use dispatch_transforms, only: dispatch_evt_decay use dispatch_transforms, only: dispatch_evt_shower use dispatch_transforms, only: dispatch_evt_hadrons use dispatch_transforms, only: dispatch_evt_nlo use integrations use event_streams use restricted_subprocesses, only: resonant_subprocess_set_t use restricted_subprocesses, only: get_libname_res use evt_nlo <> <> <> <> <> contains <> end module simulations @ %def simulations @ \subsection{Event counting} In this object we collect statistical information about an event sample or sub-sample. <>= type :: counter_t integer :: total = 0 integer :: generated = 0 integer :: read = 0 integer :: positive = 0 integer :: negative = 0 integer :: zero = 0 integer :: excess = 0 integer :: dropped = 0 real(default) :: max_excess = 0 real(default) :: sum_excess = 0 logical :: reproduce_xsection = .false. real(default) :: mean = 0 real(default) :: varsq = 0 integer :: nlo_weight_counter = 0 contains <> end type counter_t @ %def simulation_counter_t @ Output. <>= procedure :: write => counter_write <>= subroutine counter_write (counter, unit) class(counter_t), intent(in) :: counter integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) 1 format (3x,A,I0) 2 format (5x,A,I0) 3 format (5x,A,ES19.12) write (u, 1) "Events total = ", counter%total write (u, 2) "generated = ", counter%generated write (u, 2) "read = ", counter%read write (u, 2) "positive weight = ", counter%positive write (u, 2) "negative weight = ", counter%negative write (u, 2) "zero weight = ", counter%zero write (u, 2) "excess weight = ", counter%excess if (counter%excess /= 0) then write (u, 3) "max excess = ", counter%max_excess write (u, 3) "avg excess = ", counter%sum_excess / counter%total end if write (u, 1) "Events dropped = ", counter%dropped end subroutine counter_write @ %def counter_write @ This is a screen message: if there was an excess, display statistics. <>= procedure :: show_excess => counter_show_excess <>= subroutine counter_show_excess (counter) class(counter_t), intent(in) :: counter if (counter%excess > 0) then write (msg_buffer, "(A,1x,I0,1x,A,1x,'(',F7.3,' %)')") & "Encountered events with excess weight:", counter%excess, & "events", 100 * counter%excess / real (counter%total) call msg_warning () write (msg_buffer, "(A,ES10.3)") & "Maximum excess weight =", counter%max_excess call msg_message () write (msg_buffer, "(A,ES10.3)") & "Average excess weight =", counter%sum_excess / counter%total call msg_message () end if end subroutine counter_show_excess @ %def counter_show_excess @ If events have been dropped during simulation of weighted events, issue a message here. If a fraction [[n_dropped / n_total]] of the events fail the cuts, we keep generating new ones until we have [[n_total]] events with [[weight > 0]]. Thus, the total sum of weights will be a fraction of [[n_dropped / n_total]] too large. However, we do not know how many events will pass or fail the cuts prior to generating them so we leave it to the user to correct for this factor. <>= procedure :: show_dropped => counter_show_dropped <>= subroutine counter_show_dropped (counter) class(counter_t), intent(in) :: counter if (counter%dropped > 0) then write (msg_buffer, "(A,1x,I0,1x,'(',A,1x,I0,')')") & "Dropped events (weight zero) =", & counter%dropped, "total", counter%dropped + counter%total call msg_message () write (msg_buffer, "(A,ES15.8)") & "All event weights must be rescaled by f =", & real (counter%total, default) & / real (counter%dropped + counter%total, default) call msg_warning () end if end subroutine counter_show_dropped @ %def counter_show_dropped @ <>= procedure :: show_mean_and_variance => counter_show_mean_and_variance <>= subroutine counter_show_mean_and_variance (counter) class(counter_t), intent(in) :: counter if (counter%reproduce_xsection .and. counter%nlo_weight_counter > 1) then print *, "Reconstructed cross-section from event weights: " print *, counter%mean, '+-', sqrt (counter%varsq / (counter%nlo_weight_counter - 1)) end if end subroutine counter_show_mean_and_variance @ %def counter_show_mean_and_variance @ Count an event. The weight and event source are optional; by default we assume that the event has been generated and has positive weight. The optional integer [[n_dropped]] counts weighted events with weight zero that were encountered while generating the current event, but dropped (because of their zero weight). Accumulating this number allows for renormalizing event weight sums in histograms, after the generation step has been completed. <>= procedure :: record => counter_record <>= subroutine counter_record (counter, weight, excess, n_dropped, from_file) class(counter_t), intent(inout) :: counter real(default), intent(in), optional :: weight, excess integer, intent(in), optional :: n_dropped logical, intent(in), optional :: from_file counter%total = counter%total + 1 if (present (from_file)) then if (from_file) then counter%read = counter%read + 1 else counter%generated = counter%generated + 1 end if else counter%generated = counter%generated + 1 end if if (present (weight)) then if (weight > 0) then counter%positive = counter%positive + 1 else if (weight < 0) then counter%negative = counter%negative + 1 else counter%zero = counter%zero + 1 end if else counter%positive = counter%positive + 1 end if if (present (excess)) then if (excess > 0) then counter%excess = counter%excess + 1 counter%max_excess = max (counter%max_excess, excess) counter%sum_excess = counter%sum_excess + excess end if end if if (present (n_dropped)) then counter%dropped = counter%dropped + n_dropped end if end subroutine counter_record @ %def counter_record <>= procedure :: allreduce_record => counter_allreduce_record <>= subroutine counter_allreduce_record (counter) class(counter_t), intent(inout) :: counter integer :: read, generated integer :: positive, negative, zero, excess, dropped real(default) :: max_excess, sum_excess read = counter%read generated = counter%generated positive = counter%positive negative = counter%negative zero = counter%zero excess = counter%excess max_excess = counter%max_excess sum_excess = counter%sum_excess dropped = counter%dropped call MPI_ALLREDUCE (read, counter%read, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD) call MPI_ALLREDUCE (generated, counter%generated, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD) call MPI_ALLREDUCE (positive, counter%positive, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD) call MPI_ALLREDUCE (negative, counter%negative, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD) call MPI_ALLREDUCE (zero, counter%zero, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD) call MPI_ALLREDUCE (excess, counter%excess, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD) call MPI_ALLREDUCE (max_excess, counter%max_excess, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD) call MPI_ALLREDUCE (sum_excess, counter%sum_excess, 1, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD) call MPI_ALLREDUCE (dropped, counter%dropped, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD) !! \todo{sbrass - Implement allreduce of mean and variance, relevant for weighted events.} end subroutine counter_allreduce_record @ <>= procedure :: record_mean_and_variance => & counter_record_mean_and_variance <>= subroutine counter_record_mean_and_variance (counter, weight, i_nlo) class(counter_t), intent(inout) :: counter real(default), intent(in) :: weight integer, intent(in) :: i_nlo real(default), save :: weight_buffer = 0._default integer, save :: nlo_count = 1 if (.not. counter%reproduce_xsection) return if (i_nlo == 1) then call flush_weight_buffer (weight_buffer, nlo_count) weight_buffer = weight nlo_count = 1 else weight_buffer = weight_buffer + weight nlo_count = nlo_count + 1 end if contains subroutine flush_weight_buffer (w, n_nlo) real(default), intent(in) :: w integer, intent(in) :: n_nlo integer :: n real(default) :: mean_new counter%nlo_weight_counter = counter%nlo_weight_counter + 1 !!! Minus 1 to take into account offset from initialization n = counter%nlo_weight_counter - 1 if (n > 0) then mean_new = counter%mean + (w / n_nlo - counter%mean) / n if (n > 1) & counter%varsq = counter%varsq - counter%varsq / (n - 1) + & n * (mean_new - counter%mean)**2 counter%mean = mean_new end if end subroutine flush_weight_buffer end subroutine counter_record_mean_and_variance @ %def counter_record_mean_and_variance @ \subsection{Simulation: component sets} For each set of process components that share a MCI entry in the process configuration, we keep a separate event record. <>= type :: mci_set_t private integer :: n_components = 0 integer, dimension(:), allocatable :: i_component type(string_t), dimension(:), allocatable :: component_id logical :: has_integral = .false. real(default) :: integral = 0 real(default) :: error = 0 real(default) :: weight_mci = 0 type(counter_t) :: counter contains <> end type mci_set_t @ %def mci_set_t @ Output. <>= procedure :: write => mci_set_write <>= subroutine mci_set_write (object, unit, pacified) class(mci_set_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacified logical :: pacify integer :: u, i u = given_output_unit (unit) pacify = .false.; if (present (pacified)) pacify = pacified write (u, "(3x,A)") "Components:" do i = 1, object%n_components write (u, "(5x,I0,A,A,A)") object%i_component(i), & ": '", char (object%component_id(i)), "'" end do if (object%has_integral) then if (pacify) then write (u, "(3x,A," // FMT_15 // ")") "Integral = ", object%integral write (u, "(3x,A," // FMT_15 // ")") "Error = ", object%error write (u, "(3x,A,F9.6)") "Weight =", object%weight_mci else write (u, "(3x,A," // FMT_19 // ")") "Integral = ", object%integral write (u, "(3x,A," // FMT_19 // ")") "Error = ", object%error write (u, "(3x,A,F13.10)") "Weight =", object%weight_mci end if else write (u, "(3x,A)") "Integral = [undefined]" end if call object%counter%write (u) end subroutine mci_set_write @ %def mci_set_write @ Initialize: Get the indices and names for the process components that will contribute to this set. <>= procedure :: init => mci_set_init <>= subroutine mci_set_init (object, i_mci, process) class(mci_set_t), intent(out) :: object integer, intent(in) :: i_mci type(process_t), intent(in), target :: process integer :: i call process%get_i_component (i_mci, object%i_component) object%n_components = size (object%i_component) allocate (object%component_id (object%n_components)) do i = 1, size (object%component_id) object%component_id(i) = & process%get_component_id (object%i_component(i)) end do if (process%has_integral (i_mci)) then object%integral = process%get_integral (i_mci) object%error = process%get_error (i_mci) object%has_integral = .true. end if end subroutine mci_set_init @ %def mci_set_init @ \subsection{Process-core Safe} This is an object that temporarily holds a process core object. We need this while rescanning a process with modified parameters. After the rescan, we want to restore the original state. <>= type :: core_safe_t class(prc_core_t), allocatable :: core end type core_safe_t @ %def core_safe_t @ \subsection{Process Object} The simulation works on process objects. This subroutine makes a process object available for simulation. The process is in the process stack. [[use_process]] implies that the process should already exist as an object in the process stack. If integration is not yet done, do it. Any generated process object should be put on the global stack, if it is separate from the local one. <>= subroutine prepare_process & (process, process_id, use_process, integrate, local, global) type(process_t), pointer, intent(out) :: process type(string_t), intent(in) :: process_id logical, intent(in) :: use_process, integrate type(rt_data_t), intent(inout), target :: local type(rt_data_t), intent(inout), optional, target :: global type(rt_data_t), pointer :: current if (debug_on) call msg_debug (D_CORE, "prepare_process") if (debug_on) call msg_debug (D_CORE, "global present", present (global)) if (present (global)) then current => global else current => local end if process => current%process_stack%get_process_ptr (process_id) if (debug_on) call msg_debug (D_CORE, "use_process", use_process) if (debug_on) call msg_debug (D_CORE, "associated process", associated (process)) if (use_process .and. .not. associated (process)) then if (integrate) then call msg_message ("Simulate: process '" & // char (process_id) // "' needs integration") else call msg_message ("Simulate: process '" & // char (process_id) // "' needs initialization") end if if (present (global)) then call integrate_process (process_id, local, global, & init_only = .not. integrate) else call integrate_process (process_id, local, & local_stack = .true., init_only = .not. integrate) end if if (signal_is_pending ()) return process => current%process_stack%get_process_ptr (process_id) if (associated (process)) then if (integrate) then call msg_message ("Simulate: integration done") call current%process_stack%fill_result_vars (process_id) else call msg_message ("Simulate: process initialization done") end if else call msg_fatal ("Simulate: process '" & // char (process_id) // "' could not be initialized: aborting") end if else if (.not. associated (process)) then if (present (global)) then call integrate_process (process_id, local, global, & init_only = .true.) else call integrate_process (process_id, local, & local_stack = .true., init_only = .true.) end if process => current%process_stack%get_process_ptr (process_id) call msg_message & ("Simulate: process '" & // char (process_id) // "': enabled for rescan only") end if end subroutine prepare_process @ %def prepare_process @ \subsection{Simulation-entry object} For each process that we consider for event generation, we need a separate entry. The entry separately records the process ID and run ID. The [[weight_mci]] array is used for selecting a component set (which shares an MCI record inside the process container) when generating an event for the current process. The simulation entry is an extension of the [[event_t]] event record. This core object contains configuration data, pointers to the process and process instance, the expressions, flags and values that are evaluated at runtime, and the resulting particle set. The entry explicitly allocates the [[process_instance]], which becomes the process-specific workspace for the event record. If entries with differing environments are present simultaneously, we may need to switch QCD parameters and/or the model event by event. In this case, the [[qcd]] and/or [[model]] components are present. For the purpose of NLO events, [[entry_t]] contains a pointer list to other simulation-entries. This is due to the fact that we have to associate an event for each component of the fixed order simulation, i.e. one $N$-particle event and $N_\text{phs}$ $N+1$-particle events. However, all entries share the same event transforms. <>= type, extends (event_t) :: entry_t private type(string_t) :: process_id type(string_t) :: library type(string_t) :: run_id logical :: has_integral = .false. real(default) :: integral = 0 real(default) :: error = 0 real(default) :: process_weight = 0 logical :: valid = .false. type(counter_t) :: counter integer :: n_in = 0 integer :: n_mci = 0 type(mci_set_t), dimension(:), allocatable :: mci_sets type(selector_t) :: mci_selector logical :: has_resonant_subprocess_set = .false. type(resonant_subprocess_set_t) :: resonant_subprocess_set type(core_safe_t), dimension(:), allocatable :: core_safe class(model_data_t), pointer :: model => null () type(qcd_t) :: qcd type(entry_t), pointer :: first => null () type(entry_t), pointer :: next => null () class(evt_t), pointer :: evt_powheg => null () contains <> end type entry_t @ %def entry_t @ Output. Write just the configuration, the event is written by a separate routine. The [[verbose]] option is unused, it is required by the interface of the base-object method. <>= procedure :: write_config => entry_write_config <>= subroutine entry_write_config (object, unit, pacified) class(entry_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacified logical :: pacify integer :: u, i u = given_output_unit (unit) pacify = .false.; if (present (pacified)) pacify = pacified write (u, "(3x,A,A,A)") "Process = '", char (object%process_id), "'" write (u, "(3x,A,A,A)") "Library = '", char (object%library), "'" write (u, "(3x,A,A,A)") "Run = '", char (object%run_id), "'" write (u, "(3x,A,L1)") "is valid = ", object%valid if (object%has_integral) then if (pacify) then write (u, "(3x,A," // FMT_15 // ")") "Integral = ", object%integral write (u, "(3x,A," // FMT_15 // ")") "Error = ", object%error write (u, "(3x,A,F9.6)") "Weight =", object%process_weight else write (u, "(3x,A," // FMT_19 // ")") "Integral = ", object%integral write (u, "(3x,A," // FMT_19 // ")") "Error = ", object%error write (u, "(3x,A,F13.10)") "Weight =", object%process_weight end if else write (u, "(3x,A)") "Integral = [undefined]" end if write (u, "(3x,A,I0)") "MCI sets = ", object%n_mci call object%counter%write (u) do i = 1, size (object%mci_sets) write (u, "(A)") write (u, "(1x,A,I0,A)") "MCI set #", i, ":" call object%mci_sets(i)%write (u, pacified) end do if (object%resonant_subprocess_set%is_active ()) then write (u, "(A)") call object%write_resonant_subprocess_data (u) end if if (allocated (object%core_safe)) then do i = 1, size (object%core_safe) write (u, "(1x,A,I0,A)") "Saved process-component core #", i, ":" call object%core_safe(i)%core%write (u) end do end if end subroutine entry_write_config @ %def entry_write_config @ Finalizer. The [[instance]] pointer component of the [[event_t]] base type points to a target which we did explicitly allocate in the [[entry_init]] procedure. Therefore, we finalize and explicitly deallocate it here. Then we call the finalizer of the base type. <>= procedure :: final => entry_final <>= subroutine entry_final (object) class(entry_t), intent(inout) :: object integer :: i if (associated (object%instance)) then do i = 1, object%n_mci call object%instance%final_simulation (i) end do call object%instance%final () deallocate (object%instance) end if call object%event_t%final () end subroutine entry_final @ %def entry_final @ Copy the content of an entry into another one, except for the next-pointer <>= procedure :: copy_entry => entry_copy_entry <>= subroutine entry_copy_entry (entry1, entry2) class(entry_t), intent(in), target :: entry1 type(entry_t), intent(inout), target :: entry2 call entry1%event_t%clone (entry2%event_t) entry2%process_id = entry1%process_id entry2%library = entry1%library entry2%run_id = entry1%run_id entry2%has_integral = entry1%has_integral entry2%integral = entry1%integral entry2%error = entry1%error entry2%process_weight = entry1%process_weight entry2%valid = entry1%valid entry2%counter = entry1%counter entry2%n_in = entry1%n_in entry2%n_mci = entry1%n_mci if (allocated (entry1%mci_sets)) then allocate (entry2%mci_sets (size (entry1%mci_sets))) entry2%mci_sets = entry1%mci_sets end if entry2%mci_selector = entry1%mci_selector if (allocated (entry1%core_safe)) then allocate (entry2%core_safe (size (entry1%core_safe))) entry2%core_safe = entry1%core_safe end if entry2%model => entry1%model entry2%qcd = entry1%qcd end subroutine entry_copy_entry @ %def entry_copy_entry @ \subsubsection{Simulation-entry initialization} Search for a process entry and allocate a process instance as an anonymous object, temporarily accessible via the [[process_instance]] pointer. Assign data by looking at the process object and at the environment. If [[n_alt]] is set, we prepare for additional alternate sqme and weight entries. The [[compile]] flag is only false if we do not need the Whizard process at all, just its definition. In that case, we skip process initialization. Otherwise, and if the process object is not found initially: if [[integrate]] is set, attempt an integration pass and try again. Otherwise, just initialize the object. If [[generate]] is set, prepare the MCI objects for generating new events. For pure rescanning, this is not necessary. If [[resonance_history]] is set, we create a separate process library which contains all possible restricted subprocesses with distinct resonance histories. These processes will not be integrated, but their matrix element codes are used for determining probabilities of resonance histories. Note that this can work only if the process method is OMega, and the phase-space method is 'wood'. When done, we assign the [[instance]] and [[process]] pointers of the base type by the [[connect]] method, so we can reference them later. TODO: In case of NLO event generation, copying the configuration from the master process is rather intransparent. For instance, we override the process var list by the global var list. <>= procedure :: init => entry_init <>= subroutine entry_init & (entry, process_id, & use_process, integrate, generate, update_sqme, & support_resonance_history, & local, global, n_alt) class(entry_t), intent(inout), target :: entry type(string_t), intent(in) :: process_id logical, intent(in) :: use_process, integrate, generate, update_sqme logical, intent(in) :: support_resonance_history type(rt_data_t), intent(inout), target :: local type(rt_data_t), intent(inout), optional, target :: global integer, intent(in), optional :: n_alt type(process_t), pointer :: process, master_process type(process_instance_t), pointer :: process_instance type(process_library_t), pointer :: prclib_saved integer :: i logical :: res_include_trivial logical :: combined_integration integer :: selected_mci selected_mci = 0 if (debug_on) call msg_debug (D_CORE, "entry_init") if (debug_on) call msg_debug (D_CORE, "process_id", process_id) call prepare_process & (master_process, process_id, use_process, integrate, local, global) if (signal_is_pending ()) return if (associated (master_process)) then if (.not. master_process%has_matrix_element ()) then entry%has_integral = .true. entry%process_id = process_id entry%valid = .false. return end if else call entry%basic_init (local%var_list) entry%has_integral = .false. entry%process_id = process_id call entry%import_process_def_characteristics (local%prclib, process_id) entry%valid = .true. return end if call entry%basic_init (local%var_list, n_alt) entry%process_id = process_id if (generate .or. integrate) then entry%run_id = master_process%get_run_id () process => master_process else call local%set_log (var_str ("?rebuild_phase_space"), & .false., is_known = .true.) call local%set_log (var_str ("?check_phs_file"), & .false., is_known = .true.) call local%set_log (var_str ("?rebuild_grids"), & .false., is_known = .true.) entry%run_id = & local%var_list%get_sval (var_str ("$run_id")) if (update_sqme) then call prepare_local_process (process, process_id, local) else process => master_process end if end if call entry%import_process_characteristics (process) allocate (entry%mci_sets (entry%n_mci)) do i = 1, size (entry%mci_sets) call entry%mci_sets(i)%init (i, master_process) end do call entry%import_process_results (master_process) call entry%prepare_expressions (local) if (process%is_nlo_calculation ()) then call process%init_nlo_settings (global%var_list) end if combined_integration = local%get_lval (var_str ("?combined_nlo_integration")) if (.not. combined_integration) & selected_mci = process%extract_active_component_mci () call prepare_process_instance (process_instance, process, local%model, & local = local) if (generate) then if (selected_mci > 0) then call process%prepare_simulation (selected_mci) call process_instance%init_simulation (selected_mci, entry%config%safety_factor, & local%get_lval (var_str ("?keep_failed_events"))) else do i = 1, entry%n_mci call process%prepare_simulation (i) call process_instance%init_simulation (i, entry%config%safety_factor, & local%get_lval (var_str ("?keep_failed_events"))) end do end if end if if (support_resonance_history) then prclib_saved => local%prclib call entry%setup_resonant_subprocesses (local, process) if (entry%has_resonant_subprocess_set) then if (signal_is_pending ()) return call entry%compile_resonant_subprocesses (local) if (signal_is_pending ()) return call entry%prepare_resonant_subprocesses (local, global) if (signal_is_pending ()) return call entry%prepare_resonant_subprocess_instances (local) end if if (signal_is_pending ()) return if (associated (prclib_saved)) call local%update_prclib (prclib_saved) end if call entry%setup_event_transforms (process, local) call dispatch_qcd (entry%qcd, local%get_var_list_ptr (), local%os_data) call entry%connect_qcd () if (present (global)) then call entry%connect (process_instance, local%model, global%process_stack) else call entry%connect (process_instance, local%model, local%process_stack) end if call entry%setup_expressions () entry%model => process%get_model_ptr () entry%valid = .true. end subroutine entry_init @ %def entry_init @ <>= procedure :: set_active_real_components => entry_set_active_real_components <>= subroutine entry_set_active_real_components (entry) class(entry_t), intent(inout) :: entry integer :: i_active_real select type (pcm => entry%instance%pcm) class is (pcm_nlo_t) i_active_real = entry%instance%get_real_of_mci () if (debug_on) call msg_debug2 (D_CORE, "i_active_real", i_active_real) if (associated (entry%evt_powheg)) then select type (evt => entry%evt_powheg) type is (evt_shower_t) if (entry%process%get_component_type(i_active_real) == COMP_REAL_FIN) then if (debug_on) call msg_debug (D_CORE, "Disabling Powheg matching for ", i_active_real) call evt%disable_powheg_matching () else if (debug_on) call msg_debug (D_CORE, "Enabling Powheg matching for ", i_active_real) call evt%enable_powheg_matching () end if class default call msg_fatal ("powheg-evt should be evt_shower_t!") end select end if end select end subroutine entry_set_active_real_components @ %def entry_set_active_real_components @ Part of simulation-entry initialization: set up a process object for local use. <>= subroutine prepare_local_process (process, process_id, local) type(process_t), pointer, intent(inout) :: process type(string_t), intent(in) :: process_id type(rt_data_t), intent(inout), target :: local type(integration_t) :: intg call intg%create_process (process_id) call intg%init_process (local) call intg%setup_process (local, verbose=.false.) process => intg%get_process_ptr () end subroutine prepare_local_process @ %def prepare_local_process @ Part of simulation-entry initialization: set up a process instance matching the selected process object. The model that we can provide as an extra argument can modify particle settings (polarization) in the density matrices that will be constructed. It does not affect parameters. <>= subroutine prepare_process_instance & (process_instance, process, model, local) type(process_instance_t), pointer, intent(inout) :: process_instance type(process_t), intent(inout), target :: process class(model_data_t), intent(in), optional :: model type(rt_data_t), intent(in), optional, target :: local allocate (process_instance) call process_instance%init (process) if (process%is_nlo_calculation ()) then select type (pcm_work => process_instance%pcm_work) type is (pcm_nlo_workspace_t) select type (pcm => process_instance%pcm) type is (pcm_nlo_t) if (.not. pcm%settings%combined_integration) & call pcm_work%set_radiation_event () if (pcm%settings%fixed_order_nlo) & call pcm_work%set_fixed_order_event_mode () end select end select call process%prepare_any_external_code () end if call process_instance%setup_event_data (model) end subroutine prepare_process_instance @ %def prepare_process_instance @ Part of simulation-entry initialization: query the process for basic information. <>= procedure, private :: import_process_characteristics & => entry_import_process_characteristics <>= subroutine entry_import_process_characteristics (entry, process) class(entry_t), intent(inout) :: entry type(process_t), intent(in), target :: process entry%library = process%get_library_name () entry%n_in = process%get_n_in () entry%n_mci = process%get_n_mci () end subroutine entry_import_process_characteristics @ %def entry_import_process_characteristics @ This is the alternative form which applies if there is no process entry, but just a process definition which we take from the provided [[prclib]] definition library. <>= procedure, private :: import_process_def_characteristics & => entry_import_process_def_characteristics <>= subroutine entry_import_process_def_characteristics (entry, prclib, id) class(entry_t), intent(inout) :: entry type(process_library_t), intent(in), target :: prclib type(string_t), intent(in) :: id entry%library = prclib%get_name () entry%n_in = prclib%get_n_in (id) end subroutine entry_import_process_def_characteristics @ %def entry_import_process_def_characteristics @ Part of simulation-entry initialization: query the process for integration results. <>= procedure, private :: import_process_results & => entry_import_process_results <>= subroutine entry_import_process_results (entry, process) class(entry_t), intent(inout) :: entry type(process_t), intent(in), target :: process if (process%has_integral ()) then entry%integral = process%get_integral () entry%error = process%get_error () call entry%set_sigma (entry%integral) entry%has_integral = .true. end if end subroutine entry_import_process_results @ %def entry_import_process_characteristics @ Part of simulation-entry initialization: create expression factory objects and store them. <>= procedure, private :: prepare_expressions & => entry_prepare_expressions <>= subroutine entry_prepare_expressions (entry, local) class(entry_t), intent(inout) :: entry type(rt_data_t), intent(in), target :: local type(eval_tree_factory_t) :: expr_factory call expr_factory%init (local%pn%selection_lexpr) call entry%set_selection (expr_factory) call expr_factory%init (local%pn%reweight_expr) call entry%set_reweight (expr_factory) call expr_factory%init (local%pn%analysis_lexpr) call entry%set_analysis (expr_factory) end subroutine entry_prepare_expressions @ %def entry_prepare_expressions @ \subsubsection{Extra (NLO) entries} Initializes the list of additional NLO entries. The routine gets the information about how many entries to associate from [[region_data]]. <>= procedure :: setup_additional_entries => entry_setup_additional_entries <>= subroutine entry_setup_additional_entries (entry) class(entry_t), intent(inout), target :: entry type(entry_t), pointer :: current_entry integer :: i, n_phs type(evt_nlo_t), pointer :: evt integer :: mode evt => null () select type (pcm => entry%instance%pcm) type is (pcm_nlo_t) n_phs = pcm%region_data%n_phs end select select type (entry) type is (entry_t) current_entry => entry current_entry%first => entry call get_nlo_evt_ptr (current_entry, evt, mode) if (mode > EVT_NLO_SEPARATE_BORNLIKE) then allocate (evt%particle_set_nlo (n_phs + 1)) evt%event_deps%n_phs = n_phs evt%qcd = entry%qcd do i = 1, n_phs allocate (current_entry%next) current_entry%next%first => current_entry%first current_entry => current_entry%next call entry%copy_entry (current_entry) current_entry%i_event = i end do else allocate (evt%particle_set_nlo (1)) end if end select contains subroutine get_nlo_evt_ptr (entry, evt, mode) type(entry_t), intent(in), target :: entry type(evt_nlo_t), intent(out), pointer :: evt integer, intent(out) :: mode class(evt_t), pointer :: current_evt evt => null () current_evt => entry%transform_first do select type (current_evt) type is (evt_nlo_t) evt => current_evt mode = evt%mode exit end select if (associated (current_evt%next)) then current_evt => current_evt%next else call msg_fatal ("evt_nlo not in list of event transforms") end if end do end subroutine get_nlo_evt_ptr end subroutine entry_setup_additional_entries @ %def entry_setup_additional_entries @ <>= procedure :: get_first => entry_get_first <>= function entry_get_first (entry) result (entry_out) class(entry_t), intent(in), target :: entry type(entry_t), pointer :: entry_out entry_out => null () select type (entry) type is (entry_t) if (entry%is_nlo ()) then entry_out => entry%first else entry_out => entry end if end select end function entry_get_first @ %def entry_get_first @ <>= procedure :: get_next => entry_get_next <>= function entry_get_next (entry) result (next_entry) class(entry_t), intent(in) :: entry type(entry_t), pointer :: next_entry next_entry => null () if (associated (entry%next)) then next_entry => entry%next else call msg_fatal ("Get next entry: No next entry") end if end function entry_get_next @ %def entry_get_next @ <>= procedure :: count_nlo_entries => entry_count_nlo_entries <>= function entry_count_nlo_entries (entry) result (n) class(entry_t), intent(in), target :: entry integer :: n type(entry_t), pointer :: current_entry n = 1 if (.not. associated (entry%next)) then return else current_entry => entry%next do n = n + 1 if (.not. associated (current_entry%next)) exit current_entry => current_entry%next end do end if end function entry_count_nlo_entries @ %def entry_count_nlo_entries @ <>= procedure :: reset_nlo_counter => entry_reset_nlo_counter <>= subroutine entry_reset_nlo_counter (entry) class(entry_t), intent(inout) :: entry class(evt_t), pointer :: evt evt => entry%transform_first do select type (evt) type is (evt_nlo_t) evt%i_evaluation = 0 exit end select if (associated (evt%next)) evt => evt%next end do end subroutine entry_reset_nlo_counter @ %def entry_reset_nlo_counter @ <>= procedure :: determine_if_powheg_matching => entry_determine_if_powheg_matching <>= subroutine entry_determine_if_powheg_matching (entry) class(entry_t), intent(inout) :: entry class(evt_t), pointer :: current_transform if (associated (entry%transform_first)) then current_transform => entry%transform_first do select type (current_transform) type is (evt_shower_t) if (current_transform%contains_powheg_matching ()) & entry%evt_powheg => current_transform exit end select if (associated (current_transform%next)) then current_transform => current_transform%next else exit end if end do end if end subroutine entry_determine_if_powheg_matching @ %def entry_determine_if_powheg_matching @ \subsubsection{Event-transform initialization} Part of simulation-entry initialization: dispatch event transforms (decay, shower) as requested. If a transform is not applicable or switched off via some variable, it will be skipped. Regarding resonances/decays: these two transforms are currently mutually exclusive. Resonance insertion will not be applied if there is an unstable particle in the game. The initial particle set is the output of the trivial transform; this has already been applied when the transforms listed here are encountered. Each transform takes a particle set and produces a new one, with one exception: the decay module takes its input from the process object, ignoring the trivial transform. (Reason: spin correlations.) Therefore, the decay module must be first in line. Settings that we don't or can't support (yet) are rejected by the embedded call to [[event_transforms_check]]. <>= procedure, private :: setup_event_transforms & => entry_setup_event_transforms <>= subroutine entry_setup_event_transforms (entry, process, local) class(entry_t), intent(inout) :: entry type(process_t), intent(inout), target :: process type(rt_data_t), intent(in), target :: local class(evt_t), pointer :: evt type(var_list_t), pointer :: var_list logical :: enable_isr_handler logical :: enable_epa_handler logical :: enable_fixed_order logical :: enable_shower character(len=7) :: sample_normalization call event_transforms_check (entry, process, local) var_list => local%get_var_list_ptr () if (process%contains_unstable (local%model)) then call dispatch_evt_decay (evt, local%var_list) if (associated (evt)) call entry%import_transform (evt) end if if (entry%resonant_subprocess_set%is_active ()) then call dispatch_evt_resonance (evt, local%var_list, & entry%resonant_subprocess_set%get_resonance_history_set (), & entry%resonant_subprocess_set%get_libname ()) if (associated (evt)) then call entry%resonant_subprocess_set%connect_transform (evt) call entry%resonant_subprocess_set%set_on_shell_limit & (local%get_rval (var_str ("resonance_on_shell_limit"))) call entry%resonant_subprocess_set%set_on_shell_turnoff & (local%get_rval (var_str ("resonance_on_shell_turnoff"))) call entry%resonant_subprocess_set%set_background_factor & (local%get_rval (var_str ("resonance_background_factor"))) call entry%import_transform (evt) end if end if enable_fixed_order = local%get_lval (var_str ("?fixed_order_nlo_events")) if (enable_fixed_order) then call dispatch_evt_nlo & (evt, local%get_lval (var_str ("?keep_failed_events"))) call entry%import_transform (evt) end if enable_isr_handler = local%get_lval (var_str ("?isr_handler")) enable_epa_handler = local%get_lval (var_str ("?epa_handler")) if (enable_isr_handler .or. enable_epa_handler) then call dispatch_evt_isr_epa_handler (evt, local%var_list) if (associated (evt)) call entry%import_transform (evt) end if enable_shower = local%get_lval (var_str ("?allow_shower")) .and. & (local%get_lval (var_str ("?ps_isr_active")) & .or. local%get_lval (var_str ("?ps_fsr_active")) & .or. local%get_lval (var_str ("?muli_active")) & .or. local%get_lval (var_str ("?mlm_matching")) & .or. local%get_lval (var_str ("?ckkw_matching")) & .or. local%get_lval (var_str ("?powheg_matching"))) if (enable_shower) then call dispatch_evt_shower (evt, var_list, local%model, & local%fallback_model, local%os_data, local%beam_structure, & process) call entry%import_transform (evt) end if if (local%get_lval (var_str ("?hadronization_active"))) then call dispatch_evt_hadrons (evt, var_list, local%fallback_model) call entry%import_transform (evt) end if end subroutine entry_setup_event_transforms @ %def entry_setup_event_transforms @ This routine rejects all event-transform settings which we don't support at present. <>= subroutine event_transforms_check (entry, process, local) class(entry_t), intent(in) :: entry type(process_t), intent(in), target :: process type(rt_data_t), intent(in), target :: local if (local%get_lval (var_str ("?fixed_order_nlo_events"))) then if (local%get_lval (var_str ("?unweighted"))) then call msg_fatal ("NLO fixed-order events have to be generated with & &?unweighted = false") end if select case (char (local%get_sval (var_str ("$sample_normalization")))) case ("sigma", "auto") case default call msg_fatal ("NLO fixed-order events: only & &$sample_normalization = 'sigma' is supported.") end select if (process%contains_unstable (local%model)) then call msg_fatal ("NLO fixed-order events: unstable final-state & &particles not supported yet") end if if (entry%resonant_subprocess_set%is_active ()) then call msg_fatal ("NLO fixed-order events: resonant subprocess & &insertion not supported") end if if (local%get_lval (var_str ("?isr_handler")) & .or. local%get_lval (var_str ("?epa_handler"))) then call msg_fatal ("NLO fixed-order events: ISR handler for & &photon-pT generation not supported yet") end if end if if (process%contains_unstable (local%model) & .and. entry%resonant_subprocess_set%is_active ()) then call msg_fatal ("Simulation: resonant subprocess insertion with & &unstable final-state particles not supported") end if end subroutine event_transforms_check @ %def event_transforms_check @ \subsubsection{Process/MCI selector} Compute weights. The integral in the argument is the sum of integrals for all processes in the sample. After computing the process weights, we repeat the normalization procedure for the process components. <>= procedure :: init_mci_selector => entry_init_mci_selector <>= subroutine entry_init_mci_selector (entry, negative_weights) class(entry_t), intent(inout), target :: entry logical, intent(in), optional :: negative_weights type(entry_t), pointer :: current_entry integer :: i, j, k if (debug_on) call msg_debug (D_CORE, "entry_init_mci_selector") if (entry%has_integral) then select type (entry) type is (entry_t) current_entry => entry do j = 1, current_entry%count_nlo_entries () if (j > 1) current_entry => current_entry%get_next () do k = 1, size(current_entry%mci_sets%integral) if (debug_on) call msg_debug (D_CORE, "current_entry%mci_sets(k)%integral", & current_entry%mci_sets(k)%integral) end do call current_entry%mci_selector%init & (current_entry%mci_sets%integral, negative_weights) do i = 1, current_entry%n_mci current_entry%mci_sets(i)%weight_mci = & current_entry%mci_selector%get_weight (i) end do end do end select end if end subroutine entry_init_mci_selector @ %def entry_init_mci_selector @ Select a MCI entry, using the embedded random-number generator. <>= procedure :: select_mci => entry_select_mci <>= function entry_select_mci (entry) result (i_mci) class(entry_t), intent(inout) :: entry integer :: i_mci if (debug_on) call msg_debug2 (D_CORE, "entry_select_mci") i_mci = entry%process%extract_active_component_mci () if (i_mci == 0) call entry%mci_selector%generate (entry%rng, i_mci) if (debug_on) call msg_debug2 (D_CORE, "i_mci", i_mci) end function entry_select_mci @ %def entry_select_mci @ \subsubsection{Entries: event-wise updates} Record an event for this entry, i.e., increment the appropriate counters. <>= procedure :: record => entry_record <>= subroutine entry_record (entry, i_mci, from_file) class(entry_t), intent(inout) :: entry integer, intent(in) :: i_mci logical, intent(in), optional :: from_file real(default) :: weight, excess integer :: n_dropped weight = entry%get_weight_prc () excess = entry%get_excess_prc () n_dropped = entry%get_n_dropped () call entry%counter%record (weight, excess, n_dropped, from_file) if (i_mci > 0) then call entry%mci_sets(i_mci)%counter%record (weight, excess) end if end subroutine entry_record @ %def entry_record @ Update and restore the process core that this entry accesses, when parameters change. If explicit arguments [[model]], [[qcd]], or [[helicity_selection]] are provided, use those. Otherwise use the parameters stored in the process object. These two procedures come with a caching mechanism which guarantees that the current core object is saved when calling [[update_process]], and restored by calling [[restore_process]]. If the flag [[saved]] is unset, saving is skipped, and the [[restore]] procedure should not be called. <>= procedure :: update_process => entry_update_process procedure :: restore_process => entry_restore_process <>= subroutine entry_update_process & (entry, model, qcd, helicity_selection, saved) class(entry_t), intent(inout) :: entry class(model_data_t), intent(in), optional, target :: model type(qcd_t), intent(in), optional :: qcd type(helicity_selection_t), intent(in), optional :: helicity_selection logical, intent(in), optional :: saved type(process_t), pointer :: process class(prc_core_t), allocatable :: core integer :: i, n_terms class(model_data_t), pointer :: model_local type(qcd_t) :: qcd_local logical :: use_saved if (present (model)) then model_local => model else model_local => entry%model end if if (present (qcd)) then qcd_local = qcd else qcd_local = entry%qcd end if use_saved = .true.; if (present (saved)) use_saved = saved process => entry%get_process_ptr () n_terms = process%get_n_terms () if (use_saved) allocate (entry%core_safe (n_terms)) do i = 1, n_terms if (process%has_matrix_element (i, is_term_index = .true.)) then call process%extract_core (i, core) if (use_saved) then call dispatch_core_update (core, & model_local, helicity_selection, qcd_local, & entry%core_safe(i)%core) else call dispatch_core_update (core, & model_local, helicity_selection, qcd_local) end if call process%restore_core (i, core) end if end do end subroutine entry_update_process subroutine entry_restore_process (entry) class(entry_t), intent(inout) :: entry type(process_t), pointer :: process class(prc_core_t), allocatable :: core integer :: i, n_terms process => entry%get_process_ptr () n_terms = process%get_n_terms () do i = 1, n_terms if (process%has_matrix_element (i, is_term_index = .true.)) then call process%extract_core (i, core) call dispatch_core_restore (core, entry%core_safe(i)%core) call process%restore_core (i, core) end if end do deallocate (entry%core_safe) end subroutine entry_restore_process @ %def entry_update_process @ %def entry_restore_process <>= procedure :: connect_qcd => entry_connect_qcd <>= subroutine entry_connect_qcd (entry) class(entry_t), intent(inout), target :: entry class(evt_t), pointer :: evt evt => entry%transform_first do while (associated (evt)) select type (evt) type is (evt_shower_t) evt%qcd = entry%qcd if (allocated (evt%matching)) then evt%matching%qcd = entry%qcd end if end select evt => evt%next end do end subroutine entry_connect_qcd @ %def entry_connect_qcd @ \subsection{Handling resonant subprocesses} Resonant subprocesses are required if we want to determine resonance histories when generating events. The feature is optional, to be switched on by the user. This procedure initializes a new, separate process library that contains copies of the current process, restricted to the relevant resonance histories. (If this library exists already, it is just kept.) The histories can be extracted from the process object. The code has to match the assignments in [[create_resonant_subprocess_library]]. The library may already exist -- in that case, here it will be recovered without recompilation. <>= procedure :: setup_resonant_subprocesses & => entry_setup_resonant_subprocesses <>= subroutine entry_setup_resonant_subprocesses (entry, global, process) class(entry_t), intent(inout) :: entry type(rt_data_t), intent(inout), target :: global type(process_t), intent(in), target :: process type(string_t) :: libname type(resonance_history_set_t) :: res_history_set type(process_library_t), pointer :: lib type(process_component_def_t), pointer :: process_component_def logical :: req_resonant, library_exist integer :: i_component libname = process%get_library_name () lib => global%prclib_stack%get_library_ptr (libname) entry%has_resonant_subprocess_set = lib%req_resonant (process%get_id ()) if (entry%has_resonant_subprocess_set) then libname = get_libname_res (process%get_id ()) call entry%resonant_subprocess_set%init (process%get_n_components ()) call entry%resonant_subprocess_set%create_library & (libname, global, library_exist) do i_component = 1, process%get_n_components () call process%extract_resonance_history_set & (res_history_set, i_component = i_component) call entry%resonant_subprocess_set%fill_resonances & (res_history_set, i_component) if (.not. library_exist) then process_component_def & => process%get_component_def_ptr (i_component) call entry%resonant_subprocess_set%add_to_library & (i_component, & process_component_def%get_prt_spec_in (), & process_component_def%get_prt_spec_out (), & global) end if end do call entry%resonant_subprocess_set%freeze_library (global) end if end subroutine entry_setup_resonant_subprocesses @ %def entry_setup_resonant_subprocesses @ Compile the resonant-subprocesses library. The library is assumed to be the current library in the [[global]] object. This is a simple wrapper. <>= procedure :: compile_resonant_subprocesses & => entry_compile_resonant_subprocesses <>= subroutine entry_compile_resonant_subprocesses (entry, global) class(entry_t), intent(inout) :: entry type(rt_data_t), intent(inout), target :: global call entry%resonant_subprocess_set%compile_library (global) end subroutine entry_compile_resonant_subprocesses @ %def entry_compile_resonant_subprocesses @ Prepare process objects for the resonant-subprocesses library. The process objects are appended to the global process stack. We initialize the processes, such that we can evaluate matrix elements, but we do not need to integrate them. <>= procedure :: prepare_resonant_subprocesses & => entry_prepare_resonant_subprocesses <>= subroutine entry_prepare_resonant_subprocesses (entry, local, global) class(entry_t), intent(inout) :: entry type(rt_data_t), intent(inout), target :: local type(rt_data_t), intent(inout), optional, target :: global call entry%resonant_subprocess_set%prepare_process_objects (local, global) end subroutine entry_prepare_resonant_subprocesses @ %def entry_prepare_resonant_subprocesses @ Prepare process instances. They are linked to their corresponding process objects. Both, process and instance objects, are allocated as anonymous targets inside the [[resonant_subprocess_set]] component. NOTE: those anonymous object are likely forgotten during finalization of the parent [[event_t]] (extended as [[entry_t]]) object. This should be checked! The memory leak is probably harmless as long as the event object is created once per run, not once per event. <>= procedure :: prepare_resonant_subprocess_instances & => entry_prepare_resonant_subprocess_instances <>= subroutine entry_prepare_resonant_subprocess_instances (entry, global) class(entry_t), intent(inout) :: entry type(rt_data_t), intent(in), target :: global call entry%resonant_subprocess_set%prepare_process_instances (global) end subroutine entry_prepare_resonant_subprocess_instances @ %def entry_prepare_resonant_subprocess_instances @ Display the resonant subprocesses. This includes, upon request, the resonance set that defines those subprocess, and a short or long account of the process objects themselves. <>= procedure :: write_resonant_subprocess_data & => entry_write_resonant_subprocess_data <>= subroutine entry_write_resonant_subprocess_data (entry, unit) class(entry_t), intent(in) :: entry integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) call entry%resonant_subprocess_set%write (unit) write (u, "(1x,A,I0)") "Resonant subprocesses refer to & &process component #", 1 end subroutine entry_write_resonant_subprocess_data @ %def entry_write_resonant_subprocess_data @ Display of the master process for the current event, for diagnostics. <>= procedure :: write_process_data => entry_write_process_data <>= subroutine entry_write_process_data & (entry, unit, show_process, show_instance, verbose) class(entry_t), intent(in) :: entry integer, intent(in), optional :: unit logical, intent(in), optional :: show_process logical, intent(in), optional :: show_instance logical, intent(in), optional :: verbose integer :: u, i logical :: s_proc, s_inst, verb type(process_t), pointer :: process type(process_instance_t), pointer :: instance u = given_output_unit (unit) s_proc = .false.; if (present (show_process)) s_proc = show_process s_inst = .false.; if (present (show_instance)) s_inst = show_instance verb = .false.; if (present (verbose)) verb = verbose if (s_proc .or. s_inst) then write (u, "(1x,A,':')") "Process data" if (s_proc) then process => entry%process if (associated (process)) then if (verb) then call write_separator (u, 2) call process%write (.false., u) else call process%show (u, verbose=.false.) end if else write (u, "(3x,A)") "[not associated]" end if end if if (s_inst) then instance => entry%instance if (associated (instance)) then if (verb) then call instance%write (u) else call instance%write_header (u) end if else write (u, "(3x,A)") "Process instance: [not associated]" end if end if end if end subroutine entry_write_process_data @ %def entry_write_process_data @ \subsection{Entries for alternative environment} Entries for alternate environments. [No additional components anymore, so somewhat redundant.] <>= type, extends (entry_t) :: alt_entry_t contains <> end type alt_entry_t @ %def alt_entry_t @ The alternative entries are there to re-evaluate the event, given momenta, in a different context. Therefore, we allocate a local process object and use this as the reference for the local process instance, when initializing the entry. We temporarily import the [[process]] object into an [[integration_t]] wrapper, to take advantage of the associated methods. The local process object is built in the context of the current environment, here called [[global]]. Then, we initialize the process instance. The [[master_process]] object contains the integration results to which we refer when recalculating an event. Therefore, we use this object instead of the locally built [[process]] when we extract the integration results. The locally built [[process]] object should be finalized when done. It remains accessible via the [[event_t]] base object of [[entry]], which contains pointers to the process and instance. <>= procedure :: init_alt => alt_entry_init <>= subroutine alt_entry_init (entry, process_id, master_process, local) class(alt_entry_t), intent(inout), target :: entry type(string_t), intent(in) :: process_id type(process_t), intent(in), target :: master_process type(rt_data_t), intent(inout), target :: local type(process_t), pointer :: process type(process_instance_t), pointer :: process_instance type(string_t) :: run_id integer :: i call msg_message ("Simulate: initializing alternate process setup ...") run_id = & local%var_list%get_sval (var_str ("$run_id")) call local%set_log (var_str ("?rebuild_phase_space"), & .false., is_known = .true.) call local%set_log (var_str ("?check_phs_file"), & .false., is_known = .true.) call local%set_log (var_str ("?rebuild_grids"), & .false., is_known = .true.) call entry%basic_init (local%var_list) call prepare_local_process (process, process_id, local) entry%process_id = process_id entry%run_id = run_id call entry%import_process_characteristics (process) allocate (entry%mci_sets (entry%n_mci)) do i = 1, size (entry%mci_sets) call entry%mci_sets(i)%init (i, master_process) end do call entry%import_process_results (master_process) call entry%prepare_expressions (local) call prepare_process_instance (process_instance, process, local%model) call entry%setup_event_transforms (process, local) call entry%connect (process_instance, local%model, local%process_stack) call entry%setup_expressions () entry%model => process%get_model_ptr () call msg_message ("... alternate process setup complete.") end subroutine alt_entry_init @ %def alt_entry_init @ Copy the particle set from the master entry to the alternate entry. This is the particle set of the hard process. <>= procedure :: fill_particle_set => entry_fill_particle_set <>= subroutine entry_fill_particle_set (alt_entry, entry) class(alt_entry_t), intent(inout) :: alt_entry class(entry_t), intent(in), target :: entry type(particle_set_t) :: pset call entry%get_hard_particle_set (pset) call alt_entry%set_hard_particle_set (pset) call pset%final () end subroutine entry_fill_particle_set @ %def particle_set_copy_prt @ \subsection{The simulation object} Each simulation object corresponds to an event sample, identified by the [[sample_id]]. The simulation may cover several processes simultaneously. All process-specific data, including the event records, are stored in the [[entry]] subobjects. The [[current]] index indicates which record was selected last. [[version]] is foreseen to contain a tag on the \whizard\ event file version. It can be <>= public :: simulation_t <>= type :: simulation_t private type(rt_data_t), pointer :: local => null () type(string_t) :: sample_id logical :: unweighted = .true. logical :: negative_weights = .false. logical :: support_resonance_history = .false. logical :: respect_selection = .true. integer :: norm_mode = NORM_UNDEFINED logical :: update_sqme = .false. logical :: update_weight = .false. logical :: update_event = .false. logical :: recover_beams = .false. logical :: pacify = .false. integer :: n_max_tries = 10000 integer :: n_prc = 0 integer :: n_alt = 0 logical :: has_integral = .false. logical :: valid = .false. real(default) :: integral = 0 real(default) :: error = 0 integer :: version = 1 character(32) :: md5sum_prc = "" character(32) :: md5sum_cfg = "" character(32), dimension(:), allocatable :: md5sum_alt type(entry_t), dimension(:), allocatable :: entry type(alt_entry_t), dimension(:,:), allocatable :: alt_entry type(selector_t) :: process_selector integer :: n_evt_requested = 0 integer :: event_index_offset = 0 logical :: event_index_set = .false. integer :: event_index = 0 integer :: split_n_evt = 0 integer :: split_n_kbytes = 0 integer :: split_index = 0 type(counter_t) :: counter class(rng_t), allocatable :: rng integer :: i_prc = 0 integer :: i_mci = 0 real(default) :: weight = 0 real(default) :: excess = 0 integer :: n_dropped = 0 contains <> end type simulation_t @ %def simulation_t @ \subsubsection{Output of the simulation data} [[write_config]] writes just the configuration. [[write]] as a method of the base type [[event_t]] writes the current event and process instance, depending on options. <>= procedure :: write => simulation_write <>= subroutine simulation_write (object, unit, testflag) class(simulation_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag logical :: pacified integer :: u, i u = given_output_unit (unit) pacified = object%pacify; if (present (testflag)) pacified = testflag call write_separator (u, 2) write (u, "(1x,A,A,A)") "Event sample: '", char (object%sample_id), "'" write (u, "(3x,A,I0)") "Processes = ", object%n_prc if (object%n_alt > 0) then write (u, "(3x,A,I0)") "Alt.wgts = ", object%n_alt end if write (u, "(3x,A,L1)") "Unweighted = ", object%unweighted write (u, "(3x,A,A)") "Event norm = ", & char (event_normalization_string (object%norm_mode)) write (u, "(3x,A,L1)") "Neg. weights = ", object%negative_weights write (u, "(3x,A,L1)") "Res. history = ", object%support_resonance_history write (u, "(3x,A,L1)") "Respect sel. = ", object%respect_selection write (u, "(3x,A,L1)") "Update sqme = ", object%update_sqme write (u, "(3x,A,L1)") "Update wgt = ", object%update_weight write (u, "(3x,A,L1)") "Update event = ", object%update_event write (u, "(3x,A,L1)") "Recov. beams = ", object%recover_beams write (u, "(3x,A,L1)") "Pacify = ", object%pacify write (u, "(3x,A,I0)") "Max. tries = ", object%n_max_tries if (object%has_integral) then if (pacified) then write (u, "(3x,A," // FMT_15 // ")") & "Integral = ", object%integral write (u, "(3x,A," // FMT_15 // ")") & "Error = ", object%error else write (u, "(3x,A," // FMT_19 // ")") & "Integral = ", object%integral write (u, "(3x,A," // FMT_19 // ")") & "Error = ", object%error end if else write (u, "(3x,A)") "Integral = [undefined]" end if write (u, "(3x,A,L1)") "Sim. valid = ", object%valid write (u, "(3x,A,I0)") "Ev.file ver. = ", object%version if (object%md5sum_prc /= "") then write (u, "(3x,A,A,A)") "MD5 sum (proc) = '", object%md5sum_prc, "'" end if if (object%md5sum_cfg /= "") then write (u, "(3x,A,A,A)") "MD5 sum (config) = '", object%md5sum_cfg, "'" end if write (u, "(3x,A,I0)") "Events requested = ", object%n_evt_requested if (object%event_index_offset /= 0) then write (u, "(3x,A,I0)") "Event index offset= ", object%event_index_offset end if if (object%event_index_set) then write (u, "(3x,A,I0)") "Event index = ", object%event_index end if if (object%split_n_evt > 0 .or. object%split_n_kbytes > 0) then write (u, "(3x,A,I0)") "Events per file = ", object%split_n_evt write (u, "(3x,A,I0)") "KBytes per file = ", object%split_n_kbytes write (u, "(3x,A,I0)") "First file index = ", object%split_index end if call object%counter%write (u) call write_separator (u) if (object%i_prc /= 0) then write (u, "(1x,A)") "Current event:" write (u, "(3x,A,I0,A,A)") "Process #", & object%i_prc, ": ", & char (object%entry(object%i_prc)%process_id) write (u, "(3x,A,I0)") "MCI set #", object%i_mci write (u, "(3x,A," // FMT_19 // ")") "Weight = ", object%weight if (.not. vanishes (object%excess)) & write (u, "(3x,A," // FMT_19 // ")") "Excess = ", object%excess write (u, "(3x,A,I0)") "Zero-weight events dropped = ", object%n_dropped else write (u, "(1x,A,I0,A,A)") "Current event: [undefined]" end if call write_separator (u) if (allocated (object%rng)) then call object%rng%write (u) else write (u, "(3x,A)") "Random-number generator: [undefined]" end if if (allocated (object%entry)) then do i = 1, size (object%entry) if (i == 1) then call write_separator (u, 2) else call write_separator (u) end if write (u, "(1x,A,I0,A)") "Process #", i, ":" call object%entry(i)%write_config (u, pacified) end do end if call write_separator (u, 2) end subroutine simulation_write @ %def simulation_write @ Write the current event record. If an explicit index is given, write that event record. We implement writing to [[unit]] (event contents / debugging format) and writing to an [[eio]] event stream (storage). We include a [[testflag]] in order to suppress numerical noise in the testsuite. <>= generic :: write_event => write_event_unit procedure :: write_event_unit => simulation_write_event_unit <>= subroutine simulation_write_event_unit & (object, unit, i_prc, verbose, testflag) class(simulation_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer, intent(in), optional :: i_prc logical, intent(in), optional :: testflag logical :: pacified integer :: current pacified = .false.; if (present(testflag)) pacified = testflag pacified = pacified .or. object%pacify if (present (i_prc)) then current = i_prc else current = object%i_prc end if if (current > 0) then call object%entry(current)%write (unit, verbose = verbose, & testflag = pacified) else call msg_fatal ("Simulation: write event: no process selected") end if end subroutine simulation_write_event_unit @ %def simulation_write_event @ This writes one of the alternate events, if allocated. <>= procedure :: write_alt_event => simulation_write_alt_event <>= subroutine simulation_write_alt_event (object, unit, j_alt, i_prc, & verbose, testflag) class(simulation_t), intent(in) :: object integer, intent(in), optional :: unit integer, intent(in), optional :: j_alt integer, intent(in), optional :: i_prc logical, intent(in), optional :: verbose logical, intent(in), optional :: testflag integer :: i, j if (present (j_alt)) then j = j_alt else j = 1 end if if (present (i_prc)) then i = i_prc else i = object%i_prc end if if (i > 0) then if (j> 0 .and. j <= object%n_alt) then call object%alt_entry(i,j)%write (unit, verbose = verbose, & testflag = testflag) else call msg_fatal ("Simulation: write alternate event: out of range") end if else call msg_fatal ("Simulation: write alternate event: no process selected") end if end subroutine simulation_write_alt_event @ %def simulation_write_alt_event @ This writes the contents of the resonant subprocess set in the current event record. <>= procedure :: write_resonant_subprocess_data & => simulation_write_resonant_subprocess_data <>= subroutine simulation_write_resonant_subprocess_data (object, unit, i_prc) class(simulation_t), intent(in) :: object integer, intent(in), optional :: unit integer, intent(in), optional :: i_prc integer :: i if (present (i_prc)) then i = i_prc else i = object%i_prc end if call object%entry(i)%write_resonant_subprocess_data (unit) end subroutine simulation_write_resonant_subprocess_data @ %def simulation_write_resonant_subprocess_data @ The same for the master process, as an additional debugging aid. <>= procedure :: write_process_data & => simulation_write_process_data <>= subroutine simulation_write_process_data & (object, unit, i_prc, & show_process, show_instance, verbose) class(simulation_t), intent(in) :: object integer, intent(in), optional :: unit integer, intent(in), optional :: i_prc logical, intent(in), optional :: show_process logical, intent(in), optional :: show_instance logical, intent(in), optional :: verbose integer :: i if (present (i_prc)) then i = i_prc else i = object%i_prc end if call object%entry(i)%write_process_data & (unit, show_process, show_instance, verbose) end subroutine simulation_write_process_data @ %def simulation_write_process_data @ Write the actual efficiency of the simulation run. We get the total number of events stored in the simulation counter and compare this with the total number of calls stored in the event entries. In order not to miscount samples that are partly read from file, use the [[generated]] counter, not the [[total]] counter. <>= procedure :: show_efficiency => simulation_show_efficiency <>= subroutine simulation_show_efficiency (simulation) class(simulation_t), intent(inout) :: simulation integer :: n_events, n_calls real(default) :: eff n_events = simulation%counter%generated n_calls = sum (simulation%entry%get_actual_calls_total ()) if (n_calls > 0) then eff = real (n_events, kind=default) / n_calls write (msg_buffer, "(A,1x,F6.2,1x,A)") & "Events: actual unweighting efficiency =", 100 * eff, "%" call msg_message () end if end subroutine simulation_show_efficiency @ %def simulation_show_efficiency @ Compute the checksum of the process set. We retrieve the MD5 sums of all processes. This depends only on the process definitions, while parameters are not considered. The configuration checksum is retrieved from the MCI records in the process objects and furthermore includes beams, parameters, integration results, etc., so matching the latter should guarantee identical physics. <>= procedure :: compute_md5sum => simulation_compute_md5sum <>= subroutine simulation_compute_md5sum (simulation) class(simulation_t), intent(inout) :: simulation type(process_t), pointer :: process type(string_t) :: buffer integer :: j, i, n_mci, i_mci, n_component, i_component if (simulation%md5sum_prc == "") then buffer = "" do i = 1, simulation%n_prc if (.not. simulation%entry(i)%valid) cycle process => simulation%entry(i)%get_process_ptr () if (associated (process)) then n_component = process%get_n_components () do i_component = 1, n_component if (process%has_matrix_element (i_component)) then buffer = buffer // process%get_md5sum_prc (i_component) end if end do end if end do simulation%md5sum_prc = md5sum (char (buffer)) end if if (simulation%md5sum_cfg == "") then buffer = "" do i = 1, simulation%n_prc if (.not. simulation%entry(i)%valid) cycle process => simulation%entry(i)%get_process_ptr () if (associated (process)) then n_mci = process%get_n_mci () do i_mci = 1, n_mci buffer = buffer // process%get_md5sum_mci (i_mci) end do end if end do simulation%md5sum_cfg = md5sum (char (buffer)) end if do j = 1, simulation%n_alt if (simulation%md5sum_alt(j) == "") then buffer = "" do i = 1, simulation%n_prc process => simulation%alt_entry(i,j)%get_process_ptr () if (associated (process)) then buffer = buffer // process%get_md5sum_cfg () end if end do simulation%md5sum_alt(j) = md5sum (char (buffer)) end if end do end subroutine simulation_compute_md5sum @ %def simulation_compute_md5sum @ \subsubsection{Simulation-object finalizer} <>= procedure :: final => simulation_final <>= subroutine simulation_final (object) class(simulation_t), intent(inout) :: object integer :: i, j if (allocated (object%entry)) then do i = 1, size (object%entry) call object%entry(i)%final () end do end if if (allocated (object%alt_entry)) then do j = 1, size (object%alt_entry, 2) do i = 1, size (object%alt_entry, 1) call object%alt_entry(i,j)%final () end do end do end if if (allocated (object%rng)) call object%rng%final () end subroutine simulation_final @ %def simulation_final @ \subsubsection{Simulation-object initialization} We can deduce all data from the given list of process IDs and the global data set. The process objects are taken from the stack. Once the individual integrals are known, we add them (and the errors), to get the sample integral. If there are alternative environments, we suspend initialization for setting up alternative process objects, then restore the master process and its parameters. The generator or rescanner can then switch rapidly between processes. If [[integrate]] is set, we make sure that all affected processes are integrated before simulation. This is necessary if we want to actually generate events. If [[integrate]] is unset, we do not need the integral because we just rescan existing events. In that case, we just need compiled matrix elements. If [[generate]] is set, we prepare for actually generating events. Otherwise, we may only read and rescan events. <>= procedure :: init => simulation_init <>= subroutine simulation_init (simulation, & process_id, integrate, generate, local, global, alt_env) class(simulation_t), intent(out), target :: simulation type(string_t), dimension(:), intent(in) :: process_id logical, intent(in) :: integrate, generate type(rt_data_t), intent(inout), target :: local type(rt_data_t), intent(inout), optional, target :: global type(rt_data_t), dimension(:), intent(inout), optional, target :: alt_env class(rng_factory_t), allocatable :: rng_factory integer :: next_rng_seed type(string_t) :: norm_string, version_string logical :: use_process integer :: i, j type(string_t) :: sample_suffix <> sample_suffix = "" <> simulation%local => local simulation%sample_id = & local%get_sval (var_str ("$sample")) simulation%unweighted = & local%get_lval (var_str ("?unweighted")) simulation%negative_weights = & local%get_lval (var_str ("?negative_weights")) simulation%support_resonance_history = & local%get_lval (var_str ("?resonance_history")) simulation%respect_selection = & local%get_lval (var_str ("?sample_select")) version_string = & local%get_sval (var_str ("$event_file_version")) norm_string = & local%get_sval (var_str ("$sample_normalization")) simulation%norm_mode = & event_normalization_mode (norm_string, simulation%unweighted) simulation%pacify = & local%get_lval (var_str ("?sample_pacify")) simulation%event_index_offset = & local%get_ival (var_str ("event_index_offset")) simulation%n_max_tries = & local%get_ival (var_str ("sample_max_tries")) simulation%split_n_evt = & local%get_ival (var_str ("sample_split_n_evt")) simulation%split_n_kbytes = & local%get_ival (var_str ("sample_split_n_kbytes")) simulation%split_index = & local%get_ival (var_str ("sample_split_index")) simulation%update_sqme = & local%get_lval (var_str ("?update_sqme")) simulation%update_weight = & local%get_lval (var_str ("?update_weight")) simulation%update_event = & local%get_lval (var_str ("?update_event")) simulation%recover_beams = & local%get_lval (var_str ("?recover_beams")) simulation%counter%reproduce_xsection = & local%get_lval (var_str ("?check_event_weights_against_xsection")) use_process = & integrate .or. generate & .or. simulation%update_sqme & .or. simulation%update_weight & .or. simulation%update_event & .or. present (alt_env) select case (size (process_id)) case (0) call msg_error ("Simulation: no process selected") case (1) write (msg_buffer, "(A,A,A)") & "Starting simulation for process '", & char (process_id(1)), "'" call msg_message () case default write (msg_buffer, "(A,A,A)") & "Starting simulation for processes '", & char (process_id(1)), "' etc." call msg_message () end select select case (char (version_string)) case ("", "2.2.4") simulation%version = 2 case ("2.2") simulation%version = 1 case default simulation%version = 0 end select if (simulation%version == 0) then call msg_fatal ("Event file format '" & // char (version_string) & // "' is not compatible with this version.") end if simulation%n_prc = size (process_id) allocate (simulation%entry (simulation%n_prc)) if (present (alt_env)) then simulation%n_alt = size (alt_env) do i = 1, simulation%n_prc call simulation%entry(i)%init (process_id(i), & use_process, integrate, generate, & simulation%update_sqme, & simulation%support_resonance_history, & local, global, simulation%n_alt) if (signal_is_pending ()) return end do simulation%valid = any (simulation%entry%valid) if (.not. simulation%valid) then call msg_error ("Simulate: no process has a valid matrix element.") return end if call simulation%update_processes () allocate (simulation%alt_entry (simulation%n_prc, simulation%n_alt)) allocate (simulation%md5sum_alt (simulation%n_alt)) simulation%md5sum_alt = "" do j = 1, simulation%n_alt do i = 1, simulation%n_prc call simulation%alt_entry(i,j)%init_alt (process_id(i), & simulation%entry(i)%get_process_ptr (), alt_env(j)) if (signal_is_pending ()) return end do end do call simulation%restore_processes () else do i = 1, simulation%n_prc call simulation%entry(i)%init & (process_id(i), & use_process, integrate, generate, & simulation%update_sqme, & simulation%support_resonance_history, & local, global) call simulation%entry(i)%determine_if_powheg_matching () if (signal_is_pending ()) return if (simulation%entry(i)%is_nlo ()) & call simulation%entry(i)%setup_additional_entries () end do simulation%valid = any (simulation%entry%valid) if (.not. simulation%valid) then call msg_error ("Simulate: " & // "no process has a valid matrix element.") return end if end if !!! if this becomes conditional, some ref files will need update (seed change) ! if (generate) then call dispatch_rng_factory (rng_factory, local%var_list, next_rng_seed) call update_rng_seed_in_var_list (local%var_list, next_rng_seed) call rng_factory%make (simulation%rng) <> ! end if if (all (simulation%entry%has_integral)) then simulation%integral = sum (simulation%entry%integral) simulation%error = sqrt (sum (simulation%entry%error ** 2)) simulation%has_integral = .true. if (integrate .and. generate) then do i = 1, simulation%n_prc if (simulation%entry(i)%integral < 0 .and. .not. & simulation%negative_weights) then call msg_fatal ("Integral of process '" // & char (process_id (i)) // "'is negative.") end if end do end if else if (integrate .and. generate) & call msg_error ("Simulation contains undefined integrals.") end if if (simulation%integral > 0 .or. & (simulation%integral < 0 .and. simulation%negative_weights)) then simulation%valid = .true. else if (generate) then call msg_error ("Simulate: " & // "sum of process integrals must be positive; skipping.") simulation%valid = .false. else simulation%valid = .true. end if if (simulation%sample_id == "") then simulation%sample_id = simulation%get_default_sample_name () end if simulation%sample_id = simulation%sample_id // sample_suffix if (simulation%valid) call simulation%compute_md5sum () end subroutine simulation_init @ %def simulation_init @ The RNG initialization depends on serial/MPI mode. <>= <>= integer :: rank, n_size <>= <>= call mpi_get_comm_id (n_size, rank) if (n_size > 1) then sample_suffix = var_str ("_") // str (rank) end if <>= <>= do i = 2, rank + 1 select type (rng => simulation%rng) type is (rng_stream_t) call rng%next_substream () if (i == rank) & call msg_message ("Simulate: Advance RNG for parallel event generation") class default call rng%write () call msg_bug ("Parallel event generation: random-number generator & &must be 'rng_stream'.") end select end do @ The number of events that we want to simulate is determined by the settings of [[n_events]], [[luminosity]], and [[?unweighted]]. For weighted events, we take [[n_events]] at face value as the number of matrix element calls. For unweighted events, if the process is a decay, [[n_events]] is the number of unweighted events. In these cases, the luminosity setting is ignored. For unweighted events with a scattering process, we calculate the event number that corresponds to the luminosity, given the current value of the integral. We then compare this with [[n_events]] and choose the larger number. <>= procedure :: compute_n_events => simulation_compute_n_events <>= subroutine simulation_compute_n_events (simulation, n_events) class(simulation_t), intent(in) :: simulation integer, intent(out) :: n_events real(default) :: lumi, x_events_lumi integer :: n_events_lumi logical :: is_scattering n_events = & simulation%local%get_ival (var_str ("n_events")) lumi = & simulation%local%get_rval (var_str ("luminosity")) if (simulation%unweighted) then is_scattering = simulation%entry(1)%n_in == 2 if (is_scattering) then x_events_lumi = abs (simulation%integral * lumi) if (x_events_lumi < huge (n_events)) then n_events_lumi = nint (x_events_lumi) else call msg_message ("Simulation: luminosity too large, & &limiting number of events") n_events_lumi = huge (n_events) end if if (n_events_lumi > n_events) then call msg_message ("Simulation: using n_events as computed from & &luminosity value") n_events = n_events_lumi else write (msg_buffer, "(A,1x,I0)") & "Simulation: requested number of events =", n_events call msg_message () if (.not. vanishes (simulation%integral)) then write (msg_buffer, "(A,1x,ES11.4)") & " corr. to luminosity [fb-1] = ", & n_events / simulation%integral call msg_message () end if end if end if end if end subroutine simulation_compute_n_events @ %def simulation_compute_n_events @ Configuration of the OpenMP parameters, in case OpenMP is active. We use the settings accessible via the local environment. <>= procedure :: setup_openmp => simulation_setup_openmp <>= subroutine simulation_setup_openmp (simulation) class(simulation_t), intent(inout) :: simulation call openmp_set_num_threads_verbose & (simulation%local%get_ival (var_str ("openmp_num_threads")), & simulation%local%get_lval (var_str ("?openmp_logging"))) end subroutine simulation_setup_openmp @ %def simulation_setup_openmp @ Configuration of the event-stream array -- i.e., the setup of output file formats. <>= procedure :: prepare_event_streams => simulation_prepare_event_streams <>= subroutine simulation_prepare_event_streams (sim, es_array) class(simulation_t), intent(inout) :: sim type(event_stream_array_t), intent(out) :: es_array integer :: n_events logical :: rebuild_events, read_raw, write_raw integer :: checkpoint, callback integer :: n_fmt type(event_sample_data_t) :: data type(string_t), dimension(:), allocatable :: sample_fmt n_events = & sim%n_evt_requested rebuild_events = & sim%local%get_lval (var_str ("?rebuild_events")) read_raw = & sim%local%get_lval (var_str ("?read_raw")) .and. .not. rebuild_events write_raw = & sim%local%get_lval (var_str ("?write_raw")) checkpoint = & sim%local%get_ival (var_str ("checkpoint")) callback = & sim%local%get_ival (var_str ("event_callback_interval")) if (read_raw) then inquire (file = char (sim%sample_id) // ".evx", exist = read_raw) end if if (allocated (sim%local%sample_fmt)) then n_fmt = size (sim%local%sample_fmt) else n_fmt = 0 end if data = sim%get_data () data%n_evt = n_events data%nlo_multiplier = sim%get_n_nlo_entries (1) if (read_raw) then allocate (sample_fmt (n_fmt)) if (n_fmt > 0) sample_fmt = sim%local%sample_fmt call es_array%init (sim%sample_id, & sample_fmt, sim%local, & data = data, & input = var_str ("raw"), & allow_switch = write_raw, & checkpoint = checkpoint, & callback = callback) else if (write_raw) then allocate (sample_fmt (n_fmt + 1)) if (n_fmt > 0) sample_fmt(:n_fmt) = sim%local%sample_fmt sample_fmt(n_fmt+1) = var_str ("raw") call es_array%init (sim%sample_id, & sample_fmt, sim%local, & data = data, & checkpoint = checkpoint, & callback = callback) else if (allocated (sim%local%sample_fmt) & .or. checkpoint > 0 & .or. callback > 0) then allocate (sample_fmt (n_fmt)) if (n_fmt > 0) sample_fmt = sim%local%sample_fmt call es_array%init (sim%sample_id, & sample_fmt, sim%local, & data = data, & checkpoint = checkpoint, & callback = callback) end if end subroutine simulation_prepare_event_streams @ %def simulation_prepare_event_streams @ <>= procedure :: get_n_nlo_entries => simulation_get_n_nlo_entries <>= function simulation_get_n_nlo_entries (simulation, i_prc) result (n_extra) class(simulation_t), intent(in) :: simulation integer, intent(in) :: i_prc integer :: n_extra n_extra = simulation%entry(i_prc)%count_nlo_entries () end function simulation_get_n_nlo_entries @ %def simulation_get_n_nlo_entries @ Initialize the process selector, using the entry integrals as process weights. <>= procedure :: init_process_selector => simulation_init_process_selector <>= subroutine simulation_init_process_selector (simulation) class(simulation_t), intent(inout) :: simulation integer :: i if (simulation%has_integral) then call simulation%process_selector%init (simulation%entry%integral, & negative_weights = simulation%negative_weights) do i = 1, simulation%n_prc associate (entry => simulation%entry(i)) if (.not. entry%valid) then call msg_warning ("Process '" // char (entry%process_id) // & "': matrix element vanishes, no events can be generated.") cycle end if call entry%init_mci_selector (simulation%negative_weights) entry%process_weight = simulation%process_selector%get_weight (i) end associate end do end if end subroutine simulation_init_process_selector @ %def simulation_init_process_selector @ Select a process, using the random-number generator. <>= procedure :: select_prc => simulation_select_prc <>= function simulation_select_prc (simulation) result (i_prc) class(simulation_t), intent(inout) :: simulation integer :: i_prc call simulation%process_selector%generate (simulation%rng, i_prc) end function simulation_select_prc @ %def simulation_select_prc @ Select a MCI set for the selected process. <>= procedure :: select_mci => simulation_select_mci <>= function simulation_select_mci (simulation) result (i_mci) class(simulation_t), intent(inout) :: simulation integer :: i_mci i_mci = 0 if (simulation%i_prc /= 0) then i_mci = simulation%entry(simulation%i_prc)%select_mci () end if end function simulation_select_mci @ %def simulation_select_mci @ \subsubsection{Generate-event loop} The requested number of events should be set by this, in time for the event-array initializers that may use this number. <>= procedure :: set_n_events_requested => simulation_set_n_events_requested procedure :: get_n_events_requested => simulation_get_n_events_requested <>= subroutine simulation_set_n_events_requested (simulation, n) class(simulation_t), intent(inout) :: simulation integer, intent(in) :: n simulation%n_evt_requested = n end subroutine simulation_set_n_events_requested function simulation_get_n_events_requested (simulation) result (n) class(simulation_t), intent(in) :: simulation integer :: n n = simulation%n_evt_requested end function simulation_get_n_events_requested @ %def simulation_set_n_events_requested @ %def simulation_get_n_events_requested @ Generate the number of events that has been set by [[simulation_set_n_events_requested]]. First select a process and a component set, then generate an event for that process and factorize the quantum state. The pair of random numbers can be used for factorization. When generating events, we drop all configurations where the event is marked as incomplete. This happens if the event fails cuts. In fact, such events are dropped already by the sampler if unweighting is in effect, so this can happen only for weighted events. By setting a limit given by [[sample_max_tries]] (user parameter), we can avoid an endless loop. The [[begin_it]] and [[end_it]] limits are equal to 1 and the number of events, repspectively, in serial mode, but differ for MPI mode. TODO: When reading from file, event transforms cannot be applied because the process instance will not be complete. (?) <>= procedure :: generate => simulation_generate <>= subroutine simulation_generate (simulation, es_array) class(simulation_t), intent(inout), target :: simulation type(event_stream_array_t), intent(inout), optional :: es_array integer :: begin_it, end_it integer :: i, j, k call simulation%before_first_event (begin_it, end_it, es_array) do i = begin_it, end_it call simulation%next_event (es_array) end do call simulation%after_last_event (begin_it, end_it) end subroutine simulation_generate @ %def simulation_generate @ The header of the event loop: with all necessary information present in the [[simulation]] and [[es_array]] objects, and given a number of events [[n]] to generate, we prepare for actually generating/reading/writing events. The procedure returns the real iteration bounds [[begin_it]] and [[end_it]] for the event loop. This is nontrivial only for MPI; in serial mode those are equal to 1 and to [[n_events]], respectively. <>= procedure :: before_first_event => simulation_before_first_event <>= subroutine simulation_before_first_event (simulation, begin_it, end_it, & es_array) class(simulation_t), intent(inout), target :: simulation integer, intent(out) :: begin_it integer, intent(out) :: end_it type(event_stream_array_t), intent(inout), optional :: es_array integer :: n_evt_requested logical :: has_input integer :: n_events_print logical :: is_leading_order logical :: is_weighted logical :: is_polarized n_evt_requested = simulation%n_evt_requested n_events_print = n_evt_requested * simulation%get_n_nlo_entries (1) is_leading_order = (n_events_print == n_evt_requested) has_input = .false. if (present (es_array)) has_input = es_array%has_input () is_weighted = .not. simulation%entry(1)%config%unweighted is_polarized = simulation%entry(1)%config%factorization_mode & /= FM_IGNORE_HELICITY call simulation%startup_message_generate ( & has_input = has_input, & is_weighted = is_weighted, & is_polarized = is_polarized, & is_leading_order = is_leading_order, & n_events = n_events_print) call simulation%entry%set_n (n_evt_requested) if (simulation%n_alt > 0) call simulation%alt_entry%set_n (n_evt_requested) call simulation%init_event_index () begin_it = 1 end_it = n_evt_requested <> end subroutine simulation_before_first_event @ %def simulation_before_first_event @ Keep the user informed: <>= procedure, private :: startup_message_generate & => simulation_startup_message_generate <>= subroutine simulation_startup_message_generate (simulation, & has_input, is_weighted, is_polarized, is_leading_order, n_events) class(simulation_t), intent(in) :: simulation logical, intent(in) :: has_input logical, intent(in) :: is_weighted logical, intent(in) :: is_polarized logical, intent(in) :: is_leading_order integer, intent(in) :: n_events type(string_t) :: str1, str2, str3, str4 if (has_input) then str1 = "Events: reading" else str1 = "Events: generating" end if if (is_weighted) then str2 = "weighted" else str2 = "unweighted" end if if (is_polarized) then str3 = ", polarized" else str3 = ", unpolarized" end if str4 = "" if (.not. is_leading_order) str4 = " NLO" write (msg_buffer, "(A,1X,I0,1X,A,1X,A)") char (str1), n_events, & char (str2) // char(str3) // char(str4), "events ..." call msg_message () write (msg_buffer, "(A,1x,A)") "Events: event normalization mode", & char (event_normalization_string (simulation%norm_mode)) call msg_message () end subroutine simulation_startup_message_generate @ %def simulation_startup_message_generate @ The body of the event loop: generate and process a single event. Optionally transfer the current event to one of the provided event handles, for in and/or output streams. This works for any stream for which the I/O stream type matches the event-handle type. <>= procedure :: next_event => simulation_next_event <>= subroutine simulation_next_event & (simulation, es_array, event_handle_out, event_handle_in) class(simulation_t), intent(inout) :: simulation type(event_stream_array_t), intent(inout), optional :: es_array class(event_handle_t), intent(inout), optional :: event_handle_out class(event_handle_t), intent(inout), optional :: event_handle_in type(entry_t), pointer :: current_entry logical :: generate_new logical :: passed integer :: j, k call simulation%increment_event_index () if (present (es_array)) then call simulation%read_event & (es_array, .true., generate_new, event_handle_in) else generate_new = .true. end if if (generate_new) then simulation%i_prc = simulation%select_prc () simulation%i_mci = simulation%select_mci () associate (entry => simulation%entry(simulation%i_prc)) entry%instance%i_mci = simulation%i_mci call entry%set_active_real_components () current_entry => entry%get_first () do k = 1, current_entry%count_nlo_entries () if (k > 1) then current_entry => current_entry%get_next () current_entry%particle_set => current_entry%first%particle_set current_entry%particle_set_is_valid & = current_entry%first%particle_set_is_valid end if do j = 1, simulation%n_max_tries if (.not. current_entry%valid) call msg_warning & ("Process '" // char (current_entry%process_id) // "': " // & "matrix element vanishes, no events can be generated.") call current_entry%generate (simulation%i_mci, i_nlo = k) if (signal_is_pending ()) return call simulation%counter%record_mean_and_variance & (current_entry%weight_prc, k) if (current_entry%has_valid_particle_set ()) exit end do end do if (entry%is_nlo ()) call entry%reset_nlo_counter () if (.not. entry%has_valid_particle_set ()) then write (msg_buffer, "(A,I0,A)") "Simulation: failed to & &generate valid event after ", & simulation%n_max_tries, " tries (sample_max_tries)" call msg_fatal () end if current_entry => entry%get_first () do k = 1, current_entry%count_nlo_entries () if (k > 1) current_entry => current_entry%get_next () call current_entry%set_index (simulation%get_event_index ()) call current_entry%evaluate_expressions () end do if (signal_is_pending ()) return simulation%n_dropped = entry%get_n_dropped () if (entry%passed_selection ()) then simulation%weight = entry%get_weight_ref () simulation%excess = entry%get_excess_prc () end if call simulation%counter%record & (simulation%weight, simulation%excess, simulation%n_dropped) call entry%record (simulation%i_mci) end associate else associate (entry => simulation%entry(simulation%i_prc)) call simulation%set_event_index (entry%get_index ()) call entry%accept_sqme_ref () call entry%accept_weight_ref () call entry%check () call entry%evaluate_expressions () if (signal_is_pending ()) return simulation%n_dropped = entry%get_n_dropped () if (entry%passed_selection ()) then simulation%weight = entry%get_weight_ref () simulation%excess = entry%get_excess_prc () end if call simulation%counter%record & (simulation%weight, simulation%excess, simulation%n_dropped, & from_file=.true.) call entry%record (simulation%i_mci, from_file=.true.) end associate end if call simulation%calculate_alt_entries () if (simulation%pacify) call pacify (simulation) if (signal_is_pending ()) return if (simulation%respect_selection) then passed = simulation%entry(simulation%i_prc)%passed_selection () else passed = .true. end if if (present (es_array)) then call simulation%write_event (es_array, passed, event_handle_out) end if end subroutine simulation_next_event @ %def simulation_next_event @ Cleanup after last event: compute and show summary information. <>= procedure :: after_last_event => simulation_after_last_event <>= subroutine simulation_after_last_event (simulation, begin_it, end_it) class(simulation_t), intent(inout) :: simulation integer, intent(in) :: begin_it, end_it call msg_message (" ... event sample complete.") <> if (simulation%unweighted) call simulation%show_efficiency () call simulation%counter%show_excess () call simulation%counter%show_dropped () call simulation%counter%show_mean_and_variance () end subroutine simulation_after_last_event @ %def simulation_after_last_event @ \subsubsection{MPI additions} Below, we define code chunks that differ between the serial and MPI versions. Extra logging for MPI only. <>= procedure :: activate_extra_logging => simulation_activate_extra_logging <>= subroutine simulation_activate_extra_logging (simulation) class(simulation_t), intent(in) :: simulation <> end subroutine simulation_activate_extra_logging <>= <>= logical :: mpi_logging integer :: rank, n_size call mpi_get_comm_id (n_size, rank) mpi_logging = & (simulation%local%get_sval (var_str ("$integration_method")) == "vamp2" & .and. n_size > 1) & .or. simulation%local%get_lval (var_str ("?mpi_logging")) call mpi_set_logging (mpi_logging) @ %def simulation_activate_extra_logging @ Extra subroutine to be called before the first event: <>= <>= call simulation%init_event_loop_mpi (n_evt_requested, begin_it, end_it) @ Extra subroutine to be called after the last event: <>= <>= call simulation%final_event_loop_mpi (begin_it, end_it) @ For MPI event generation, the event-loop interval (1\dots n) is split up into intervals of [[n_workers]]. <>= procedure, private :: init_event_loop_mpi => simulation_init_event_loop_mpi <>= subroutine simulation_init_event_loop_mpi & (simulation, n_events, begin_it, end_it) class(simulation_t), intent(inout) :: simulation integer, intent(in) :: n_events integer, intent(out) :: begin_it, end_it integer :: rank, n_workers call MPI_COMM_SIZE (MPI_COMM_WORLD, n_workers) if (n_workers < 2) then begin_it = 1; end_it = n_events return end if call MPI_COMM_RANK (MPI_COMM_WORLD, rank) if (rank == 0) then call compute_and_scatter_intervals (n_events, begin_it, end_it) else call retrieve_intervals (begin_it, end_it) end if !! Event index starts by 0 (before incrementing when the first event gets generated/read in). !! Proof: event_index_offset in [0, N], start_it in [1, N]. simulation%event_index_offset = simulation%event_index_offset + (begin_it - 1) call simulation%init_event_index () write (msg_buffer, "(A,I0,A,I0,A)") & & "MPI: generate events [", begin_it, ":", end_it, "]" call msg_message () contains subroutine compute_and_scatter_intervals (n_events, begin_it, end_it) integer, intent(in) :: n_events integer, intent(out) :: begin_it, end_it integer, dimension(:), allocatable :: all_begin_it, all_end_it integer :: rank, n_workers, n_events_per_worker call MPI_COMM_RANK (MPI_COMM_WORLD, rank) call MPI_COMM_SIZE (MPI_COMM_WORLD, n_workers) allocate (all_begin_it (n_workers), source = 1) allocate (all_end_it (n_workers), source = n_events) n_events_per_worker = floor (real (n_events, default) / n_workers) all_begin_it = [(1 + rank * n_events_per_worker, rank = 0, n_workers - 1)] all_end_it = [(rank * n_events_per_worker, rank = 1, n_workers)] all_end_it(n_workers) = n_events call MPI_SCATTER (all_begin_it, 1, MPI_INTEGER, begin_it, 1, MPI_INTEGER, 0, MPI_COMM_WORLD) call MPI_SCATTER (all_end_it, 1, MPI_INTEGER, end_it, 1, MPI_INTEGER, 0, MPI_COMM_WORLD) end subroutine compute_and_scatter_intervals subroutine retrieve_intervals (begin_it, end_it) integer, intent(out) :: begin_it, end_it integer :: local_begin_it, local_end_it call MPI_SCATTER (local_begin_it, 1, MPI_INTEGER, begin_it, 1, MPI_INTEGER, 0, MPI_COMM_WORLD) call MPI_SCATTER (local_end_it, 1, MPI_INTEGER, end_it, 1, MPI_INTEGER, 0, MPI_COMM_WORLD) end subroutine retrieve_intervals end subroutine simulation_init_event_loop_mpi @ %def simulation_init_event_loop_mpi @ Synchronize, reduce and collect stuff after the event loop has completed. <>= procedure, private :: final_event_loop_mpi => simulation_final_event_loop_mpi <>= subroutine simulation_final_event_loop_mpi (simulation, begin_it, end_it) class(simulation_t), intent(inout) :: simulation integer, intent(in) :: begin_it, end_it integer :: n_workers, n_events_local, n_events_global call MPI_Barrier (MPI_COMM_WORLD) call MPI_COMM_SIZE (MPI_COMM_WORLD, n_workers) if (n_workers < 2) return n_events_local = end_it - begin_it + 1 call MPI_ALLREDUCE (n_events_local, n_events_global, 1, MPI_INTEGER, MPI_SUM,& & MPI_COMM_WORLD) write (msg_buffer, "(2(A,1X,I0))") & "MPI: Number of generated events locally", n_events_local, " and in world", n_events_global call msg_message () call simulation%counter%allreduce_record () end subroutine simulation_final_event_loop_mpi @ %def simulation_final_event_loop_mpi @ \subsubsection{Alternate environments} Compute the event matrix element and weight for all alternative environments, given the current event and selected process. We first copy the particle set, then temporarily update the process core with local parameters, recalculate everything, and restore the process core. The event weight is obtained by rescaling the original event weight with the ratio of the new and old [[sqme]] values. (In particular, if the old value was zero, the weight will stay zero.) Note: this may turn out to be inefficient because we always replace all parameters and recalculate everything, once for each event and environment. However, a more fine-grained control requires more code. In any case, while we may keep multiple process cores (which stay constant for a simulation run), we still have to update the external matrix element parameters event by event. The matrix element ``object'' is present only once. <>= procedure :: calculate_alt_entries => simulation_calculate_alt_entries <>= subroutine simulation_calculate_alt_entries (simulation) class(simulation_t), intent(inout) :: simulation real(default) :: sqme_prc, weight_prc, factor real(default), dimension(:), allocatable :: sqme_alt, weight_alt integer :: n_alt, i, j i = simulation%i_prc n_alt = simulation%n_alt if (n_alt == 0) return allocate (sqme_alt (n_alt), weight_alt (n_alt)) associate (entry => simulation%entry(i)) do j = 1, n_alt if (signal_is_pending ()) return if (simulation%update_weight) then factor = entry%get_kinematical_weight () else sqme_prc = entry%get_sqme_prc () weight_prc = entry%get_weight_prc () if (sqme_prc /= 0) then factor = weight_prc / sqme_prc else factor = 0 end if end if associate (alt_entry => simulation%alt_entry(i,j)) call alt_entry%update_process (saved=.false.) call alt_entry%select & (entry%get_i_mci (), entry%get_i_term (), entry%get_channel ()) call alt_entry%fill_particle_set (entry) call alt_entry%recalculate & (update_sqme = .true., & recover_beams = simulation%recover_beams, & weight_factor = factor) if (signal_is_pending ()) return call alt_entry%accept_sqme_prc () call alt_entry%update_normalization () call alt_entry%accept_weight_prc () call alt_entry%check () call alt_entry%set_index (simulation%get_event_index ()) call alt_entry%evaluate_expressions () if (signal_is_pending ()) return sqme_alt(j) = alt_entry%get_sqme_ref () if (alt_entry%passed_selection ()) then weight_alt(j) = alt_entry%get_weight_ref () end if end associate end do call entry%update_process (saved=.false.) call entry%set (sqme_alt = sqme_alt, weight_alt = weight_alt) call entry%check () call entry%store_alt_values () end associate end subroutine simulation_calculate_alt_entries @ %def simulation_calculate_alt_entries @ These routines take care of temporary parameter redefinitions that we want to take effect while recalculating the matrix elements. We extract the core(s) of the processes that we are simulating, apply the changes, and make sure that the changes are actually used. This is the duty of [[dispatch_core_update]]. When done, we restore the original versions using [[dispatch_core_restore]]. <>= procedure :: update_processes => simulation_update_processes procedure :: restore_processes => simulation_restore_processes <>= subroutine simulation_update_processes (simulation, & model, qcd, helicity_selection) class(simulation_t), intent(inout) :: simulation class(model_data_t), intent(in), optional, target :: model type(qcd_t), intent(in), optional :: qcd type(helicity_selection_t), intent(in), optional :: helicity_selection integer :: i do i = 1, simulation%n_prc call simulation%entry(i)%update_process & (model, qcd, helicity_selection) end do end subroutine simulation_update_processes subroutine simulation_restore_processes (simulation) class(simulation_t), intent(inout) :: simulation integer :: i do i = 1, simulation%n_prc call simulation%entry(i)%restore_process () end do end subroutine simulation_restore_processes @ %def simulation_update_processes @ %def simulation_restore_processes @ \subsubsection{Rescan-Events Loop} Rescan an undefined number of events. If [[update_event]] or [[update_sqme]] is set, we have to recalculate the event, starting from the particle set. If the latter is set, this includes the squared matrix element (i.e., the amplitude is evaluated). Otherwise, only kinematics and observables derived from it are recovered. If any of the update flags is set, we will come up with separate [[sqme_prc]] and [[weight_prc]] values. (The latter is only distinct if [[update_weight]] is set.) Otherwise, we accept the reference values. <>= procedure :: rescan => simulation_rescan <>= subroutine simulation_rescan (simulation, n, es_array, global) class(simulation_t), intent(inout) :: simulation integer, intent(in) :: n type(event_stream_array_t), intent(inout) :: es_array type(rt_data_t), intent(inout) :: global type(qcd_t) :: qcd type(string_t) :: str1, str2, str3 logical :: complete, check_match str1 = "Rescanning" if (simulation%entry(1)%config%unweighted) then str2 = "unweighted" else str2 = "weighted" end if simulation%n_evt_requested = n call simulation%entry%set_n (n) if (simulation%update_sqme .or. simulation%update_weight) then call dispatch_qcd (qcd, global%get_var_list_ptr (), global%os_data) call simulation%update_processes & (global%model, qcd, global%get_helicity_selection ()) str3 = "(process parameters updated) " else str3 = "" end if write (msg_buffer, "(A,1x,A,1x,A,A,A)") char (str1), char (str2), & "events ", char (str3), "..." call msg_message () call simulation%init_event_index () check_match = .not. global%var_list%get_lval (var_str ("?rescan_force")) do call simulation%increment_event_index () call simulation%read_event (es_array, .false., complete) if (complete) exit if (simulation%update_event & .or. simulation%update_sqme & .or. simulation%update_weight) then call simulation%recalculate (check_match = check_match) if (signal_is_pending ()) return associate (entry => simulation%entry(simulation%i_prc)) call entry%update_normalization () if (simulation%update_event) then call entry%evaluate_transforms () end if call entry%check () call entry%evaluate_expressions () if (signal_is_pending ()) return simulation%n_dropped = entry%get_n_dropped () simulation%weight = entry%get_weight_prc () call simulation%counter%record & (simulation%weight, n_dropped=simulation%n_dropped, from_file=.true.) call entry%record (simulation%i_mci, from_file=.true.) end associate else associate (entry => simulation%entry(simulation%i_prc)) call entry%accept_sqme_ref () call entry%accept_weight_ref () call entry%check () call entry%evaluate_expressions () if (signal_is_pending ()) return simulation%n_dropped = entry%get_n_dropped () simulation%weight = entry%get_weight_ref () call simulation%counter%record & (simulation%weight, n_dropped=simulation%n_dropped, from_file=.true.) call entry%record (simulation%i_mci, from_file=.true.) end associate end if call simulation%calculate_alt_entries () if (signal_is_pending ()) return call simulation%write_event (es_array) end do call simulation%counter%show_dropped () if (simulation%update_sqme .or. simulation%update_weight) then call simulation%restore_processes () end if end subroutine simulation_rescan @ %def simulation_rescan @ \subsubsection{Event index} Here we handle the event index that is kept in the simulation record. The event index is valid for the current sample. When generating or reading events, we initialize the index with the offset that the user provides (if any) and increment it for each event that is generated or read from file. The event index is stored in the event-entry that is current for the event. If an event on file comes with its own index, that index overwrites the predefined one and also resets the index within the simulation record. The event index is not connected to the [[counter]] object. The counter is supposed to collect statistical information. The event index is a user-level object that is visible in event records and analysis expressions. <>= procedure :: init_event_index => simulation_init_event_index procedure :: increment_event_index => simulation_increment_event_index procedure :: set_event_index => simulation_set_event_index procedure :: get_event_index => simulation_get_event_index <>= subroutine simulation_init_event_index (simulation) class(simulation_t), intent(inout) :: simulation call simulation%set_event_index (simulation%event_index_offset) end subroutine simulation_init_event_index subroutine simulation_increment_event_index (simulation) class(simulation_t), intent(inout) :: simulation if (simulation%event_index_set) then simulation%event_index = simulation%event_index + 1 end if end subroutine simulation_increment_event_index subroutine simulation_set_event_index (simulation, i) class(simulation_t), intent(inout) :: simulation integer, intent(in) :: i simulation%event_index = i simulation%event_index_set = .true. end subroutine simulation_set_event_index function simulation_get_event_index (simulation) result (i) class(simulation_t), intent(in) :: simulation integer :: i if (simulation%event_index_set) then i = simulation%event_index else i = 0 end if end function simulation_get_event_index @ %def simulation_init_event_index @ %def simulation_increment_event_index @ %def simulation_set_event_index @ %def simulation_get_event_index @ \subsection{Direct event access} If we want to retrieve event information, we should expose the currently selected event [[entry]] within the simulation object. We recall that this is an extension of the (generic) [[event]] type. Assuming that we will restrict this to read access, we return a pointer. <>= procedure :: get_process_index => simulation_get_process_index procedure :: get_event_ptr => simulation_get_event_ptr <>= function simulation_get_process_index (simulation) result (i_prc) class(simulation_t), intent(in), target :: simulation integer :: i_prc i_prc = simulation%i_prc end function simulation_get_process_index function simulation_get_event_ptr (simulation) result (event) class(simulation_t), intent(in), target :: simulation class(event_t), pointer :: event event => simulation%entry(simulation%i_prc) end function simulation_get_event_ptr @ %def simulation_get_process_index @ %def simulation_get_event_ptr @ \subsection{Event Stream I/O} Write an event to a generic [[eio]] event stream. The process index must be selected, or the current index must be available. <>= generic :: write_event => write_event_eio procedure :: write_event_eio => simulation_write_event_eio <>= subroutine simulation_write_event_eio (object, eio, i_prc) class(simulation_t), intent(in) :: object class(eio_t), intent(inout) :: eio integer, intent(in), optional :: i_prc logical :: increased integer :: current if (present (i_prc)) then current = i_prc else current = object%i_prc end if if (current > 0) then if (object%split_n_evt > 0 .and. object%counter%total > 1) then if (mod (object%counter%total, object%split_n_evt) == 1) then call eio%split_out () end if else if (object%split_n_kbytes > 0) then call eio%update_split_count (increased) if (increased) call eio%split_out () end if call eio%output (object%entry(current)%event_t, current, pacify = object%pacify) else call msg_fatal ("Simulation: write event: no process selected") end if end subroutine simulation_write_event_eio @ %def simulation_write_event @ Read an event from a generic [[eio]] event stream. The event stream element must specify the process within the sample ([[i_prc]]), the MC group for this process ([[i_mci]]), the selected term ([[i_term]]), the selected MC integration [[channel]], and the particle set of the event. We may encounter EOF, which we indicate by storing 0 for the process index [[i_prc]]. An I/O error will be reported, and we also abort reading. <>= generic :: read_event => read_event_eio procedure :: read_event_eio => simulation_read_event_eio <>= subroutine simulation_read_event_eio (object, eio) class(simulation_t), intent(inout) :: object class(eio_t), intent(inout) :: eio integer :: iostat, current call eio%input_i_prc (current, iostat) select case (iostat) case (0) object%i_prc = current call eio%input_event (object%entry(current)%event_t, iostat) end select select case (iostat) case (:-1) object%i_prc = 0 object%i_mci = 0 case (1:) call msg_error ("Reading events: I/O error, aborting read") object%i_prc = 0 object%i_mci = 0 case default object%i_mci = object%entry(current)%get_i_mci () end select end subroutine simulation_read_event_eio @ %def simulation_read_event @ \subsection{Event Stream Array} Write an event using an array of event I/O streams. The process index must be selected, or the current index must be available. <>= generic :: write_event => write_event_es_array procedure :: write_event_es_array => simulation_write_event_es_array <>= subroutine simulation_write_event_es_array & (object, es_array, passed, event_handle) class(simulation_t), intent(in), target :: object class(event_stream_array_t), intent(inout) :: es_array logical, intent(in), optional :: passed class(event_handle_t), intent(inout), optional :: event_handle integer :: i_prc, event_index integer :: i type(entry_t), pointer :: current_entry i_prc = object%i_prc if (i_prc > 0) then event_index = object%counter%total current_entry => object%entry(i_prc)%get_first () do i = 1, current_entry%count_nlo_entries () if (i > 1) current_entry => current_entry%get_next () call es_array%output (current_entry%event_t, i_prc, & event_index, & passed = passed, & pacify = object%pacify, & event_handle = event_handle) end do else call msg_fatal ("Simulation: write event: no process selected") end if end subroutine simulation_write_event_es_array @ %def simulation_write_event @ Read an event using an array of event I/O streams. Reading is successful if there is an input stream within the array, and if a valid event can be read from that stream. If there is a stream, but EOF is passed when reading the first item, we switch the channel to output and return failure but no error message, such that new events can be appended to that stream. <>= generic :: read_event => read_event_es_array procedure :: read_event_es_array => simulation_read_event_es_array <>= subroutine simulation_read_event_es_array & (object, es_array, enable_switch, fail, event_handle) class(simulation_t), intent(inout), target :: object class(event_stream_array_t), intent(inout), target :: es_array logical, intent(in) :: enable_switch logical, intent(out) :: fail class(event_handle_t), intent(inout), optional :: event_handle integer :: iostat, i_prc type(entry_t), pointer :: current_entry => null () integer :: i if (es_array%has_input ()) then fail = .false. call es_array%input_i_prc (i_prc, iostat) select case (iostat) case (0) object%i_prc = i_prc current_entry => object%entry(i_prc) do i = 1, current_entry%count_nlo_entries () if (i > 1) then call es_array%skip_eio_entry (iostat) current_entry => current_entry%get_next () end if call current_entry%set_index (object%get_event_index ()) call es_array%input_event & (current_entry%event_t, iostat, event_handle) end do case (:-1) write (msg_buffer, "(A,1x,I0,1x,A)") & "... event file terminates after", & object%counter%read, "events." call msg_message () if (enable_switch) then call es_array%switch_inout () write (msg_buffer, "(A,1x,I0,1x,A)") & "Generating remaining ", & object%n_evt_requested - object%counter%read, "events ..." call msg_message () end if fail = .true. return end select select case (iostat) case (0) object%i_mci = object%entry(i_prc)%get_i_mci () case default write (msg_buffer, "(A,1x,I0,1x,A)") & "Reading events: I/O error, aborting read after", & object%counter%read, "events." call msg_error () object%i_prc = 0 object%i_mci = 0 fail = .true. end select else fail = .true. end if end subroutine simulation_read_event_es_array @ %def simulation_read_event @ \subsection{Recover event} Recalculate the process instance contents, given an event with known particle set. The indices for MC, term, and channel must be already set. The [[recalculate]] method of the selected entry will import the result into [[sqme_prc]] and [[weight_prc]]. If [[recover_phs]] is set (and false), do not attempt any phase-space calculation. Useful if we need only matrix elements (esp. testing); this flag is not stored in the simulation record. <>= procedure :: recalculate => simulation_recalculate <>= subroutine simulation_recalculate (simulation, recover_phs, check_match) class(simulation_t), intent(inout) :: simulation logical, intent(in), optional :: recover_phs logical, intent(in), optional :: check_match integer :: i_prc, i_comp, i_term, k integer :: i_mci, i_mci0, i_mci1 integer, dimension(:), allocatable :: i_terms logical :: success i_prc = simulation%i_prc associate (entry => simulation%entry(i_prc)) if (entry%selected_i_mci /= 0) then i_mci0 = entry%selected_i_mci i_mci1 = i_mci0 else i_mci0 = 1 i_mci1 = entry%process%get_n_mci () end if SCAN_COMP: do i_mci = i_mci0, i_mci1 i_comp = entry%process%get_master_component (i_mci) call entry%process%reset_selected_cores () call entry%process%select_components ([i_comp]) i_terms = entry%process%get_component_i_terms (i_comp) SCAN_TERM: do k = 1, size (i_terms) i_term = i_terms(k) call entry%select (i_mci, i_term, entry%selected_channel) if (entry%selected_i_term /= 0 & .and. entry%selected_i_term /= i_term) cycle SCAN_TERM call entry%select (i_mci, i_term, entry%selected_channel) if (simulation%update_weight) then call entry%recalculate & (update_sqme = simulation%update_sqme, & recover_beams = simulation%recover_beams, & recover_phs = recover_phs, & weight_factor = entry%get_kinematical_weight (), & check_match = check_match, & success = success) else call entry%recalculate & (update_sqme = simulation%update_sqme, & recover_beams = simulation%recover_beams, & recover_phs = recover_phs, & check_match = check_match, & success = success) end if if (success) exit SCAN_COMP end do SCAN_TERM deallocate (i_terms) end do SCAN_COMP if (.not. success) then call entry%write () call msg_fatal ("Simulation/recalculate: & &event could not be matched to the specified process") end if end associate end subroutine simulation_recalculate @ %def simulation_recalculate @ \subsection{Extract contents of the simulation object} Return the MD5 sum that summarizes configuration and integration (but not the event file). Used for initializing the event streams. <>= procedure :: get_md5sum_prc => simulation_get_md5sum_prc procedure :: get_md5sum_cfg => simulation_get_md5sum_cfg procedure :: get_md5sum_alt => simulation_get_md5sum_alt <>= function simulation_get_md5sum_prc (simulation) result (md5sum) class(simulation_t), intent(in) :: simulation character(32) :: md5sum md5sum = simulation%md5sum_prc end function simulation_get_md5sum_prc function simulation_get_md5sum_cfg (simulation) result (md5sum) class(simulation_t), intent(in) :: simulation character(32) :: md5sum md5sum = simulation%md5sum_cfg end function simulation_get_md5sum_cfg function simulation_get_md5sum_alt (simulation, i) result (md5sum) class(simulation_t), intent(in) :: simulation integer, intent(in) :: i character(32) :: md5sum md5sum = simulation%md5sum_alt(i) end function simulation_get_md5sum_alt @ %def simulation_get_md5sum_prc @ %def simulation_get_md5sum_cfg @ Return data that may be useful for writing event files. Usually we can refer to a previously integrated process, for which we can fetch a process pointer. Occasionally, we do not have this because we are just rescanning an externally generated file without calculation. For that situation, we generate our local beam data object using the current enviroment, or, in simple cases, just fetch the necessary data from the process definition and environment. <>= procedure :: get_data => simulation_get_data <>= function simulation_get_data (simulation, alt) result (sdata) class(simulation_t), intent(in) :: simulation logical, intent(in), optional :: alt type(event_sample_data_t) :: sdata type(process_t), pointer :: process type(beam_data_t), pointer :: beam_data type(beam_structure_t), pointer :: beam_structure type(flavor_t), dimension(:), allocatable :: flv integer :: n, i logical :: enable_alt, construct_beam_data real(default) :: sqrts class(model_data_t), pointer :: model logical :: decay_rest_frame type(string_t) :: process_id enable_alt = .true.; if (present (alt)) enable_alt = alt if (debug_on) call msg_debug (D_CORE, "simulation_get_data") if (debug_on) call msg_debug (D_CORE, "alternative setup", enable_alt) if (enable_alt) then call sdata%init (simulation%n_prc, simulation%n_alt) do i = 1, simulation%n_alt sdata%md5sum_alt(i) = simulation%get_md5sum_alt (i) end do else call sdata%init (simulation%n_prc) end if sdata%unweighted = simulation%unweighted sdata%negative_weights = simulation%negative_weights sdata%norm_mode = simulation%norm_mode process => simulation%entry(1)%get_process_ptr () if (associated (process)) then beam_data => process%get_beam_data_ptr () construct_beam_data = .false. else n = simulation%entry(1)%n_in sqrts = simulation%local%get_sqrts () beam_structure => simulation%local%beam_structure call beam_structure%check_against_n_in (n, construct_beam_data) if (construct_beam_data) then allocate (beam_data) model => simulation%local%model decay_rest_frame = & simulation%local%get_lval (var_str ("?decay_rest_frame")) call beam_data%init_structure (beam_structure, & sqrts, model, decay_rest_frame) else beam_data => null () end if end if if (associated (beam_data)) then n = beam_data%get_n_in () sdata%n_beam = n allocate (flv (n)) flv = beam_data%get_flavor () sdata%pdg_beam(:n) = flv%get_pdg () sdata%energy_beam(:n) = beam_data%get_energy () if (construct_beam_data) deallocate (beam_data) else n = simulation%entry(1)%n_in sdata%n_beam = n process_id = simulation%entry(1)%process_id call simulation%local%prclib%get_pdg_in_1 & (process_id, sdata%pdg_beam(:n)) sdata%energy_beam(:n) = sqrts / n end if do i = 1, simulation%n_prc if (.not. simulation%entry(i)%valid) cycle process => simulation%entry(i)%get_process_ptr () if (associated (process)) then sdata%proc_num_id(i) = process%get_num_id () else process_id = simulation%entry(i)%process_id sdata%proc_num_id(i) = simulation%local%prclib%get_num_id (process_id) end if if (sdata%proc_num_id(i) == 0) sdata%proc_num_id(i) = i if (simulation%entry(i)%has_integral) then sdata%cross_section(i) = simulation%entry(i)%integral sdata%error(i) = simulation%entry(i)%error end if end do sdata%total_cross_section = sum (sdata%cross_section) sdata%md5sum_prc = simulation%get_md5sum_prc () sdata%md5sum_cfg = simulation%get_md5sum_cfg () if (simulation%split_n_evt > 0 .or. simulation%split_n_kbytes > 0) then sdata%split_n_evt = simulation%split_n_evt sdata%split_n_kbytes = simulation%split_n_kbytes sdata%split_index = simulation%split_index end if end function simulation_get_data @ %def simulation_get_data @ Return a default name for the current event sample. This is the process ID of the first process. <>= procedure :: get_default_sample_name => simulation_get_default_sample_name <>= function simulation_get_default_sample_name (simulation) result (sample) class(simulation_t), intent(in) :: simulation type(string_t) :: sample type(process_t), pointer :: process sample = "whizard" if (simulation%n_prc > 0) then process => simulation%entry(1)%get_process_ptr () if (associated (process)) then sample = process%get_id () end if end if end function simulation_get_default_sample_name @ %def simulation_get_default_sample_name @ <>= procedure :: is_valid => simulation_is_valid <>= function simulation_is_valid (simulation) result (valid) class(simulation_t), intent(inout) :: simulation logical :: valid valid = simulation%valid end function simulation_is_valid @ %def simulation_is_valid @ Return the hard-interaction particle set for event entry [[i_prc]]. <>= procedure :: get_hard_particle_set => simulation_get_hard_particle_set <>= function simulation_get_hard_particle_set (simulation, i_prc) result (pset) class(simulation_t), intent(in) :: simulation integer, intent(in) :: i_prc type(particle_set_t) :: pset call simulation%entry(i_prc)%get_hard_particle_set (pset) end function simulation_get_hard_particle_set @ %def simulation_get_hard_particle_set @ \subsection{Auxiliary} Call pacify: eliminate numerical noise. <>= public :: pacify <>= interface pacify module procedure pacify_simulation end interface <>= subroutine pacify_simulation (simulation) class(simulation_t), intent(inout) :: simulation integer :: i, j i = simulation%i_prc if (i > 0) then call pacify (simulation%entry(i)) do j = 1, simulation%n_alt call pacify (simulation%alt_entry(i,j)) end do end if end subroutine pacify_simulation @ %def pacify_simulation @ Manually evaluate expressions for the currently selected process. This is used only in the unit tests. <>= procedure :: evaluate_expressions => simulation_evaluate_expressions <>= subroutine simulation_evaluate_expressions (simulation) class(simulation_t), intent(inout) :: simulation call simulation%entry(simulation%i_prc)%evaluate_expressions () end subroutine simulation_evaluate_expressions @ %def simulation_evaluate_expressions @ Manually evaluate event transforms for the currently selected process. This is used only in the unit tests. <>= procedure :: evaluate_transforms => simulation_evaluate_transforms <>= subroutine simulation_evaluate_transforms (simulation) class(simulation_t), intent(inout) :: simulation associate (entry => simulation%entry(simulation%i_prc)) call entry%evaluate_transforms () end associate end subroutine simulation_evaluate_transforms @ %def simulation_evaluate_transforms @ \subsection{Unit tests} Test module, followed by the stand-alone unit-test procedures. <<[[simulations_ut.f90]]>>= <> module simulations_ut use unit_tests use simulations_uti <> <> contains <> end module simulations_ut @ %def simulations_ut @ <<[[simulations_uti.f90]]>>= <> module simulations_uti <> use kinds, only: i64 <> use io_units use format_defs, only: FMT_10, FMT_12 use ifiles use lexers use parser use lorentz use flavors use interactions, only: reset_interaction_counter use process_libraries, only: process_library_t use prclib_stacks use phs_forests use event_base, only: generic_event_t use event_base, only: event_callback_t use particles, only: particle_set_t use eio_data use eio_base use eio_direct, only: eio_direct_t use eio_raw use eio_ascii use eio_dump use eio_callback use eval_trees use model_data, only: model_data_t use models use rt_data use event_streams use decays_ut, only: prepare_testbed use process, only: process_t use process_stacks, only: process_entry_t use process_configurations_ut, only: prepare_test_library use compilations, only: compile_library use integrations, only: integrate_process use simulations use restricted_subprocesses_uti, only: prepare_resonance_test_library <> <> <> contains <> <> end module simulations_uti @ %def simulations_uti @ API: driver for the unit tests below. <>= public :: simulations_test <>= subroutine simulations_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine simulations_test @ %def simulations_test @ \subsubsection{Initialization} Initialize a [[simulation_t]] object, including the embedded event records. <>= call test (simulations_1, "simulations_1", & "initialization", & u, results) <>= public :: simulations_1 <>= subroutine simulations_1 (u) integer, intent(in) :: u type(string_t) :: libname, procname1, procname2 type(rt_data_t), target :: global type(simulation_t), target :: simulation write (u, "(A)") "* Test output: simulations_1" write (u, "(A)") "* Purpose: initialize simulation" write (u, "(A)") write (u, "(A)") "* Initialize processes" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) libname = "simulation_1a" procname1 = "simulation_1p" call prepare_test_library (global, libname, 1, [procname1]) call compile_library (libname, global) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("single"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_log (var_str ("?recover_beams"), & .false., is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%it_list%init ([1], [1000]) call global%set_string (var_str ("$run_id"), & var_str ("simulations1"), is_known = .true.) call integrate_process (procname1, global, local_stack=.true.) procname2 = "sim_extra" call prepare_test_library (global, libname, 1, [procname2]) call compile_library (libname, global) call global%set_string (var_str ("$run_id"), & var_str ("simulations2"), is_known = .true.) write (u, "(A)") "* Initialize event generation" write (u, "(A)") call global%set_string (var_str ("$sample"), & var_str ("sim1"), is_known = .true.) call integrate_process (procname2, global, local_stack=.true.) call simulation%init ([procname1, procname2], .false., .true., global) call simulation%init_process_selector () call simulation%write (u) write (u, "(A)") write (u, "(A)") "* Write the event record for the first process" write (u, "(A)") call simulation%write_event (u, i_prc = 1) write (u, "(A)") write (u, "(A)") "* Cleanup" call simulation%final () call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: simulations_1" end subroutine simulations_1 @ %def simulations_1 @ \subsubsection{Weighted events} Generate events for a single process. <>= call test (simulations_2, "simulations_2", & "weighted events", & u, results) <>= public :: simulations_2 <>= subroutine simulations_2 (u) integer, intent(in) :: u type(string_t) :: libname, procname1 type(rt_data_t), target :: global type(simulation_t), target :: simulation type(event_sample_data_t) :: data write (u, "(A)") "* Test output: simulations_2" write (u, "(A)") "* Purpose: generate events for a single process" write (u, "(A)") write (u, "(A)") "* Initialize processes" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) libname = "simulation_2a" procname1 = "simulation_2p" call prepare_test_library (global, libname, 1, [procname1]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_events"), .true., intrinsic = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("single"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_log (var_str ("?recover_beams"), & .false., is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%it_list%init ([1], [1000]) call global%set_string (var_str ("$run_id"), & var_str ("simulations1"), is_known = .true.) call integrate_process (procname1, global, local_stack=.true.) write (u, "(A)") "* Initialize event generation" write (u, "(A)") call global%set_log (var_str ("?unweighted"), & .false., is_known = .true.) call simulation%init ([procname1], .true., .true., global) call simulation%init_process_selector () data = simulation%get_data () call data%write (u) write (u, "(A)") write (u, "(A)") "* Generate three events" write (u, "(A)") call simulation%set_n_events_requested (3) call simulation%generate () call simulation%write (u) write (u, "(A)") write (u, "(A)") "* Write the event record for the last event" write (u, "(A)") call simulation%write_event (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call simulation%final () call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: simulations_2" end subroutine simulations_2 @ %def simulations_2 @ \subsubsection{Unweighted events} Generate events for a single process. <>= call test (simulations_3, "simulations_3", & "unweighted events", & u, results) <>= public :: simulations_3 <>= subroutine simulations_3 (u) integer, intent(in) :: u type(string_t) :: libname, procname1 type(rt_data_t), target :: global type(simulation_t), target :: simulation type(event_sample_data_t) :: data write (u, "(A)") "* Test output: simulations_3" write (u, "(A)") "* Purpose: generate unweighted events & &for a single process" write (u, "(A)") write (u, "(A)") "* Initialize processes" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) libname = "simulation_3a" procname1 = "simulation_3p" call prepare_test_library (global, libname, 1, [procname1]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_events"), .true., intrinsic = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("single"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_log (var_str ("?recover_beams"), & .false., is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%it_list%init ([1], [1000]) call global%set_string (var_str ("$run_id"), & var_str ("simulations1"), is_known = .true.) call integrate_process (procname1, global, local_stack=.true.) write (u, "(A)") "* Initialize event generation" write (u, "(A)") call simulation%init ([procname1], .true., .true., global) call simulation%init_process_selector () data = simulation%get_data () call data%write (u) write (u, "(A)") write (u, "(A)") "* Generate three events" write (u, "(A)") call simulation%set_n_events_requested (3) call simulation%generate () call simulation%write (u) write (u, "(A)") write (u, "(A)") "* Write the event record for the last event" write (u, "(A)") call simulation%write_event (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call simulation%final () call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: simulations_3" end subroutine simulations_3 @ %def simulations_3 @ \subsubsection{Simulating process with structure functions} Generate events for a single process. <>= call test (simulations_4, "simulations_4", & "process with structure functions", & u, results) <>= public :: simulations_4 <>= subroutine simulations_4 (u) integer, intent(in) :: u type(string_t) :: libname, procname1 type(rt_data_t), target :: global type(flavor_t) :: flv type(string_t) :: name type(simulation_t), target :: simulation type(event_sample_data_t) :: data write (u, "(A)") "* Test output: simulations_4" write (u, "(A)") "* Purpose: generate events for a single process & &with structure functions" write (u, "(A)") write (u, "(A)") "* Initialize processes" write (u, "(A)") call syntax_model_file_init () call syntax_phs_forest_init () call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) libname = "simulation_4a" procname1 = "simulation_4p" call prepare_test_library (global, libname, 1, [procname1]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_grids"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_events"), .true., intrinsic = .true.) call global%set_string (var_str ("$run_id"), & var_str ("r1"), is_known = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("wood"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("vamp"), is_known = .true.) call global%set_log (var_str ("?use_vamp_equivalences"),& .true., is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%model_set_real (var_str ("ms"), & 0._default) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_log (var_str ("?recover_beams"), & .false., is_known = .true.) call reset_interaction_counter () call flv%init (25, global%model) name = flv%get_name () call global%beam_structure%init_sf ([name, name], [1]) call global%beam_structure%set_sf (1, 1, var_str ("sf_test_1")) write (u, "(A)") "* Integrate" write (u, "(A)") call global%it_list%init ([1], [1000]) call global%set_string (var_str ("$run_id"), & var_str ("r1"), is_known = .true.) call integrate_process (procname1, global, local_stack=.true.) write (u, "(A)") "* Initialize event generation" write (u, "(A)") call global%set_log (var_str ("?unweighted"), & .false., is_known = .true.) call global%set_string (var_str ("$sample"), & var_str ("simulations4"), is_known = .true.) call simulation%init ([procname1], .true., .true., global) call simulation%init_process_selector () data = simulation%get_data () call data%write (u) write (u, "(A)") write (u, "(A)") "* Generate three events" write (u, "(A)") call simulation%set_n_events_requested (3) call simulation%generate () call simulation%write (u) write (u, "(A)") write (u, "(A)") "* Write the event record for the last event" write (u, "(A)") call simulation%write_event (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call simulation%final () call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: simulations_4" end subroutine simulations_4 @ %def simulations_4 @ \subsubsection{Event I/O} Generate event for a test process, write to file and reread. <>= call test (simulations_5, "simulations_5", & "raw event I/O", & u, results) <>= public :: simulations_5 <>= subroutine simulations_5 (u) integer, intent(in) :: u type(string_t) :: libname, procname1, sample type(rt_data_t), target :: global class(eio_t), allocatable :: eio type(simulation_t), allocatable, target :: simulation write (u, "(A)") "* Test output: simulations_5" write (u, "(A)") "* Purpose: generate events for a single process" write (u, "(A)") "* write to file and reread" write (u, "(A)") write (u, "(A)") "* Initialize processes" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) libname = "simulation_5a" procname1 = "simulation_5p" call prepare_test_library (global, libname, 1, [procname1]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_events"), .true., intrinsic = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("single"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_log (var_str ("?recover_beams"), & .false., is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%it_list%init ([1], [1000]) call global%set_string (var_str ("$run_id"), & var_str ("simulations5"), is_known = .true.) call integrate_process (procname1, global, local_stack=.true.) write (u, "(A)") "* Initialize event generation" write (u, "(A)") call global%set_log (var_str ("?unweighted"), & .false., is_known = .true.) sample = "simulations5" call global%set_string (var_str ("$sample"), & sample, is_known = .true.) allocate (simulation) call simulation%init ([procname1], .true., .true., global) call simulation%init_process_selector () write (u, "(A)") "* Initialize raw event file" write (u, "(A)") allocate (eio_raw_t :: eio) call eio%init_out (sample) write (u, "(A)") "* Generate an event" write (u, "(A)") call simulation%set_n_events_requested (1) call simulation%generate () call simulation%write_event (u) call simulation%write_event (eio) call eio%final () deallocate (eio) call simulation%final () deallocate (simulation) write (u, "(A)") write (u, "(A)") "* Re-read the event from file" write (u, "(A)") call global%set_log (var_str ("?update_sqme"), & .true., is_known = .true.) call global%set_log (var_str ("?update_weight"), & .true., is_known = .true.) call global%set_log (var_str ("?recover_beams"), & .false., is_known = .true.) allocate (simulation) call simulation%init ([procname1], .true., .true., global) call simulation%init_process_selector () allocate (eio_raw_t :: eio) call eio%init_in (sample) call simulation%read_event (eio) call simulation%write_event (u) write (u, "(A)") write (u, "(A)") "* Recalculate process instance" write (u, "(A)") call simulation%recalculate () call simulation%evaluate_expressions () call simulation%write_event (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio%final () call simulation%final () call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: simulations_5" end subroutine simulations_5 @ %def simulations_5 @ \subsubsection{Event I/O} Generate event for a real process with structure functions, write to file and reread. <>= call test (simulations_6, "simulations_6", & "raw event I/O with structure functions", & u, results) <>= public :: simulations_6 <>= subroutine simulations_6 (u) integer, intent(in) :: u type(string_t) :: libname, procname1, sample type(rt_data_t), target :: global class(eio_t), allocatable :: eio type(simulation_t), allocatable, target :: simulation type(flavor_t) :: flv type(string_t) :: name write (u, "(A)") "* Test output: simulations_6" write (u, "(A)") "* Purpose: generate events for a single process" write (u, "(A)") "* write to file and reread" write (u, "(A)") write (u, "(A)") "* Initialize process and integrate" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) libname = "simulation_6" procname1 = "simulation_6p" call prepare_test_library (global, libname, 1, [procname1]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_grids"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_events"), .true., intrinsic = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("wood"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("vamp"), is_known = .true.) call global%set_log (var_str ("?use_vamp_equivalences"),& .true., is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_log (var_str ("?recover_beams"), & .false., is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%model_set_real (var_str ("ms"), & 0._default) call flv%init (25, global%model) name = flv%get_name () call global%beam_structure%init_sf ([name, name], [1]) call global%beam_structure%set_sf (1, 1, var_str ("sf_test_1")) call global%it_list%init ([1], [1000]) call global%set_string (var_str ("$run_id"), & var_str ("r1"), is_known = .true.) call integrate_process (procname1, global, local_stack=.true.) write (u, "(A)") "* Initialize event generation" write (u, "(A)") call reset_interaction_counter () call global%set_log (var_str ("?unweighted"), & .false., is_known = .true.) sample = "simulations6" call global%set_string (var_str ("$sample"), & sample, is_known = .true.) allocate (simulation) call simulation%init ([procname1], .true., .true., global) call simulation%init_process_selector () write (u, "(A)") "* Initialize raw event file" write (u, "(A)") allocate (eio_raw_t :: eio) call eio%init_out (sample) write (u, "(A)") "* Generate an event" write (u, "(A)") call simulation%set_n_events_requested (1) call simulation%generate () call pacify (simulation) call simulation%write_event (u, verbose = .true., testflag = .true.) call simulation%write_event (eio) call eio%final () deallocate (eio) call simulation%final () deallocate (simulation) write (u, "(A)") write (u, "(A)") "* Re-read the event from file" write (u, "(A)") call reset_interaction_counter () call global%set_log (var_str ("?update_sqme"), & .true., is_known = .true.) call global%set_log (var_str ("?update_weight"), & .true., is_known = .true.) allocate (simulation) call simulation%init ([procname1], .true., .true., global) call simulation%init_process_selector () allocate (eio_raw_t :: eio) call eio%init_in (sample) call simulation%read_event (eio) call simulation%write_event (u, verbose = .true., testflag = .true.) write (u, "(A)") write (u, "(A)") "* Recalculate process instance" write (u, "(A)") call simulation%recalculate () call simulation%evaluate_expressions () call simulation%write_event (u, verbose = .true., testflag = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio%final () call simulation%final () call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: simulations_6" end subroutine simulations_6 @ %def simulations_6 @ \subsubsection{Automatic Event I/O} Generate events with raw-format event file as cache: generate, reread, append. <>= call test (simulations_7, "simulations_7", & "automatic raw event I/O", & u, results) <>= public :: simulations_7 <>= subroutine simulations_7 (u) integer, intent(in) :: u type(string_t) :: libname, procname1, sample type(rt_data_t), target :: global type(string_t), dimension(0) :: empty_string_array type(event_sample_data_t) :: data type(event_stream_array_t) :: es_array type(simulation_t), allocatable, target :: simulation type(flavor_t) :: flv type(string_t) :: name write (u, "(A)") "* Test output: simulations_7" write (u, "(A)") "* Purpose: generate events for a single process" write (u, "(A)") "* write to file and reread" write (u, "(A)") write (u, "(A)") "* Initialize process and integrate" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%init_fallback_model & (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl")) call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) libname = "simulation_7" procname1 = "simulation_7p" call prepare_test_library (global, libname, 1, [procname1]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_grids"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_events"), .true., intrinsic = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("wood"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("vamp"), is_known = .true.) call global%set_log (var_str ("?use_vamp_equivalences"),& .true., is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_log (var_str ("?recover_beams"), & .false., is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%model_set_real (var_str ("ms"), & 0._default) call flv%init (25, global%model) name = flv%get_name () call global%beam_structure%init_sf ([name, name], [1]) call global%beam_structure%set_sf (1, 1, var_str ("sf_test_1")) call global%it_list%init ([1], [1000]) call global%set_string (var_str ("$run_id"), & var_str ("r1"), is_known = .true.) call integrate_process (procname1, global, local_stack=.true.) write (u, "(A)") "* Initialize event generation" write (u, "(A)") call reset_interaction_counter () call global%set_log (var_str ("?unweighted"), & .false., is_known = .true.) sample = "simulations7" call global%set_string (var_str ("$sample"), & sample, is_known = .true.) allocate (simulation) call simulation%init ([procname1], .true., .true., global) call simulation%init_process_selector () write (u, "(A)") "* Initialize raw event file" write (u, "(A)") data%md5sum_prc = simulation%get_md5sum_prc () data%md5sum_cfg = simulation%get_md5sum_cfg () call es_array%init (sample, [var_str ("raw")], global, data) write (u, "(A)") "* Generate an event" write (u, "(A)") call simulation%set_n_events_requested (1) call simulation%generate (es_array) call es_array%final () call simulation%final () deallocate (simulation) write (u, "(A)") "* Re-read the event from file and generate another one" write (u, "(A)") call global%set_log (& var_str ("?rebuild_events"), .false., is_known = .true.) call reset_interaction_counter () allocate (simulation) call simulation%init ([procname1], .true., .true., global) call simulation%init_process_selector () data%md5sum_prc = simulation%get_md5sum_prc () data%md5sum_cfg = simulation%get_md5sum_cfg () call es_array%init (sample, empty_string_array, global, data, & input = var_str ("raw")) call simulation%set_n_events_requested (2) call simulation%generate (es_array) call pacify (simulation) call simulation%write_event (u, verbose = .true.) call es_array%final () call simulation%final () deallocate (simulation) write (u, "(A)") write (u, "(A)") "* Re-read both events from file" write (u, "(A)") call reset_interaction_counter () allocate (simulation) call simulation%init ([procname1], .true., .true., global) call simulation%init_process_selector () data%md5sum_prc = simulation%get_md5sum_prc () data%md5sum_cfg = simulation%get_md5sum_cfg () call es_array%init (sample, empty_string_array, global, data, & input = var_str ("raw")) call simulation%set_n_events_requested (2) call simulation%generate (es_array) call pacify (simulation) call simulation%write_event (u, verbose = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call es_array%final () call simulation%final () call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: simulations_7" end subroutine simulations_7 @ %def simulations_7 @ \subsubsection{Rescanning Events} Generate events and rescan the resulting raw event file. <>= call test (simulations_8, "simulations_8", & "rescan raw event file", & u, results) <>= public :: simulations_8 <>= subroutine simulations_8 (u) integer, intent(in) :: u type(string_t) :: libname, procname1, sample type(rt_data_t), target :: global type(string_t), dimension(0) :: empty_string_array type(event_sample_data_t) :: data type(event_stream_array_t) :: es_array type(simulation_t), allocatable, target :: simulation type(flavor_t) :: flv type(string_t) :: name write (u, "(A)") "* Test output: simulations_8" write (u, "(A)") "* Purpose: generate events for a single process" write (u, "(A)") "* write to file and rescan" write (u, "(A)") write (u, "(A)") "* Initialize process and integrate" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%init_fallback_model & (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl")) call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) libname = "simulation_8" procname1 = "simulation_8p" call prepare_test_library (global, libname, 1, [procname1]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_grids"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_events"), .true., intrinsic = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("wood"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("vamp"), is_known = .true.) call global%set_log (var_str ("?use_vamp_equivalences"),& .true., is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_log (var_str ("?recover_beams"), & .false., is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%model_set_real (var_str ("ms"), & 0._default) call flv%init (25, global%model) name = flv%get_name () call global%beam_structure%init_sf ([name, name], [1]) call global%beam_structure%set_sf (1, 1, var_str ("sf_test_1")) call global%it_list%init ([1], [1000]) call global%set_string (var_str ("$run_id"), & var_str ("r1"), is_known = .true.) call integrate_process (procname1, global, local_stack=.true.) write (u, "(A)") "* Initialize event generation" write (u, "(A)") call reset_interaction_counter () call global%set_log (var_str ("?unweighted"), & .false., is_known = .true.) sample = "simulations8" call global%set_string (var_str ("$sample"), & sample, is_known = .true.) allocate (simulation) call simulation%init ([procname1], .true., .true., global) call simulation%init_process_selector () write (u, "(A)") "* Initialize raw event file" write (u, "(A)") data%md5sum_prc = simulation%get_md5sum_prc () data%md5sum_cfg = simulation%get_md5sum_cfg () write (u, "(1x,A,A,A)") "MD5 sum (proc) = '", data%md5sum_prc, "'" write (u, "(1x,A,A,A)") "MD5 sum (config) = '", data%md5sum_cfg, "'" call es_array%init (sample, [var_str ("raw")], global, & data) write (u, "(A)") write (u, "(A)") "* Generate an event" write (u, "(A)") call simulation%set_n_events_requested (1) call simulation%generate (es_array) call pacify (simulation) call simulation%write_event (u, verbose = .true., testflag = .true.) call es_array%final () call simulation%final () deallocate (simulation) write (u, "(A)") write (u, "(A)") "* Re-read the event from file" write (u, "(A)") call reset_interaction_counter () allocate (simulation) call simulation%init ([procname1], .false., .false., global) call simulation%init_process_selector () data%md5sum_prc = simulation%get_md5sum_prc () data%md5sum_cfg = "" write (u, "(1x,A,A,A)") "MD5 sum (proc) = '", data%md5sum_prc, "'" write (u, "(1x,A,A,A)") "MD5 sum (config) = '", data%md5sum_cfg, "'" call es_array%init (sample, empty_string_array, global, data, & input = var_str ("raw"), input_sample = sample, allow_switch = .false.) call simulation%rescan (1, es_array, global = global) write (u, "(A)") call pacify (simulation) call simulation%write_event (u, verbose = .true., testflag = .true.) call es_array%final () call simulation%final () deallocate (simulation) write (u, "(A)") write (u, "(A)") "* Re-read again and recalculate" write (u, "(A)") call reset_interaction_counter () call global%set_log (var_str ("?update_sqme"), & .true., is_known = .true.) call global%set_log (var_str ("?update_event"), & .true., is_known = .true.) allocate (simulation) call simulation%init ([procname1], .false., .false., global) call simulation%init_process_selector () data%md5sum_prc = simulation%get_md5sum_prc () data%md5sum_cfg = "" write (u, "(1x,A,A,A)") "MD5 sum (proc) = '", data%md5sum_prc, "'" write (u, "(1x,A,A,A)") "MD5 sum (config) = '", data%md5sum_cfg, "'" call es_array%init (sample, empty_string_array, global, data, & input = var_str ("raw"), input_sample = sample, allow_switch = .false.) call simulation%rescan (1, es_array, global = global) write (u, "(A)") call pacify (simulation) call simulation%write_event (u, verbose = .true., testflag = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call es_array%final () call simulation%final () call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: simulations_8" end subroutine simulations_8 @ %def simulations_8 @ \subsubsection{Rescanning Check} Generate events and rescan with process mismatch. <>= call test (simulations_9, "simulations_9", & "rescan mismatch", & u, results) <>= public :: simulations_9 <>= subroutine simulations_9 (u) integer, intent(in) :: u type(string_t) :: libname, procname1, sample type(rt_data_t), target :: global type(string_t), dimension(0) :: empty_string_array type(event_sample_data_t) :: data type(event_stream_array_t) :: es_array type(simulation_t), allocatable, target :: simulation type(flavor_t) :: flv type(string_t) :: name logical :: error write (u, "(A)") "* Test output: simulations_9" write (u, "(A)") "* Purpose: generate events for a single process" write (u, "(A)") "* write to file and rescan" write (u, "(A)") write (u, "(A)") "* Initialize process and integrate" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%init_fallback_model & (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl")) call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) libname = "simulation_9" procname1 = "simulation_9p" call prepare_test_library (global, libname, 1, [procname1]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_grids"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_events"), .true., intrinsic = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("wood"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("vamp"), is_known = .true.) call global%set_log (var_str ("?use_vamp_equivalences"),& .true., is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_log (var_str ("?recover_beams"), & .false., is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%model_set_real (var_str ("ms"), & 0._default) call flv%init (25, global%model) name = flv%get_name () call global%beam_structure%init_sf ([name, name], [1]) call global%beam_structure%set_sf (1, 1, var_str ("sf_test_1")) call global%it_list%init ([1], [1000]) call global%set_string (var_str ("$run_id"), & var_str ("r1"), is_known = .true.) call integrate_process (procname1, global, local_stack=.true.) write (u, "(A)") "* Initialize event generation" write (u, "(A)") call reset_interaction_counter () call global%set_log (var_str ("?unweighted"), & .false., is_known = .true.) sample = "simulations9" call global%set_string (var_str ("$sample"), & sample, is_known = .true.) allocate (simulation) call simulation%init ([procname1], .true., .true., global) call simulation%init_process_selector () call simulation%write (u) write (u, "(A)") write (u, "(A)") "* Initialize raw event file" write (u, "(A)") data%md5sum_prc = simulation%get_md5sum_prc () data%md5sum_cfg = simulation%get_md5sum_cfg () write (u, "(1x,A,A,A)") "MD5 sum (proc) = '", data%md5sum_prc, "'" write (u, "(1x,A,A,A)") "MD5 sum (config) = '", data%md5sum_cfg, "'" call es_array%init (sample, [var_str ("raw")], global, & data) write (u, "(A)") write (u, "(A)") "* Generate an event" write (u, "(A)") call simulation%set_n_events_requested (1) call simulation%generate (es_array) call es_array%final () call simulation%final () deallocate (simulation) write (u, "(A)") "* Initialize event generation for different parameters" write (u, "(A)") call reset_interaction_counter () allocate (simulation) call simulation%init ([procname1, procname1], .false., .false., global) call simulation%init_process_selector () call simulation%write (u) write (u, "(A)") write (u, "(A)") "* Attempt to re-read the events (should fail)" write (u, "(A)") data%md5sum_prc = simulation%get_md5sum_prc () data%md5sum_cfg = "" write (u, "(1x,A,A,A)") "MD5 sum (proc) = '", data%md5sum_prc, "'" write (u, "(1x,A,A,A)") "MD5 sum (config) = '", data%md5sum_cfg, "'" call es_array%init (sample, empty_string_array, global, data, & input = var_str ("raw"), input_sample = sample, & allow_switch = .false., error = error) write (u, "(1x,A,L1)") "error = ", error call simulation%rescan (1, es_array, global = global) call es_array%final () call simulation%final () call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: simulations_9" end subroutine simulations_9 @ %def simulations_9 @ \subsubsection{Alternative weights} Generate an event for a single process and reweight it in a simultaneous calculation. <>= call test (simulations_10, "simulations_10", & "alternative weight", & u, results) <>= public :: simulations_10 <>= subroutine simulations_10 (u) integer, intent(in) :: u type(string_t) :: libname, procname1, expr_text type(rt_data_t), target :: global type(rt_data_t), dimension(1), target :: alt_env type(ifile_t) :: ifile type(stream_t) :: stream type(parse_tree_t) :: pt_weight type(simulation_t), target :: simulation type(event_sample_data_t) :: data write (u, "(A)") "* Test output: simulations_10" write (u, "(A)") "* Purpose: reweight event" write (u, "(A)") write (u, "(A)") "* Initialize processes" write (u, "(A)") call syntax_model_file_init () call syntax_pexpr_init () call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) libname = "simulation_10a" procname1 = "simulation_10p" call prepare_test_library (global, libname, 1, [procname1]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_grids"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_events"), .true., intrinsic = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("single"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_log (var_str ("?recover_beams"), & .false., is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%it_list%init ([1], [1000]) call global%set_string (var_str ("$run_id"), & var_str ("simulations1"), is_known = .true.) call integrate_process (procname1, global, local_stack=.true.) write (u, "(A)") "* Initialize alternative environment with custom weight" write (u, "(A)") call alt_env(1)%local_init (global) call alt_env(1)%activate () expr_text = "2" write (u, "(A,A)") "weight = ", char (expr_text) write (u, *) call ifile_clear (ifile) call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call parse_tree_init_expr (pt_weight, stream, .true.) call stream_final (stream) alt_env(1)%pn%weight_expr => pt_weight%get_root_ptr () call alt_env(1)%write_expr (u) write (u, "(A)") write (u, "(A)") "* Initialize event generation" write (u, "(A)") call global%set_log (var_str ("?unweighted"), & .false., is_known = .true.) call simulation%init ([procname1], .true., .true., global, alt_env=alt_env) call simulation%init_process_selector () data = simulation%get_data () call data%write (u) write (u, "(A)") write (u, "(A)") "* Generate an event" write (u, "(A)") call simulation%set_n_events_requested (1) call simulation%generate () call simulation%write (u) write (u, "(A)") write (u, "(A)") "* Write the event record for the last event" write (u, "(A)") call simulation%write_event (u) write (u, "(A)") write (u, "(A)") "* Write the event record for the alternative setup" write (u, "(A)") call simulation%write_alt_event (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call simulation%final () call global%final () call syntax_model_file_final () call syntax_pexpr_final () write (u, "(A)") write (u, "(A)") "* Test output end: simulations_10" end subroutine simulations_10 @ %def simulations_10 @ \subsubsection{Decays} Generate an event with subsequent partonic decays. <>= call test (simulations_11, "simulations_11", & "decay", & u, results) <>= public :: simulations_11 <>= subroutine simulations_11 (u) integer, intent(in) :: u type(rt_data_t), target :: global type(prclib_entry_t), pointer :: lib type(string_t) :: prefix, procname1, procname2 type(simulation_t), target :: simulation write (u, "(A)") "* Test output: simulations_11" write (u, "(A)") "* Purpose: apply decay" write (u, "(A)") write (u, "(A)") "* Initialize processes" write (u, "(A)") call syntax_model_file_init () call global%global_init () allocate (lib) call global%add_prclib (lib) call global%set_int (var_str ("seed"), & 0, is_known = .true.) call global%set_log (var_str ("?recover_beams"), & .false., is_known = .true.) prefix = "simulation_11" procname1 = prefix // "_p" procname2 = prefix // "_d" call prepare_testbed & (global%prclib, global%process_stack, & prefix, global%os_data, & scattering=.true., decay=.true.) call global%select_model (var_str ("Test")) call global%model%set_par (var_str ("ff"), 0.4_default) call global%model%set_par (var_str ("mf"), & global%model%get_real (var_str ("ff")) & * global%model%get_real (var_str ("ms"))) call global%model%set_unstable (25, [procname2]) write (u, "(A)") "* Initialize simulation object" write (u, "(A)") call simulation%init ([procname1], .true., .true., global) call simulation%init_process_selector () write (u, "(A)") "* Generate event" write (u, "(A)") call simulation%set_n_events_requested (1) call simulation%generate () call simulation%write (u) write (u, *) call simulation%write_event (u) write (u, "(A)") write (u, "(A)") "* Cleanup" write (u, "(A)") call simulation%final () call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: simulations_11" end subroutine simulations_11 @ %def simulations_11 @ \subsubsection{Split Event Files} Generate event for a real process with structure functions and write to file, accepting a limit for the number of events per file. <>= call test (simulations_12, "simulations_12", & "split event files", & u, results) <>= public :: simulations_12 <>= subroutine simulations_12 (u) integer, intent(in) :: u type(string_t) :: libname, procname1, sample type(rt_data_t), target :: global class(eio_t), allocatable :: eio type(simulation_t), allocatable, target :: simulation type(flavor_t) :: flv integer :: i_evt write (u, "(A)") "* Test output: simulations_12" write (u, "(A)") "* Purpose: generate events for a single process" write (u, "(A)") "* and write to split event files" write (u, "(A)") write (u, "(A)") "* Initialize process and integrate" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) libname = "simulation_12" procname1 = "simulation_12p" call prepare_test_library (global, libname, 1, [procname1]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_grids"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_events"), .true., intrinsic = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("single"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_log (var_str ("?recover_beams"), & .false., is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%model_set_real (var_str ("ms"), & 0._default) call flv%init (25, global%model) call global%it_list%init ([1], [1000]) call global%set_string (var_str ("$run_id"), & var_str ("r1"), is_known = .true.) call integrate_process (procname1, global, local_stack=.true.) write (u, "(A)") "* Initialize event generation" write (u, "(A)") call global%set_log (var_str ("?unweighted"), & .false., is_known = .true.) sample = "simulations_12" call global%set_string (var_str ("$sample"), & sample, is_known = .true.) call global%set_int (var_str ("sample_split_n_evt"), & 2, is_known = .true.) call global%set_int (var_str ("sample_split_index"), & 42, is_known = .true.) allocate (simulation) call simulation%init ([procname1], .true., .true., global) call simulation%init_process_selector () call simulation%write (u) write (u, "(A)") write (u, "(A)") "* Initialize ASCII event file" write (u, "(A)") allocate (eio_ascii_short_t :: eio) select type (eio) class is (eio_ascii_t); call eio%set_parameters () end select call eio%init_out (sample, data = simulation%get_data ()) write (u, "(A)") "* Generate 5 events, distributed among three files" do i_evt = 1, 5 call simulation%set_n_events_requested (1) call simulation%generate () call simulation%write_event (eio) end do call eio%final () deallocate (eio) call simulation%final () deallocate (simulation) write (u, *) call display_file ("simulations_12.42.short.evt", u) write (u, *) call display_file ("simulations_12.43.short.evt", u) write (u, *) call display_file ("simulations_12.44.short.evt", u) write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: simulations_12" end subroutine simulations_12 @ %def simulations_12 @ Auxiliary: display file contents. <>= public :: display_file <>= subroutine display_file (file, u) use io_units, only: free_unit character(*), intent(in) :: file integer, intent(in) :: u character(256) :: buffer integer :: u_file write (u, "(3A)") "* Contents of file '", file, "':" write (u, *) u_file = free_unit () open (u_file, file = file, action = "read", status = "old") do read (u_file, "(A)", end = 1) buffer write (u, "(A)") trim (buffer) end do 1 continue end subroutine display_file @ %def display_file @ \subsubsection{Callback} Generate events and execute a callback in place of event I/O. <>= call test (simulations_13, "simulations_13", & "callback", & u, results) <>= public :: simulations_13 <>= subroutine simulations_13 (u) integer, intent(in) :: u type(string_t) :: libname, procname1, sample type(rt_data_t), target :: global class(eio_t), allocatable :: eio type(simulation_t), allocatable, target :: simulation type(flavor_t) :: flv integer :: i_evt type(simulations_13_callback_t) :: event_callback write (u, "(A)") "* Test output: simulations_13" write (u, "(A)") "* Purpose: generate events for a single process" write (u, "(A)") "* and execute callback" write (u, "(A)") write (u, "(A)") "* Initialize process and integrate" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) libname = "simulation_13" procname1 = "simulation_13p" call prepare_test_library (global, libname, 1, [procname1]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_grids"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_events"), .true., intrinsic = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("single"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_log (var_str ("?recover_beams"), & .false., is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call flv%init (25, global%model) call global%it_list%init ([1], [1000]) call global%set_string (var_str ("$run_id"), & var_str ("r1"), is_known = .true.) call integrate_process (procname1, global, local_stack=.true.) write (u, "(A)") "* Initialize event generation" write (u, "(A)") call global%set_log (var_str ("?unweighted"), & .false., is_known = .true.) sample = "simulations_13" call global%set_string (var_str ("$sample"), & sample, is_known = .true.) allocate (simulation) call simulation%init ([procname1], .true., .true., global) call simulation%init_process_selector () write (u, "(A)") "* Prepare callback object" write (u, "(A)") event_callback%u = u call global%set_event_callback (event_callback) write (u, "(A)") "* Initialize callback I/O object" write (u, "(A)") allocate (eio_callback_t :: eio) select type (eio) class is (eio_callback_t) call eio%set_parameters (callback = event_callback, & count_interval = 3) end select call eio%init_out (sample, data = simulation%get_data ()) write (u, "(A)") "* Generate 7 events, with callback every 3 events" write (u, "(A)") do i_evt = 1, 7 call simulation%set_n_events_requested (1) call simulation%generate () call simulation%write_event (eio) end do call eio%final () deallocate (eio) call simulation%final () deallocate (simulation) write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: simulations_13" end subroutine simulations_13 @ %def simulations_13 @ The callback object and procedure. In the type extension, we can store the output channel [[u]] so we know where to write into. <>= type, extends (event_callback_t) :: simulations_13_callback_t integer :: u contains procedure :: write => simulations_13_callback_write procedure :: proc => simulations_13_callback end type simulations_13_callback_t @ %def simulations_13_callback_t <>= subroutine simulations_13_callback_write (event_callback, unit) class(simulations_13_callback_t), intent(in) :: event_callback integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Hello" end subroutine simulations_13_callback_write subroutine simulations_13_callback (event_callback, i, event) class(simulations_13_callback_t), intent(in) :: event_callback integer(i64), intent(in) :: i class(generic_event_t), intent(in) :: event write (event_callback%u, "(A,I0)") "hello event #", i end subroutine simulations_13_callback @ %def simulations_13_callback_write @ %def simulations_13_callback @ \subsubsection{Resonant subprocess setup} Prepare a process with resonances and enter resonant subprocesses in the simulation object. Select a kinematics configuration and compute probabilities for resonant subprocesses. The process and its initialization is taken from [[processes_18]], but we need a complete \oMega\ matrix element here. <>= call test (simulations_14, "simulations_14", & "resonant subprocesses evaluation", & u, results) <>= public :: simulations_14 <>= subroutine simulations_14 (u) integer, intent(in) :: u type(string_t) :: libname, libname_generated type(string_t) :: procname type(string_t) :: model_name type(rt_data_t), target :: global type(prclib_entry_t), pointer :: lib_entry type(process_library_t), pointer :: lib class(model_t), pointer :: model class(model_data_t), pointer :: model_data type(simulation_t), target :: simulation type(particle_set_t) :: pset type(eio_direct_t) :: eio_in type(eio_dump_t) :: eio_out real(default) :: sqrts, mw, pp real(default), dimension(3) :: p3 type(vector4_t), dimension(:), allocatable :: p real(default), dimension(:), allocatable :: m integer :: u_verbose, i real(default) :: sqme_proc real(default), dimension(:), allocatable :: sqme real(default) :: on_shell_limit integer, dimension(:), allocatable :: i_array real(default), dimension(:), allocatable :: prob_array write (u, "(A)") "* Test output: simulations_14" write (u, "(A)") "* Purpose: construct resonant subprocesses & &in the simulation object" write (u, "(A)") write (u, "(A)") "* Build and load a test library with one process" write (u, "(A)") call syntax_model_file_init () call syntax_phs_forest_init () libname = "simulations_14_lib" procname = "simulations_14_p" call global%global_init () call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_grids"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_events"), .true., intrinsic = .true.) call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%set_log (var_str ("?recover_beams"), & .false., is_known = .true.) call global%set_log (var_str ("?update_sqme"), & .true., is_known = .true.) call global%set_log (var_str ("?update_weight"), & .true., is_known = .true.) call global%set_log (var_str ("?update_event"), & .true., is_known = .true.) model_name = "SM" call global%select_model (model_name) allocate (model) call model%init_instance (global%model) model_data => model write (u, "(A)") "* Initialize process library and process" write (u, "(A)") allocate (lib_entry) call lib_entry%init (libname) lib => lib_entry%process_library_t call global%add_prclib (lib_entry) call prepare_resonance_test_library & (lib, libname, procname, model_data, global, u) write (u, "(A)") write (u, "(A)") "* Initialize simulation object & &with resonant subprocesses" write (u, "(A)") call global%set_log (var_str ("?resonance_history"), & .true., is_known = .true.) call global%set_real (var_str ("resonance_on_shell_limit"), & 10._default, is_known = .true.) call simulation%init ([procname], & integrate=.false., generate=.false., local=global) call simulation%write_resonant_subprocess_data (u, 1) write (u, "(A)") write (u, "(A)") "* Resonant subprocesses: generated library" write (u, "(A)") libname_generated = procname // "_R" lib => global%prclib_stack%get_library_ptr (libname_generated) if (associated (lib)) call lib%write (u, libpath=.false.) write (u, "(A)") write (u, "(A)") "* Generated process stack" write (u, "(A)") call global%process_stack%show (u) write (u, "(A)") write (u, "(A)") "* Particle set" write (u, "(A)") pset = simulation%get_hard_particle_set (1) call pset%write (u) write (u, "(A)") write (u, "(A)") "* Initialize object for direct access" write (u, "(A)") call eio_in%init_direct & (n_beam = 0, n_in = 2, n_rem = 0, n_vir = 0, n_out = 3, & pdg = [-11, 11, 1, -2, 24], model=global%model) call eio_in%set_selection_indices (1, 1, 1, 1) sqrts = global%get_rval (var_str ("sqrts")) mw = 80._default ! deliberately slightly different from true mw pp = sqrt (sqrts**2 - 4 * mw**2) / 2 allocate (p (5), m (5)) p(1) = vector4_moving (sqrts/2, sqrts/2, 3) m(1) = 0 p(2) = vector4_moving (sqrts/2,-sqrts/2, 3) m(2) = 0 p3(1) = pp/2 p3(2) = mw/2 p3(3) = 0 p(3) = vector4_moving (sqrts/4, vector3_moving (p3)) m(3) = 0 p3(2) = -mw/2 p(4) = vector4_moving (sqrts/4, vector3_moving (p3)) m(4) = 0 p(5) = vector4_moving (sqrts/2,-pp, 1) m(5) = mw call eio_in%set_momentum (p, m**2) call eio_in%write (u) write (u, "(A)") write (u, "(A)") "* Transfer and show particle set" write (u, "(A)") call simulation%read_event (eio_in) pset = simulation%get_hard_particle_set (1) call pset%write (u) write (u, "(A)") write (u, "(A)") "* (Re)calculate matrix element" write (u, "(A)") call simulation%recalculate (recover_phs = .false.) call simulation%evaluate_transforms () write (u, "(A)") "* Show event with sqme" write (u, "(A)") call eio_out%set_parameters (unit = u, & weights = .true., pacify = .true., compressed = .true.) call eio_out%init_out (var_str ("")) call simulation%write_event (eio_out) write (u, "(A)") write (u, "(A)") "* Write event to separate file & &'simulations_14_event_verbose.log'" u_verbose = free_unit () open (unit = u_verbose, file = "simulations_14_event_verbose.log", & status = "replace", action = "write") call simulation%write (u_verbose) write (u_verbose, *) call simulation%write_event (u_verbose, verbose =.true., testflag = .true.) close (u_verbose) write (u, "(A)") write (u, "(A)") "* Cleanup" call simulation%final () call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: simulations_14" end subroutine simulations_14 @ %def simulations_14 @ \subsubsection{Resonant subprocess simulation} Prepare a process with resonances and enter resonant subprocesses in the simulation object. Simulate events with selection of resonance histories. The process and its initialization is taken from [[processes_18]], but we need a complete \oMega\ matrix element here. <>= call test (simulations_15, "simulations_15", & "resonant subprocesses in simulation", & u, results) <>= public :: simulations_15 <>= subroutine simulations_15 (u) integer, intent(in) :: u type(string_t) :: libname, libname_generated type(string_t) :: procname type(string_t) :: model_name type(rt_data_t), target :: global type(prclib_entry_t), pointer :: lib_entry type(process_library_t), pointer :: lib class(model_t), pointer :: model class(model_data_t), pointer :: model_data type(simulation_t), target :: simulation real(default) :: sqrts type(eio_dump_t) :: eio_out integer :: u_verbose write (u, "(A)") "* Test output: simulations_15" write (u, "(A)") "* Purpose: generate event with resonant subprocess" write (u, "(A)") write (u, "(A)") "* Build and load a test library with one process" write (u, "(A)") call syntax_model_file_init () call syntax_phs_forest_init () libname = "simulations_15_lib" procname = "simulations_15_p" call global%global_init () call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_grids"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_events"), .true., intrinsic = .true.) call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%set_log (var_str ("?recover_beams"), & .false., is_known = .true.) call global%set_log (var_str ("?update_sqme"), & .true., is_known = .true.) call global%set_log (var_str ("?update_weight"), & .true., is_known = .true.) call global%set_log (var_str ("?update_event"), & .true., is_known = .true.) call global%set_log (var_str ("?resonance_history"), & .true., is_known = .true.) call global%set_real (var_str ("resonance_on_shell_limit"), & 10._default, is_known = .true.) model_name = "SM" call global%select_model (model_name) allocate (model) call model%init_instance (global%model) model_data => model write (u, "(A)") "* Initialize process library and process" write (u, "(A)") allocate (lib_entry) call lib_entry%init (libname) lib => lib_entry%process_library_t call global%add_prclib (lib_entry) call prepare_resonance_test_library & (lib, libname, procname, model_data, global, u) write (u, "(A)") write (u, "(A)") "* Initialize simulation object & &with resonant subprocesses" write (u, "(A)") call global%it_list%init ([1], [1000]) call simulation%init ([procname], & integrate=.true., generate=.true., local=global) call simulation%write_resonant_subprocess_data (u, 1) write (u, "(A)") write (u, "(A)") "* Generate event" write (u, "(A)") call simulation%init_process_selector () call simulation%set_n_events_requested (1) call simulation%generate () call eio_out%set_parameters (unit = u, & weights = .true., pacify = .true., compressed = .true.) call eio_out%init_out (var_str ("")) call simulation%write_event (eio_out) write (u, "(A)") write (u, "(A)") "* Write event to separate file & &'simulations_15_event_verbose.log'" u_verbose = free_unit () open (unit = u_verbose, file = "simulations_15_event_verbose.log", & status = "replace", action = "write") call simulation%write (u_verbose) write (u_verbose, *) call simulation%write_event (u_verbose, verbose =.true., testflag = .true.) close (u_verbose) write (u, "(A)") write (u, "(A)") "* Cleanup" call simulation%final () call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: simulations_15" end subroutine simulations_15 @ %def simulations_15 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{More Unit Tests} This chapter collects some procedures for testing that can't be provided at the point where the corresponding modules are defined, because they use other modules of a different level. (We should move them back, collecting the high-level functionality in init/final hooks that we can set at runtime.) \section{Expression Testing} Expression objects are part of process and event objects, but the process and event object modules should not depend on the implementation of expressions. Here, we collect unit tests that depend on expression implementation. <<[[expr_tests_ut.f90]]>>= <> module expr_tests_ut use unit_tests use expr_tests_uti <> <> contains <> end module expr_tests_ut @ %def expr_tests_ut @ <<[[expr_tests_uti.f90]]>>= <> module expr_tests_uti <> <> use format_defs, only: FMT_12 use format_utils, only: write_separator use os_interface use sm_qcd use lorentz use ifiles use lexers use parser use model_data use interactions, only: reset_interaction_counter use process_libraries use subevents use subevt_expr use rng_base use mci_base use phs_base use variables, only: var_list_t use eval_trees use models use prc_core use prc_test use process, only: process_t use instances, only: process_instance_t use events use rng_base_ut, only: rng_test_factory_t use phs_base_ut, only: phs_test_config_t <> <> contains <> <> end module expr_tests_uti @ %def expr_tests_uti @ \subsection{Test} This is the master for calling self-test procedures. <>= public :: subevt_expr_test <>= subroutine subevt_expr_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine subevt_expr_test @ %def subevt_expr_test @ \subsubsection{Parton-event expressions} <>= call test (subevt_expr_1, "subevt_expr_1", & "parton-event expressions", & u, results) <>= public :: subevt_expr_1 <>= subroutine subevt_expr_1 (u) integer, intent(in) :: u type(string_t) :: expr_text type(ifile_t) :: ifile type(stream_t) :: stream type(parse_tree_t) :: pt_cuts, pt_scale, pt_fac_scale, pt_ren_scale type(parse_tree_t) :: pt_weight type(parse_node_t), pointer :: pn_cuts, pn_scale, pn_fac_scale, pn_ren_scale type(parse_node_t), pointer :: pn_weight type(eval_tree_factory_t) :: expr_factory type(os_data_t) :: os_data type(model_t), target :: model type(parton_expr_t), target :: expr real(default) :: E, Ex, m type(vector4_t), dimension(6) :: p integer :: i, pdg logical :: passed real(default) :: scale, weight real(default), allocatable :: fac_scale, ren_scale write (u, "(A)") "* Test output: subevt_expr_1" write (u, "(A)") "* Purpose: Set up a subevt and associated & &process-specific expressions" write (u, "(A)") call syntax_pexpr_init () call syntax_model_file_init () call os_data%init () call model%read (var_str ("Test.mdl"), os_data) write (u, "(A)") "* Expression texts" write (u, "(A)") expr_text = "all Pt > 100 [s]" write (u, "(A,A)") "cuts = ", char (expr_text) call ifile_clear (ifile) call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call parse_tree_init_lexpr (pt_cuts, stream, .true.) call stream_final (stream) pn_cuts => pt_cuts%get_root_ptr () expr_text = "sqrts" write (u, "(A,A)") "scale = ", char (expr_text) call ifile_clear (ifile) call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call parse_tree_init_expr (pt_scale, stream, .true.) call stream_final (stream) pn_scale => pt_scale%get_root_ptr () expr_text = "sqrts_hat" write (u, "(A,A)") "fac_scale = ", char (expr_text) call ifile_clear (ifile) call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call parse_tree_init_expr (pt_fac_scale, stream, .true.) call stream_final (stream) pn_fac_scale => pt_fac_scale%get_root_ptr () expr_text = "100" write (u, "(A,A)") "ren_scale = ", char (expr_text) call ifile_clear (ifile) call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call parse_tree_init_expr (pt_ren_scale, stream, .true.) call stream_final (stream) pn_ren_scale => pt_ren_scale%get_root_ptr () expr_text = "n_tot - n_in - n_out" write (u, "(A,A)") "weight = ", char (expr_text) call ifile_clear (ifile) call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call parse_tree_init_expr (pt_weight, stream, .true.) call stream_final (stream) pn_weight => pt_weight%get_root_ptr () call ifile_final (ifile) write (u, "(A)") write (u, "(A)") "* Initialize process expr" write (u, "(A)") call expr%setup_vars (1000._default) call expr%var_list%append_real (var_str ("tolerance"), 0._default) call expr%link_var_list (model%get_var_list_ptr ()) call expr_factory%init (pn_cuts) call expr%setup_selection (expr_factory) call expr_factory%init (pn_scale) call expr%setup_scale (expr_factory) call expr_factory%init (pn_fac_scale) call expr%setup_fac_scale (expr_factory) call expr_factory%init (pn_ren_scale) call expr%setup_ren_scale (expr_factory) call expr_factory%init (pn_weight) call expr%setup_weight (expr_factory) call write_separator (u) call expr%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Fill subevt and evaluate expressions" write (u, "(A)") call subevt_init (expr%subevt_t, 6) E = 500._default Ex = 400._default m = 125._default pdg = 25 p(1) = vector4_moving (E, sqrt (E**2 - m**2), 3) p(2) = vector4_moving (E, -sqrt (E**2 - m**2), 3) p(3) = vector4_moving (Ex, sqrt (Ex**2 - m**2), 3) p(4) = vector4_moving (Ex, -sqrt (Ex**2 - m**2), 3) p(5) = vector4_moving (Ex, sqrt (Ex**2 - m**2), 1) p(6) = vector4_moving (Ex, -sqrt (Ex**2 - m**2), 1) call expr%reset_contents () do i = 1, 2 call expr%set_beam (i, pdg, p(i), m**2) end do do i = 3, 4 call expr%set_incoming (i, pdg, p(i), m**2) end do do i = 5, 6 call expr%set_outgoing (i, pdg, p(i), m**2) end do expr%sqrts_hat = expr%get_sqrts_hat () expr%n_in = 2 expr%n_out = 2 expr%n_tot = 4 expr%subevt_filled = .true. call expr%evaluate (passed, scale, fac_scale, ren_scale, weight) write (u, "(A,L1)") "Event has passed = ", passed write (u, "(A," // FMT_12 // ")") "Scale = ", scale write (u, "(A," // FMT_12 // ")") "Factorization scale = ", fac_scale write (u, "(A," // FMT_12 // ")") "Renormalization scale = ", ren_scale write (u, "(A," // FMT_12 // ")") "Weight = ", weight write (u, "(A)") call write_separator (u) call expr%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call expr%final () call model%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: subevt_expr_1" end subroutine subevt_expr_1 @ %def subevt_expr_1 @ \subsubsection{Parton-event expressions} <>= call test (subevt_expr_2, "subevt_expr_2", & "parton-event expressions", & u, results) <>= public :: subevt_expr_2 <>= subroutine subevt_expr_2 (u) integer, intent(in) :: u type(string_t) :: expr_text type(ifile_t) :: ifile type(stream_t) :: stream type(parse_tree_t) :: pt_selection type(parse_tree_t) :: pt_reweight, pt_analysis type(parse_node_t), pointer :: pn_selection type(parse_node_t), pointer :: pn_reweight, pn_analysis type(os_data_t) :: os_data type(model_t), target :: model type(eval_tree_factory_t) :: expr_factory type(event_expr_t), target :: expr real(default) :: E, Ex, m type(vector4_t), dimension(6) :: p integer :: i, pdg logical :: passed real(default) :: reweight logical :: analysis_flag write (u, "(A)") "* Test output: subevt_expr_2" write (u, "(A)") "* Purpose: Set up a subevt and associated & &process-specific expressions" write (u, "(A)") call syntax_pexpr_init () call syntax_model_file_init () call os_data%init () call model%read (var_str ("Test.mdl"), os_data) write (u, "(A)") "* Expression texts" write (u, "(A)") expr_text = "all Pt > 100 [s]" write (u, "(A,A)") "selection = ", char (expr_text) call ifile_clear (ifile) call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call parse_tree_init_lexpr (pt_selection, stream, .true.) call stream_final (stream) pn_selection => pt_selection%get_root_ptr () expr_text = "n_tot - n_in - n_out" write (u, "(A,A)") "reweight = ", char (expr_text) call ifile_clear (ifile) call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call parse_tree_init_expr (pt_reweight, stream, .true.) call stream_final (stream) pn_reweight => pt_reweight%get_root_ptr () expr_text = "true" write (u, "(A,A)") "analysis = ", char (expr_text) call ifile_clear (ifile) call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call parse_tree_init_lexpr (pt_analysis, stream, .true.) call stream_final (stream) pn_analysis => pt_analysis%get_root_ptr () call ifile_final (ifile) write (u, "(A)") write (u, "(A)") "* Initialize process expr" write (u, "(A)") call expr%setup_vars (1000._default) call expr%link_var_list (model%get_var_list_ptr ()) call expr%var_list%append_real (var_str ("tolerance"), 0._default) call expr_factory%init (pn_selection) call expr%setup_selection (expr_factory) call expr_factory%init (pn_analysis) call expr%setup_analysis (expr_factory) call expr_factory%init (pn_reweight) call expr%setup_reweight (expr_factory) call write_separator (u) call expr%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Fill subevt and evaluate expressions" write (u, "(A)") call subevt_init (expr%subevt_t, 6) E = 500._default Ex = 400._default m = 125._default pdg = 25 p(1) = vector4_moving (E, sqrt (E**2 - m**2), 3) p(2) = vector4_moving (E, -sqrt (E**2 - m**2), 3) p(3) = vector4_moving (Ex, sqrt (Ex**2 - m**2), 3) p(4) = vector4_moving (Ex, -sqrt (Ex**2 - m**2), 3) p(5) = vector4_moving (Ex, sqrt (Ex**2 - m**2), 1) p(6) = vector4_moving (Ex, -sqrt (Ex**2 - m**2), 1) call expr%reset_contents () do i = 1, 2 call expr%set_beam (i, pdg, p(i), m**2) end do do i = 3, 4 call expr%set_incoming (i, pdg, p(i), m**2) end do do i = 5, 6 call expr%set_outgoing (i, pdg, p(i), m**2) end do expr%sqrts_hat = expr%get_sqrts_hat () expr%n_in = 2 expr%n_out = 2 expr%n_tot = 4 expr%subevt_filled = .true. call expr%evaluate (passed, reweight, analysis_flag) write (u, "(A,L1)") "Event has passed = ", passed write (u, "(A," // FMT_12 // ")") "Reweighting factor = ", reweight write (u, "(A,L1)") "Analysis flag = ", analysis_flag write (u, "(A)") call write_separator (u) call expr%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call expr%final () call model%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: subevt_expr_2" end subroutine subevt_expr_2 @ %def subevt_expr_2 @ \subsubsection{Processes: handle partonic cuts} Initialize a process and process instance, choose a sampling point and fill the process instance, evaluating a given cut configuration. We use the same trivial process as for the previous test. All momentum and state dependence is trivial, so we just test basic functionality. <>= call test (processes_5, "processes_5", & "handle cuts (partonic event)", & u, results) <>= public :: processes_5 <>= subroutine processes_5 (u) integer, intent(in) :: u type(string_t) :: cut_expr_text type(ifile_t) :: ifile type(stream_t) :: stream type(parse_tree_t) :: parse_tree type(eval_tree_factory_t) :: expr_factory type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), pointer :: model_tmp type(model_t), pointer :: model type(var_list_t), target :: var_list type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts type(process_instance_t), allocatable, target :: process_instance write (u, "(A)") "* Test output: processes_5" write (u, "(A)") "* Purpose: create a process & &and fill a process instance" write (u, "(A)") write (u, "(A)") "* Prepare a cut expression" write (u, "(A)") call syntax_pexpr_init () cut_expr_text = "all Pt > 100 [s]" call ifile_append (ifile, cut_expr_text) call stream_init (stream, ifile) call parse_tree_init_lexpr (parse_tree, stream, .true.) write (u, "(A)") "* Build and initialize a test process" write (u, "(A)") libname = "processes5" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call syntax_model_file_init () allocate (model_tmp) call model_tmp%read (var_str ("Test.mdl"), os_data) call var_list%init_snapshot (model_tmp%get_var_list_ptr ()) model => model_tmp call reset_interaction_counter () call var_list%append_real (var_str ("tolerance"), 0._default) call var_list%append_log (var_str ("?alphas_is_fixed"), .true.) call var_list%append_int (var_str ("seed"), 0) allocate (process) call process%init (procname, lib, os_data, model, var_list) call var_list%final () allocate (phs_test_config_t :: phs_config_template) call process%setup_test_cores () call process%init_components (phs_config_template) write (u, "(A)") "* Prepare a trivial beam setup" write (u, "(A)") sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_empty) write (u, "(A)") "* Complete process initialization and set cuts" write (u, "(A)") call process%setup_terms () call expr_factory%init (parse_tree%get_root_ptr ()) call process%set_cuts (expr_factory) call process%write (.false., u, & show_var_list=.true., show_expressions=.true., show_os_data=.false.) write (u, "(A)") write (u, "(A)") "* Create a process instance" write (u, "(A)") allocate (process_instance) call process_instance%init (process) write (u, "(A)") write (u, "(A)") "* Inject a set of random numbers" write (u, "(A)") call process_instance%choose_mci (1) call process_instance%set_mcpar ([0._default, 0._default]) write (u, "(A)") write (u, "(A)") "* Set up kinematics and subevt, check cuts (should fail)" write (u, "(A)") call process_instance%select_channel (1) call process_instance%compute_seed_kinematics () call process_instance%compute_hard_kinematics () call process_instance%compute_eff_kinematics () call process_instance%evaluate_expressions () call process_instance%compute_other_channels () call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Evaluate for another set (should succeed)" write (u, "(A)") call process_instance%reset () call process_instance%set_mcpar ([0.5_default, 0.125_default]) call process_instance%select_channel (1) call process_instance%compute_seed_kinematics () call process_instance%compute_hard_kinematics () call process_instance%compute_eff_kinematics () call process_instance%evaluate_expressions () call process_instance%compute_other_channels () call process_instance%evaluate_trace () call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Evaluate for another set using convenience procedure & &(failure)" write (u, "(A)") call process_instance%evaluate_sqme (1, [0.0_default, 0.2_default]) call process_instance%write_header (u) write (u, "(A)") write (u, "(A)") "* Evaluate for another set using convenience procedure & &(success)" write (u, "(A)") call process_instance%evaluate_sqme (1, [0.1_default, 0.2_default]) call process_instance%write_header (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call process_instance%final () deallocate (process_instance) call process%final () deallocate (process) call parse_tree_final (parse_tree) call stream_final (stream) call ifile_final (ifile) call syntax_pexpr_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_5" end subroutine processes_5 @ %def processes_5 @ Trivial for testing: do not allocate the MCI record. <>= subroutine dispatch_mci_empty (mci, var_list, process_id, is_nlo) class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo end subroutine dispatch_mci_empty @ %def dispatch_mci_empty @ \subsubsection{Processes: scales and such} Initialize a process and process instance, choose a sampling point and fill the process instance, evaluating a given cut configuration. We use the same trivial process as for the previous test. All momentum and state dependence is trivial, so we just test basic functionality. <>= call test (processes_6, "processes_6", & "handle scales and weight (partonic event)", & u, results) <>= public :: processes_6 <>= subroutine processes_6 (u) integer, intent(in) :: u type(string_t) :: expr_text type(ifile_t) :: ifile type(stream_t) :: stream type(parse_tree_t) :: pt_scale, pt_fac_scale, pt_ren_scale, pt_weight type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), pointer :: model_tmp type(model_t), pointer :: model type(var_list_t), target :: var_list type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts type(process_instance_t), allocatable, target :: process_instance type(eval_tree_factory_t) :: expr_factory write (u, "(A)") "* Test output: processes_6" write (u, "(A)") "* Purpose: create a process & &and fill a process instance" write (u, "(A)") write (u, "(A)") "* Prepare expressions" write (u, "(A)") call syntax_pexpr_init () expr_text = "sqrts - 100 GeV" write (u, "(A,A)") "scale = ", char (expr_text) call ifile_clear (ifile) call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call parse_tree_init_expr (pt_scale, stream, .true.) call stream_final (stream) expr_text = "sqrts_hat" write (u, "(A,A)") "fac_scale = ", char (expr_text) call ifile_clear (ifile) call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call parse_tree_init_expr (pt_fac_scale, stream, .true.) call stream_final (stream) expr_text = "eval sqrt (M2) [collect [s]]" write (u, "(A,A)") "ren_scale = ", char (expr_text) call ifile_clear (ifile) call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call parse_tree_init_expr (pt_ren_scale, stream, .true.) call stream_final (stream) expr_text = "n_tot * n_in * n_out * (eval Phi / pi [s])" write (u, "(A,A)") "weight = ", char (expr_text) call ifile_clear (ifile) call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call parse_tree_init_expr (pt_weight, stream, .true.) call stream_final (stream) call ifile_final (ifile) write (u, "(A)") write (u, "(A)") "* Build and initialize a test process" write (u, "(A)") libname = "processes4" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call syntax_model_file_init () allocate (model_tmp) call model_tmp%read (var_str ("Test.mdl"), os_data) call var_list%init_snapshot (model_tmp%get_var_list_ptr ()) model => model_tmp call var_list%append_log (var_str ("?alphas_is_fixed"), .true.) call var_list%append_int (var_str ("seed"), 0) call reset_interaction_counter () allocate (process) call process%init (procname, lib, os_data, model, var_list) call var_list%final () call process%setup_test_cores () allocate (phs_test_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Prepare a trivial beam setup" write (u, "(A)") sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_empty) write (u, "(A)") "* Complete process initialization and set cuts" write (u, "(A)") call process%setup_terms () call expr_factory%init (pt_scale%get_root_ptr ()) call process%set_scale (expr_factory) call expr_factory%init (pt_fac_scale%get_root_ptr ()) call process%set_fac_scale (expr_factory) call expr_factory%init (pt_ren_scale%get_root_ptr ()) call process%set_ren_scale (expr_factory) call expr_factory%init (pt_weight%get_root_ptr ()) call process%set_weight (expr_factory) call process%write (.false., u, show_expressions=.true.) write (u, "(A)") write (u, "(A)") "* Create a process instance and evaluate" write (u, "(A)") allocate (process_instance) call process_instance%init (process) call process_instance%choose_mci (1) call process_instance%evaluate_sqme (1, [0.5_default, 0.125_default]) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call process_instance%final () deallocate (process_instance) call process%final () deallocate (process) call parse_tree_final (pt_scale) call parse_tree_final (pt_fac_scale) call parse_tree_final (pt_ren_scale) call parse_tree_final (pt_weight) call syntax_pexpr_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_6" end subroutine processes_6 @ %def processes_6 @ \subsubsection{Event expressions} After generating an event, fill the [[subevt]] and evaluate expressions for selection, reweighting, and analysis. <>= call test (events_3, "events_3", & "expression evaluation", & u, results) <>= public :: events_3 <>= subroutine events_3 (u) use processes_ut, only: prepare_test_process, cleanup_test_process integer, intent(in) :: u type(string_t) :: expr_text type(ifile_t) :: ifile type(stream_t) :: stream type(parse_tree_t) :: pt_selection, pt_reweight, pt_analysis type(eval_tree_factory_t) :: expr_factory type(event_t), allocatable, target :: event type(process_t), allocatable, target :: process type(process_instance_t), allocatable, target :: process_instance type(os_data_t) :: os_data type(model_t), pointer :: model type(var_list_t), target :: var_list write (u, "(A)") "* Test output: events_3" write (u, "(A)") "* Purpose: generate an event and evaluate expressions" write (u, "(A)") call syntax_pexpr_init () write (u, "(A)") "* Expression texts" write (u, "(A)") expr_text = "all Pt > 100 [s]" write (u, "(A,A)") "selection = ", char (expr_text) call ifile_clear (ifile) call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call parse_tree_init_lexpr (pt_selection, stream, .true.) call stream_final (stream) expr_text = "1 + sqrts_hat / sqrts" write (u, "(A,A)") "reweight = ", char (expr_text) call ifile_clear (ifile) call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call parse_tree_init_expr (pt_reweight, stream, .true.) call stream_final (stream) expr_text = "true" write (u, "(A,A)") "analysis = ", char (expr_text) call ifile_clear (ifile) call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call parse_tree_init_lexpr (pt_analysis, stream, .true.) call stream_final (stream) call ifile_final (ifile) write (u, "(A)") write (u, "(A)") "* Initialize test process event" call os_data%init () call syntax_model_file_init () allocate (model) call model%read (var_str ("Test.mdl"), os_data) call var_list%init_snapshot (model%get_var_list_ptr ()) call var_list%append_log (var_str ("?alphas_is_fixed"), .true.) call var_list%append_int (var_str ("seed"), 0) allocate (process) allocate (process_instance) call prepare_test_process (process, process_instance, model, var_list) call var_list%final () call process_instance%setup_event_data () write (u, "(A)") write (u, "(A)") "* Initialize event object and set expressions" allocate (event) call event%basic_init () call expr_factory%init (pt_selection%get_root_ptr ()) call event%set_selection (expr_factory) call expr_factory%init (pt_reweight%get_root_ptr ()) call event%set_reweight (expr_factory) call expr_factory%init (pt_analysis%get_root_ptr ()) call event%set_analysis (expr_factory) call event%connect (process_instance, process%get_model_ptr ()) call event%expr%var_list%append_real (var_str ("tolerance"), 0._default) call event%setup_expressions () write (u, "(A)") write (u, "(A)") "* Generate test process event" call process_instance%generate_weighted_event (1) write (u, "(A)") write (u, "(A)") "* Fill event object and evaluate expressions" write (u, "(A)") call event%generate (1, [0.4_default, 0.4_default]) call event%set_index (42) call event%evaluate_expressions () call event%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call event%final () deallocate (event) call cleanup_test_process (process, process_instance) deallocate (process_instance) deallocate (process) call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: events_3" end subroutine events_3 @ %def events_3 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Top Level} The top level consists of \begin{description} \item[commands] Defines generic command-list and command objects, and all specific implementations. Each command type provides a specific functionality. Together with the modules that provide expressions and variables, this module defines the Sindarin language. \item[whizard] This module interprets streams of various kind in terms of the command language. It also contains the unit-test feature. We also define the externally visible procedures here, for the \whizard\ as a library. \item[main] The driver for \whizard\ as a stand-alone program. Contains the command-line interpreter. \item[whizard\_c\_interface] Alternative top-level procedures, for use in the context of a C-compatible caller program. \end{description} \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Commands} This module defines the command language of the main input file. <<[[commands.f90]]>>= <> module commands <> <> <> use io_units use string_utils, only: lower_case, split_string, str use format_utils, only: write_indent use format_defs, only: FMT_14, FMT_19 use diagnostics use constants, only: one use physics_defs use sorting use sf_lhapdf, only: lhapdf_global_reset use os_interface use ifiles use lexers use syntax_rules use parser use analysis use pdg_arrays use variables, only: var_list_t, V_NONE, V_LOG, V_INT, V_REAL, V_CMPLX, V_STR, V_PDG use observables, only: var_list_check_observable use observables, only: var_list_check_result_var use eval_trees use models use auto_components use flavors use polarizations use particle_specifiers use process_libraries use process use instances use prclib_stacks use slha_interface use user_files use eio_data use rt_data use process_configurations use compilations, only: compile_library, compile_executable use integrations, only: integrate_process use restricted_subprocesses, only: get_libname_res use restricted_subprocesses, only: spawn_resonant_subprocess_libraries use event_streams use simulations use radiation_generator <> <> <> <> <> <> <> contains <> end module commands @ %def commands @ \subsection{The command type} The command type is a generic type that holds any command, compiled for execution. Each command may come with its own local environment. The command list that determines this environment is allocated as [[options]], if necessary. (It has to be allocated as a pointer because the type definition is recursive.) The local environment is available as a pointer which either points to the global environment, or is explicitly allocated and initialized. <>= type, abstract :: command_t type(parse_node_t), pointer :: pn => null () class(command_t), pointer :: next => null () type(parse_node_t), pointer :: pn_opt => null () type(command_list_t), pointer :: options => null () type(rt_data_t), pointer :: local => null () contains <> end type command_t @ %def command_t @ Finalizer: If there is an option list, finalize the option list and deallocate. If not, the local environment is just a pointer. <>= procedure :: final => command_final <>= recursive subroutine command_final (cmd) class(command_t), intent(inout) :: cmd if (associated (cmd%options)) then call cmd%options%final () deallocate (cmd%options) call cmd%local%local_final () deallocate (cmd%local) else cmd%local => null () end if end subroutine command_final @ %def command_final @ Allocate a command with the appropriate concrete type. Store the parse node pointer in the command object, so we can reference to it when compiling. <>= subroutine dispatch_command (command, pn) class(command_t), intent(inout), pointer :: command type(parse_node_t), intent(in), target :: pn select case (char (parse_node_get_rule_key (pn))) case ("cmd_model") allocate (cmd_model_t :: command) case ("cmd_library") allocate (cmd_library_t :: command) case ("cmd_process") allocate (cmd_process_t :: command) case ("cmd_nlo") allocate (cmd_nlo_t :: command) case ("cmd_compile") allocate (cmd_compile_t :: command) case ("cmd_exec") allocate (cmd_exec_t :: command) case ("cmd_num", "cmd_complex", "cmd_real", "cmd_int", & "cmd_log_decl", "cmd_log", "cmd_string", "cmd_string_decl", & "cmd_alias", "cmd_result") allocate (cmd_var_t :: command) case ("cmd_slha") allocate (cmd_slha_t :: command) case ("cmd_show") allocate (cmd_show_t :: command) case ("cmd_clear") allocate (cmd_clear_t :: command) case ("cmd_expect") allocate (cmd_expect_t :: command) case ("cmd_beams") allocate (cmd_beams_t :: command) case ("cmd_beams_pol_density") allocate (cmd_beams_pol_density_t :: command) case ("cmd_beams_pol_fraction") allocate (cmd_beams_pol_fraction_t :: command) case ("cmd_beams_momentum") allocate (cmd_beams_momentum_t :: command) case ("cmd_beams_theta") allocate (cmd_beams_theta_t :: command) case ("cmd_beams_phi") allocate (cmd_beams_phi_t :: command) case ("cmd_cuts") allocate (cmd_cuts_t :: command) case ("cmd_scale") allocate (cmd_scale_t :: command) case ("cmd_fac_scale") allocate (cmd_fac_scale_t :: command) case ("cmd_ren_scale") allocate (cmd_ren_scale_t :: command) case ("cmd_weight") allocate (cmd_weight_t :: command) case ("cmd_selection") allocate (cmd_selection_t :: command) case ("cmd_reweight") allocate (cmd_reweight_t :: command) case ("cmd_iterations") allocate (cmd_iterations_t :: command) case ("cmd_integrate") allocate (cmd_integrate_t :: command) case ("cmd_observable") allocate (cmd_observable_t :: command) case ("cmd_histogram") allocate (cmd_histogram_t :: command) case ("cmd_plot") allocate (cmd_plot_t :: command) case ("cmd_graph") allocate (cmd_graph_t :: command) case ("cmd_record") allocate (cmd_record_t :: command) case ("cmd_analysis") allocate (cmd_analysis_t :: command) case ("cmd_alt_setup") allocate (cmd_alt_setup_t :: command) case ("cmd_unstable") allocate (cmd_unstable_t :: command) case ("cmd_stable") allocate (cmd_stable_t :: command) case ("cmd_polarized") allocate (cmd_polarized_t :: command) case ("cmd_unpolarized") allocate (cmd_unpolarized_t :: command) case ("cmd_sample_format") allocate (cmd_sample_format_t :: command) case ("cmd_simulate") allocate (cmd_simulate_t :: command) case ("cmd_rescan") allocate (cmd_rescan_t :: command) case ("cmd_write_analysis") allocate (cmd_write_analysis_t :: command) case ("cmd_compile_analysis") allocate (cmd_compile_analysis_t :: command) case ("cmd_open_out") allocate (cmd_open_out_t :: command) case ("cmd_close_out") allocate (cmd_close_out_t :: command) case ("cmd_printf") allocate (cmd_printf_t :: command) case ("cmd_scan") allocate (cmd_scan_t :: command) case ("cmd_if") allocate (cmd_if_t :: command) case ("cmd_include") allocate (cmd_include_t :: command) case ("cmd_export") allocate (cmd_export_t :: command) case ("cmd_quit") allocate (cmd_quit_t :: command) case default print *, char (parse_node_get_rule_key (pn)) call msg_bug ("Command not implemented") end select command%pn => pn end subroutine dispatch_command @ %def dispatch_command @ Output. We allow for indentation so we can display a command tree. <>= procedure (command_write), deferred :: write <>= abstract interface subroutine command_write (cmd, unit, indent) import class(command_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent end subroutine command_write end interface @ %def command_write @ Compile a command. The command type is already fixed, so this is a deferred type-bound procedure. <>= procedure (command_compile), deferred :: compile <>= abstract interface subroutine command_compile (cmd, global) import class(command_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global end subroutine command_compile end interface @ %def command_compile @ Execute a command. This will use and/or modify the runtime data set. If the [[quit]] flag is set, the caller should terminate command execution. <>= procedure (command_execute), deferred :: execute <>= abstract interface subroutine command_execute (cmd, global) import class(command_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global end subroutine command_execute end interface @ %def command_execute @ \subsection{Options} The [[options]] command list is allocated, initialized, and executed, if the command is associated with an option text in curly braces. If present, a separate local runtime data set [[local]] will be allocated and initialized; otherwise, [[local]] becomes a pointer to the global dataset. For output, we indent the options list. <>= procedure :: write_options => command_write_options <>= recursive subroutine command_write_options (cmd, unit, indent) class(command_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: ind ind = 1; if (present (indent)) ind = indent + 1 if (associated (cmd%options)) call cmd%options%write (unit, ind) end subroutine command_write_options @ %def command_write_options @ Compile the options list, if any. This implies initialization of the local environment. Should be done once the [[pn_opt]] node has been assigned (if applicable), but before the actual command compilation. <>= procedure :: compile_options => command_compile_options <>= recursive subroutine command_compile_options (cmd, global) class(command_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global if (associated (cmd%pn_opt)) then allocate (cmd%local) call cmd%local%local_init (global) call global%copy_globals (cmd%local) allocate (cmd%options) call cmd%options%compile (cmd%pn_opt, cmd%local) call global%restore_globals (cmd%local) call cmd%local%deactivate () else cmd%local => global end if end subroutine command_compile_options @ %def command_compile_options @ Execute options. First prepare the local environment, then execute the command list. <>= procedure :: execute_options => cmd_execute_options <>= recursive subroutine cmd_execute_options (cmd, global) class(command_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global if (associated (cmd%options)) then call cmd%local%activate () call cmd%options%execute (cmd%local) end if end subroutine cmd_execute_options @ %def cmd_execute_options @ This must be called after the parent command has been executed, to undo temporary modifications to the environment. Note that some modifications to [[global]] can become permanent. <>= procedure :: reset_options => cmd_reset_options <>= subroutine cmd_reset_options (cmd, global) class(command_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global if (associated (cmd%options)) then call cmd%local%deactivate (global) end if end subroutine cmd_reset_options @ %def cmd_reset_options @ \subsection{Specific command types} \subsubsection{Model configuration} The command declares a model, looks for the specified file and loads it. <>= type, extends (command_t) :: cmd_model_t private type(string_t) :: name type(string_t) :: scheme logical :: ufo_model = .false. logical :: ufo_path_set = .false. type(string_t) :: ufo_path contains <> end type cmd_model_t @ %def cmd_model_t @ Output <>= procedure :: write => cmd_model_write <>= subroutine cmd_model_write (cmd, unit, indent) class(cmd_model_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A,1x,'""',A,'""')", advance="no") "model =", char (cmd%name) if (cmd%ufo_model) then if (cmd%ufo_path_set) then write (u, "(1x,A,A,A)") "(ufo (", char (cmd%ufo_path), "))" else write (u, "(1x,A)") "(ufo)" end if else if (cmd%scheme /= "") then write (u, "(1x,'(',A,')')") char (cmd%scheme) else write (u, *) end if end subroutine cmd_model_write @ %def cmd_model_write @ Compile. Get the model name and read the model from file, so it is readily available when the command list is executed. If the model has a scheme argument, take this into account. Assign the model pointer in the [[global]] record, so it can be used for (read-only) variable lookup while compiling further commands. <>= procedure :: compile => cmd_model_compile <>= subroutine cmd_model_compile (cmd, global) class(cmd_model_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_name, pn_arg, pn_scheme type(parse_node_t), pointer :: pn_ufo_arg, pn_path type(model_t), pointer :: model type(string_t) :: scheme pn_name => cmd%pn%get_sub_ptr (3) pn_arg => pn_name%get_next_ptr () if (associated (pn_arg)) then pn_scheme => pn_arg%get_sub_ptr () else pn_scheme => null () end if cmd%name = pn_name%get_string () if (associated (pn_scheme)) then select case (char (pn_scheme%get_rule_key ())) case ("ufo_spec") cmd%ufo_model = .true. pn_ufo_arg => pn_scheme%get_sub_ptr (2) if (associated (pn_ufo_arg)) then pn_path => pn_ufo_arg%get_sub_ptr () cmd%ufo_path_set = .true. cmd%ufo_path = pn_path%get_string () end if case default scheme = pn_scheme%get_string () select case (char (lower_case (scheme))) case ("ufo"); cmd%ufo_model = .true. case default; cmd%scheme = scheme end select end select if (cmd%ufo_model) then if (cmd%ufo_path_set) then call preload_ufo_model (model, cmd%name, cmd%ufo_path) else call preload_ufo_model (model, cmd%name) end if else call preload_model (model, cmd%name, cmd%scheme) end if else cmd%scheme = "" call preload_model (model, cmd%name) end if global%model => model if (associated (global%model)) then call global%model%link_var_list (global%var_list) end if contains subroutine preload_model (model, name, scheme) type(model_t), pointer, intent(out) :: model type(string_t), intent(in) :: name type(string_t), intent(in), optional :: scheme model => null () if (associated (global%model)) then if (global%model%matches (name, scheme)) then model => global%model end if end if if (.not. associated (model)) then if (global%model_list%model_exists (name, scheme)) then model => global%model_list%get_model_ptr (name, scheme) else call global%read_model (name, model, scheme) end if end if end subroutine preload_model subroutine preload_ufo_model (model, name, ufo_path) type(model_t), pointer, intent(out) :: model type(string_t), intent(in) :: name type(string_t), intent(in), optional :: ufo_path model => null () if (associated (global%model)) then if (global%model%matches (name, ufo=.true., ufo_path=ufo_path)) then model => global%model end if end if if (.not. associated (model)) then if (global%model_list%model_exists (name, & ufo=.true., ufo_path=ufo_path)) then model => global%model_list%get_model_ptr (name, & ufo=.true., ufo_path=ufo_path) else call global%read_ufo_model (name, model, ufo_path=ufo_path) end if end if end subroutine preload_ufo_model end subroutine cmd_model_compile @ %def cmd_model_compile @ Execute: Insert a pointer into the global data record and reassign the variable list. <>= procedure :: execute => cmd_model_execute <>= subroutine cmd_model_execute (cmd, global) class(cmd_model_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global if (cmd%ufo_model) then if (cmd%ufo_path_set) then call global%select_model (cmd%name, ufo=.true., ufo_path=cmd%ufo_path) else call global%select_model (cmd%name, ufo=.true.) end if else if (cmd%scheme /= "") then call global%select_model (cmd%name, cmd%scheme) else call global%select_model (cmd%name) end if if (.not. associated (global%model)) & call msg_fatal ("Switching to model '" & // char (cmd%name) // "': model not found") end subroutine cmd_model_execute @ %def cmd_model_execute @ \subsubsection{Library configuration} We configure a process library that should hold the subsequently defined processes. If the referenced library exists already, just make it the currently active one. <>= type, extends (command_t) :: cmd_library_t private type(string_t) :: name contains <> end type cmd_library_t @ %def cmd_library_t @ Output. <>= procedure :: write => cmd_library_write <>= subroutine cmd_library_write (cmd, unit, indent) class(cmd_library_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit) call write_indent (u, indent) write (u, "(1x,A,1x,'""',A,'""')") "library =", char (cmd%name) end subroutine cmd_library_write @ %def cmd_library_write @ Compile. Get the library name. <>= procedure :: compile => cmd_library_compile <>= subroutine cmd_library_compile (cmd, global) class(cmd_library_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_name pn_name => parse_node_get_sub_ptr (cmd%pn, 3) cmd%name = parse_node_get_string (pn_name) end subroutine cmd_library_compile @ %def cmd_library_compile @ Execute: Initialize a new library and push it on the library stack (if it does not yet exist). Insert a pointer to the library into the global data record. Then, try to load the library unless the [[rebuild]] flag is set. <>= procedure :: execute => cmd_library_execute <>= subroutine cmd_library_execute (cmd, global) class(cmd_library_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(prclib_entry_t), pointer :: lib_entry type(process_library_t), pointer :: lib logical :: rebuild_library lib => global%prclib_stack%get_library_ptr (cmd%name) rebuild_library = & global%var_list%get_lval (var_str ("?rebuild_library")) if (.not. (associated (lib))) then allocate (lib_entry) call lib_entry%init (cmd%name) lib => lib_entry%process_library_t call global%add_prclib (lib_entry) else call global%update_prclib (lib) end if if (associated (lib) .and. .not. rebuild_library) then call lib%update_status (global%os_data) end if end subroutine cmd_library_execute @ %def cmd_library_execute @ \subsubsection{Process configuration} We define a process-configuration command as a specific type. The incoming and outgoing particles are given evaluation-trees which we transform to PDG-code arrays. For transferring to \oMega, they are reconverted to strings. For the incoming particles, we store parse nodes individually. We do not yet resolve the outgoing state, so we store just a single parse node. This also includes the choice of method for the corresponding process: [[omega]] for \oMega\ matrix elements as Fortran code, [[ovm]] for \oMega\ matrix elements as a bytecode virtual machine, [[test]] for special processes, [[unit_test]] for internal test matrix elements generated by \whizard, [[template]] and [[template_unity]] for test matrix elements generated by \whizard\ as Fortran code similar to the \oMega\ code. If the one-loop program (OLP) \gosam\ is linked, also matrix elements from there (at leading and next-to-leading order) can be generated via [[gosam]]. <>= type, extends (command_t) :: cmd_process_t private type(string_t) :: id integer :: n_in = 0 type(parse_node_p), dimension(:), allocatable :: pn_pdg_in type(parse_node_t), pointer :: pn_out => null () contains <> end type cmd_process_t @ %def cmd_process_t @ Output. The particle expressions are not resolved, so we just list the number of incoming particles. <>= procedure :: write => cmd_process_write <>= subroutine cmd_process_write (cmd, unit, indent) class(cmd_process_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A,A,A,I0,A)") "process: ", char (cmd%id), " (", & size (cmd%pn_pdg_in), " -> X)" call cmd%write_options (u, indent) end subroutine cmd_process_write @ %def cmd_process_write @ Compile. Find and assign the parse nodes. <>= procedure :: compile => cmd_process_compile <>= subroutine cmd_process_compile (cmd, global) class(cmd_process_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_id, pn_in, pn_codes integer :: i pn_id => parse_node_get_sub_ptr (cmd%pn, 2) pn_in => parse_node_get_next_ptr (pn_id, 2) cmd%pn_out => parse_node_get_next_ptr (pn_in, 2) cmd%pn_opt => parse_node_get_next_ptr (cmd%pn_out) call cmd%compile_options (global) cmd%id = parse_node_get_string (pn_id) cmd%n_in = parse_node_get_n_sub (pn_in) pn_codes => parse_node_get_sub_ptr (pn_in) allocate (cmd%pn_pdg_in (cmd%n_in)) do i = 1, cmd%n_in cmd%pn_pdg_in(i)%ptr => pn_codes pn_codes => parse_node_get_next_ptr (pn_codes) end do end subroutine cmd_process_compile @ %def cmd_process_compile @ Command execution. Evaluate the subevents, transform PDG codes into strings, and add the current process configuration to the process library. The initial state will be unique (one or two particles). For the final state, we allow for expressions. The expressions will be expanded until we have a sum of final states. Each distinct final state will get its own process component. To identify equivalent final states, we transform the final state into an array of PDG codes, which we sort and compare. If a particle entry is actually a PDG array, only the first entry in the array is used for the comparison. The user should make sure that there is no overlap between different particles or arrays which would make the expansion ambiguous. There are two possibilities that a process contains more than one component: by an explicit component statement by the user for inclusive processes, or by having one process at NLO level. The first option is determined in the chunk [[scan components]], and determines [[n_components]]. <>= procedure :: execute => cmd_process_execute <>= subroutine cmd_process_execute (cmd, global) class(cmd_process_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(pdg_array_t) :: pdg_in, pdg_out type(pdg_array_t), dimension(:), allocatable :: pdg_out_tab type(string_t), dimension(:), allocatable :: prt_in type(string_t) :: prt_out, prt_out1 type(process_configuration_t) :: prc_config type(prt_expr_t) :: prt_expr_out type(prt_spec_t), dimension(:), allocatable :: prt_spec_in type(prt_spec_t), dimension(:), allocatable :: prt_spec_out type(var_list_t), pointer :: var_list integer, dimension(:), allocatable :: ipdg integer, dimension(:), allocatable :: i_term integer, dimension(:), allocatable :: nlo_comp integer :: i, j, n_in, n_out, n_terms, n_components logical :: nlo_fixed_order logical :: qcd_corr, qed_corr type(string_t), dimension(:), allocatable :: prt_in_nlo, prt_out_nlo type(radiation_generator_t) :: radiation_generator type(pdg_list_t) :: pl_in, pl_out, pl_excluded_gauge_splittings type(string_t) :: method, born_me_method, loop_me_method, & correlation_me_method, real_tree_me_method, dglap_me_method integer, dimension(:), allocatable :: i_list logical :: use_real_finite logical :: gks_active logical :: initial_state_colored logical :: neg_sf integer :: comp_mult integer :: gks_multiplicity integer :: n_components_init integer :: alpha_power, alphas_power logical :: requires_soft_mismatch, requires_dglap_remnants type(string_t) :: nlo_correction_type type(pdg_array_t), dimension(:), allocatable :: pdg if (debug_on) call msg_debug (D_CORE, "cmd_process_execute") var_list => cmd%local%get_var_list_ptr () n_in = size (cmd%pn_pdg_in) allocate (prt_in (n_in), prt_spec_in (n_in)) do i = 1, n_in pdg_in = & eval_pdg_array (cmd%pn_pdg_in(i)%ptr, var_list) prt_in(i) = make_flavor_string (pdg_in, cmd%local%model) prt_spec_in(i) = new_prt_spec (prt_in(i)) end do call compile_prt_expr & (prt_expr_out, cmd%pn_out, var_list, cmd%local%model) call prt_expr_out%expand () <> allocate (nlo_comp (n_components)) nlo_fixed_order = cmd%local%nlo_fixed_order gks_multiplicity = var_list%get_ival (var_str ("gks_multiplicity")) gks_active = gks_multiplicity > 2 neg_sf = .false. select case (char (var_list%get_sval (var_str ("$negative_sf")))) case ("default") neg_sf = nlo_fixed_order case ("negative") neg_sf = .true. case ("positive") neg_sf = .false. case default call msg_fatal ("Negative PDF handling can only be " // & "default, negative or positive.") end select <> method = var_list%get_sval (var_str ("$method")) born_me_method = var_list%get_sval (var_str ("$born_me_method")) if (born_me_method == var_str ("")) born_me_method = method select case (char (var_list%get_sval (var_str ("$real_partition_mode")))) case ("default", "off", "singular") use_real_finite = .false. case ("all", "on", "finite") use_real_finite = .true. case default call msg_fatal ("The real partition mode can only be " // & "default, off, all, on, singular or finite.") end select if (nlo_fixed_order) then real_tree_me_method = & var_list%get_sval (var_str ("$real_tree_me_method")) if (real_tree_me_method == var_str ("")) & real_tree_me_method = method loop_me_method = var_list%get_sval (var_str ("$loop_me_method")) if (loop_me_method == var_str ("")) & loop_me_method = method correlation_me_method = & var_list%get_sval (var_str ("$correlation_me_method")) if (correlation_me_method == var_str ("")) & correlation_me_method = method dglap_me_method = var_list%get_sval (var_str ("$dglap_me_method")) if (dglap_me_method == var_str ("")) & dglap_me_method = method call check_nlo_options (cmd%local) end if call determine_needed_components () call prc_config%init (cmd%id, n_in, n_components_init, & cmd%local%model, cmd%local%var_list, & nlo_process = nlo_fixed_order, & negative_sf = neg_sf) alpha_power = var_list%get_ival (var_str ("alpha_power")) alphas_power = var_list%get_ival (var_str ("alphas_power")) call prc_config%set_coupling_powers (alpha_power, alphas_power) call setup_components () call prc_config%record (cmd%local) contains <> end subroutine cmd_process_execute @ %def cmd_process_execute @ <>= elemental function is_threshold (method) logical :: is_threshold type(string_t), intent(in) :: method is_threshold = method == var_str ("threshold") end function is_threshold subroutine check_threshold_consistency () if (nlo_fixed_order .and. is_threshold (born_me_method)) then if (.not. (is_threshold (real_tree_me_method) .and. is_threshold (loop_me_method) & .and. is_threshold (correlation_me_method))) then print *, 'born: ', char (born_me_method) print *, 'real: ', char (real_tree_me_method) print *, 'loop: ', char (loop_me_method) print *, 'correlation: ', char (correlation_me_method) call msg_fatal ("Inconsistent methods: All components need to be threshold") end if end if end subroutine check_threshold_consistency @ %def check_threshold_consistency <>= if (nlo_fixed_order .or. gks_active) then nlo_correction_type = & var_list%get_sval (var_str ('$nlo_correction_type')) select case (char (nlo_correction_type)) case ("QCD") qcd_corr = .true.; qed_corr = .false. case ("EW") qcd_corr = .false.; qed_corr = .true. case ("Full") qcd_corr =.true.; qed_corr = .true. case default call msg_fatal ("Invalid NLO correction type. " // & "Valid inputs are: QCD, EW, Full (default: QCD)") end select call check_for_excluded_gauge_boson_splitting_partners () call setup_radiation_generator () end if if (nlo_fixed_order) then call radiation_generator%find_splittings () if (debug2_active (D_CORE)) then print *, '' print *, 'Found (pdg) splittings: ' do i = 1, radiation_generator%if_table%get_length () call radiation_generator%if_table%get_pdg_out (i, pdg) call pdg_array_write_set (pdg) print *, '----------------' end do end if nlo_fixed_order = radiation_generator%contains_emissions () if (.not. nlo_fixed_order) call msg_warning & (arr = [var_str ("No NLO corrections found for process ") // & cmd%id // var_str("."), var_str ("Proceed with usual " // & "leading-order integration and simulation")]) end if @ %def check_for_nlo_corrections @ <>= subroutine check_for_excluded_gauge_boson_splitting_partners () type(string_t) :: str_excluded_partners type(string_t), dimension(:), allocatable :: excluded_partners type(pdg_list_t) :: pl_tmp, pl_anti integer :: i, n_anti str_excluded_partners = var_list%get_sval & (var_str ("$exclude_gauge_splittings")) if (str_excluded_partners == "") then return else call split_string (str_excluded_partners, & var_str (":"), excluded_partners) call pl_tmp%init (size (excluded_partners)) do i = 1, size (excluded_partners) call pl_tmp%set (i, & cmd%local%model%get_pdg (excluded_partners(i), .true.)) end do call pl_tmp%create_antiparticles (pl_anti, n_anti) call pl_excluded_gauge_splittings%init (pl_tmp%get_size () + n_anti) do i = 1, pl_tmp%get_size () call pl_excluded_gauge_splittings%set (i, pl_tmp%get(i)) end do do i = 1, n_anti j = i + pl_tmp%get_size () call pl_excluded_gauge_splittings%set (j, pl_anti%get(i)) end do end if end subroutine check_for_excluded_gauge_boson_splitting_partners @ %def check_for_excluded_gauge_boson_splitting_partners @ <>= subroutine determine_needed_components () type(string_t) :: fks_method comp_mult = 1 if (nlo_fixed_order) then fks_method = var_list%get_sval (var_str ('$fks_mapping_type')) call check_threshold_consistency () requires_soft_mismatch = fks_method == var_str ('resonances') comp_mult = needed_extra_components (requires_dglap_remnants, & use_real_finite, requires_soft_mismatch) allocate (i_list (comp_mult)) else if (gks_active) then call radiation_generator%generate_multiple & (gks_multiplicity, cmd%local%model) comp_mult = radiation_generator%get_n_gks_states () + 1 end if n_components_init = n_components * comp_mult end subroutine determine_needed_components @ %def determine_needed_components @ <>= subroutine setup_radiation_generator () call split_prt (prt_spec_in, n_in, pl_in) call split_prt (prt_spec_out, n_out, pl_out) call radiation_generator%init (pl_in, pl_out, & pl_excluded_gauge_splittings, qcd = qcd_corr, qed = qed_corr) call radiation_generator%set_n (n_in, n_out, 0) initial_state_colored = pdg_in%has_colored_particles () if ((n_in == 2 .and. initial_state_colored) .or. qed_corr) then requires_dglap_remnants = n_in == 2 .and. initial_state_colored call radiation_generator%set_initial_state_emissions () else requires_dglap_remnants = .false. end if call radiation_generator%set_constraints (.false., .false., .true., .true.) call radiation_generator%setup_if_table (cmd%local%model) end subroutine setup_radiation_generator @ %def setup_radiation_generator @ <>= n_terms = prt_expr_out%get_n_terms () allocate (pdg_out_tab (n_terms)) allocate (i_term (n_terms), source = 0) n_components = 0 SCAN: do i = 1, n_terms if (allocated (ipdg)) deallocate (ipdg) call prt_expr_out%term_to_array (prt_spec_out, i) n_out = size (prt_spec_out) allocate (ipdg (n_out)) do j = 1, n_out prt_out = prt_spec_out(j)%to_string () call split (prt_out, prt_out1, ":") ipdg(j) = cmd%local%model%get_pdg (prt_out1) end do pdg_out = sort (ipdg) do j = 1, n_components if (pdg_out == pdg_out_tab(j)) cycle SCAN end do n_components = n_components + 1 i_term(n_components) = i pdg_out_tab(n_components) = pdg_out end do SCAN @ <>= subroutine split_prt (prt, n_out, pl) type(prt_spec_t), intent(in), dimension(:), allocatable :: prt integer, intent(in) :: n_out type(pdg_list_t), intent(out) :: pl type(pdg_array_t) :: pdg type(string_t) :: prt_string, prt_tmp integer, parameter :: max_particle_number = 25 integer, dimension(max_particle_number) :: i_particle integer :: i, j, n i_particle = 0 call pl%init (n_out) do i = 1, n_out n = 1 prt_string = prt(i)%to_string () do call split (prt_string, prt_tmp, ":") if (prt_tmp /= "") then i_particle(n) = cmd%local%model%get_pdg (prt_tmp) n = n + 1 else exit end if end do call pdg%init (n - 1) do j = 1, n - 1 call pdg%set (j, i_particle(j)) end do call pl%set (i, pdg) call pdg%delete () end do end subroutine split_prt @ %def split_prt @ <>= subroutine setup_components() integer :: k, i_comp, add_index i_comp = 0 add_index = 0 if (debug_on) call msg_debug (D_CORE, "setup_components") do i = 1, n_components call prt_expr_out%term_to_array (prt_spec_out, i_term(i)) if (nlo_fixed_order) then associate (selected_nlo_parts => cmd%local%selected_nlo_parts) if (debug_on) call msg_debug (D_CORE, "Setting up this NLO component:", & i_comp + 1) call prc_config%setup_component (i_comp + 1, & prt_spec_in, prt_spec_out, & cmd%local%model, var_list, BORN, & can_be_integrated = selected_nlo_parts (BORN)) call radiation_generator%generate_real_particle_strings & (prt_in_nlo, prt_out_nlo) if (debug_on) call msg_debug (D_CORE, "Setting up this NLO component:", & i_comp + 2) call prc_config%setup_component (i_comp + 2, & new_prt_spec (prt_in_nlo), new_prt_spec (prt_out_nlo), & cmd%local%model, var_list, NLO_REAL, & can_be_integrated = selected_nlo_parts (NLO_REAL)) if (debug_on) call msg_debug (D_CORE, "Setting up this NLO component:", & i_comp + 3) call prc_config%setup_component (i_comp + 3, & prt_spec_in, prt_spec_out, & cmd%local%model, var_list, NLO_VIRTUAL, & can_be_integrated = selected_nlo_parts (NLO_VIRTUAL)) if (debug_on) call msg_debug (D_CORE, "Setting up this NLO component:", & i_comp + 4) call prc_config%setup_component (i_comp + 4, & prt_spec_in, prt_spec_out, & cmd%local%model, var_list, NLO_SUBTRACTION, & can_be_integrated = selected_nlo_parts (NLO_SUBTRACTION)) do k = 1, 4 i_list(k) = i_comp + k end do if (requires_dglap_remnants) then if (debug_on) call msg_debug (D_CORE, "Setting up this NLO component:", & i_comp + 5) call prc_config%setup_component (i_comp + 5, & prt_spec_in, prt_spec_out, & cmd%local%model, var_list, NLO_DGLAP, & can_be_integrated = selected_nlo_parts (NLO_DGLAP)) i_list(5) = i_comp + 5 add_index = add_index + 1 end if if (use_real_finite) then if (debug_on) call msg_debug (D_CORE, "Setting up this NLO component:", & i_comp + 5 + add_index) call prc_config%setup_component (i_comp + 5 + add_index, & new_prt_spec (prt_in_nlo), new_prt_spec (prt_out_nlo), & cmd%local%model, var_list, NLO_REAL, & can_be_integrated = selected_nlo_parts (NLO_REAL)) i_list(5 + add_index) = i_comp + 5 + add_index add_index = add_index + 1 end if if (requires_soft_mismatch) then if (debug_on) call msg_debug (D_CORE, "Setting up this NLO component:", & i_comp + 5 + add_index) call prc_config%setup_component (i_comp + 5 + add_index, & prt_spec_in, prt_spec_out, & cmd%local%model, var_list, NLO_MISMATCH, & can_be_integrated = selected_nlo_parts (NLO_MISMATCH)) i_list(5 + add_index) = i_comp + 5 + add_index end if call prc_config%set_component_associations (i_list, & requires_dglap_remnants, use_real_finite, & requires_soft_mismatch) end associate else if (gks_active) then call prc_config%setup_component (i_comp + 1, prt_spec_in, & prt_spec_out, cmd%local%model, var_list, BORN, & can_be_integrated = .true.) call radiation_generator%reset_queue () do j = 1, comp_mult prt_out_nlo = radiation_generator%get_next_state () call prc_config%setup_component (i_comp + 1 + j, & new_prt_spec (prt_in), new_prt_spec (prt_out_nlo), & cmd%local%model, var_list, GKS, can_be_integrated = .false.) end do else call prc_config%setup_component (i, & prt_spec_in, prt_spec_out, & cmd%local%model, var_list, can_be_integrated = .true.) end if i_comp = i_comp + comp_mult end do end subroutine setup_components @ @ These three functions should be bundled with the logicals they depend on into an object (the pcm?). <>= subroutine check_nlo_options (local) type(rt_data_t), intent(in) :: local type(var_list_t), pointer :: var_list => null () real :: mult_real, mult_virt, mult_dglap logical :: combined, powheg logical :: case_lo_but_any_other logical :: fixed_order_nlo_events logical :: real_finite_only var_list => local%get_var_list_ptr () combined = var_list%get_lval (var_str ('?combined_nlo_integration')) powheg = var_list%get_lval (var_str ('?powheg_matching')) if (powheg .and. .not. combined) then call msg_fatal ("POWHEG matching requires the 'combined_nlo_integration' & &-option to be set to true.") end if fixed_order_nlo_events = & var_list%get_lval (var_str ('?fixed_order_nlo_events')) if (fixed_order_nlo_events .and. .not. combined .and. & count (local%selected_nlo_parts) > 1) & call msg_fatal ("Option mismatch: Fixed order NLO events of multiple ", & [var_str ("components are requested, but ?combined_nlo_integration "), & var_str ("is false. You can either switch to the combined NLO "), & var_str ("integration mode for the full process or choose one "), & var_str ("individual NLO component to generate events with.")]) real_finite_only = local%var_list%get_sval (var_str ("$real_partition_mode")) == "finite" associate (nlo_parts => local%selected_nlo_parts) ! TODO (PS-2020-03-26): This technically leaves the possibility to skip this ! message by deactivating the dglap component for a proton collider process. ! To circumvent this, the selected_nlo_parts should be refactored. if (combined .and. .not. (nlo_parts(BORN) & .and. nlo_parts(NLO_VIRTUAL) .and. nlo_parts(NLO_REAL))) then call msg_fatal ("A combined integration of anything else than", & [var_str ("all NLO components together is not supported.")]) end if if (real_finite_only .and. combined) then call msg_fatal ("You cannot do a combined integration without", & [var_str ("the real singular component.")]) end if if (real_finite_only .and. count(nlo_parts([BORN,NLO_VIRTUAL,NLO_DGLAP])) > 1) then call msg_fatal ("You cannot do a full NLO integration without", & [var_str ("the real singular component.")]) end if end associate mult_real = local%var_list%get_rval (var_str ("mult_call_real")) mult_virt = local%var_list%get_rval (var_str ("mult_call_virt")) mult_dglap = local%var_list%get_rval (var_str ("mult_call_dglap")) if (combined .and. (mult_real /= one .or. mult_virt /= one .or. mult_dglap /= one)) then call msg_warning ("mult_call_real, mult_call_virt and mult_call_dglap", & [var_str (" will be ignored because of ?combined_nlo_integration = true. ")]) end if end subroutine check_nlo_options @ %def check_nlo_options @ There are four components for a general NLO process, namely Born, real, virtual and subtraction. There will be additional components for DGLAP remnant, in case real contributions are split into singular and finite pieces, and for resonance-aware FKS subtraction for the needed soft mismatch component. <>= pure function needed_extra_components (requires_dglap_remnant, & use_real_finite, requires_soft_mismatch) result (n) integer :: n logical, intent(in) :: requires_dglap_remnant, & use_real_finite, requires_soft_mismatch n = 4 if (requires_dglap_remnant) n = n + 1 if (use_real_finite) n = n + 1 if (requires_soft_mismatch) n = n + 1 end function needed_extra_components @ %def needed_extra_components @ This is a method of the eval tree, but cannot be coded inside the [[expressions]] module since it uses the [[model]] and [[flv]] types which are not available there. <>= function make_flavor_string (aval, model) result (prt) type(string_t) :: prt type(pdg_array_t), intent(in) :: aval type(model_t), intent(in), target :: model integer, dimension(:), allocatable :: pdg type(flavor_t), dimension(:), allocatable :: flv integer :: i pdg = aval allocate (flv (size (pdg))) call flv%init (pdg, model) if (size (pdg) /= 0) then prt = flv(1)%get_name () do i = 2, size (flv) prt = prt // ":" // flv(i)%get_name () end do else prt = "?" end if end function make_flavor_string @ %def make_flavor_string @ Create a pdg array from a particle-specification array <>= function make_pdg_array (prt, model) result (pdg_array) type(prt_spec_t), intent(in), dimension(:) :: prt type(model_t), intent(in) :: model integer, dimension(:), allocatable :: aval type(pdg_array_t) :: pdg_array type(flavor_t) :: flv integer :: k allocate (aval (size (prt))) do k = 1, size (prt) call flv%init (prt(k)%to_string (), model) aval (k) = flv%get_pdg () end do pdg_array = aval end function make_pdg_array @ %def make_pdg_array @ Compile a (possible nested) expression, to obtain a particle-specifier expression which we can process further. <>= recursive subroutine compile_prt_expr (prt_expr, pn, var_list, model) type(prt_expr_t), intent(out) :: prt_expr type(parse_node_t), intent(in), target :: pn type(var_list_t), intent(in), target :: var_list type(model_t), intent(in), target :: model type(parse_node_t), pointer :: pn_entry, pn_term, pn_addition type(pdg_array_t) :: pdg type(string_t) :: prt_string integer :: n_entry, n_term, i select case (char (parse_node_get_rule_key (pn))) case ("prt_state_list") n_entry = parse_node_get_n_sub (pn) pn_entry => parse_node_get_sub_ptr (pn) if (n_entry == 1) then call compile_prt_expr (prt_expr, pn_entry, var_list, model) else call prt_expr%init_list (n_entry) select type (x => prt_expr%x) type is (prt_spec_list_t) do i = 1, n_entry call compile_prt_expr (x%expr(i), pn_entry, var_list, model) pn_entry => parse_node_get_next_ptr (pn_entry) end do end select end if case ("prt_state_sum") n_term = parse_node_get_n_sub (pn) pn_term => parse_node_get_sub_ptr (pn) pn_addition => pn_term if (n_term == 1) then call compile_prt_expr (prt_expr, pn_term, var_list, model) else call prt_expr%init_sum (n_term) select type (x => prt_expr%x) type is (prt_spec_sum_t) do i = 1, n_term call compile_prt_expr (x%expr(i), pn_term, var_list, model) pn_addition => parse_node_get_next_ptr (pn_addition) if (associated (pn_addition)) & pn_term => parse_node_get_sub_ptr (pn_addition, 2) end do end select end if case ("cexpr") pdg = eval_pdg_array (pn, var_list) prt_string = make_flavor_string (pdg, model) call prt_expr%init_spec (new_prt_spec (prt_string)) case default call parse_node_write_rec (pn) call msg_bug ("compile prt expr: impossible syntax rule") end select end subroutine compile_prt_expr @ %def compile_prt_expr @ \subsubsection{Initiating a NLO calculation} <>= type, extends (command_t) :: cmd_nlo_t private integer, dimension(:), allocatable :: nlo_component contains <> end type cmd_nlo_t @ %def cmd_nlo_t @ <>= procedure :: write => cmd_nlo_write <>= subroutine cmd_nlo_write (cmd, unit, indent) class(cmd_nlo_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent end subroutine cmd_nlo_write @ %def cmd_nlo_write @ As it is, the NLO calculation is switched on by putting {nlo} behind the process definition. This should be made nicer in the future. <>= procedure :: compile => cmd_nlo_compile <>= subroutine cmd_nlo_compile (cmd, global) class(cmd_nlo_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_arg, pn_comp integer :: i, n_comp pn_arg => parse_node_get_sub_ptr (cmd%pn, 3) if (associated (pn_arg)) then n_comp = parse_node_get_n_sub (pn_arg) allocate (cmd%nlo_component (n_comp)) pn_comp => parse_node_get_sub_ptr (pn_arg) i = 0 do while (associated (pn_comp)) i = i + 1 cmd%nlo_component(i) = component_status & (parse_node_get_rule_key (pn_comp)) pn_comp => parse_node_get_next_ptr (pn_comp) end do else allocate (cmd%nlo_component (0)) end if end subroutine cmd_nlo_compile @ %def cmd_nlo_compile @ % TODO (PS-2020-03-26): This routine still needs to be adopted % to cope with more than 5 components. <>= procedure :: execute => cmd_nlo_execute <>= subroutine cmd_nlo_execute (cmd, global) class(cmd_nlo_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(string_t) :: string integer :: n, i, j logical, dimension(0:5) :: selected_nlo_parts if (debug_on) call msg_debug (D_CORE, "cmd_nlo_execute") selected_nlo_parts = .false. if (allocated (cmd%nlo_component)) then n = size (cmd%nlo_component) else n = 0 end if do i = 1, n select case (cmd%nlo_component (i)) case (BORN, NLO_VIRTUAL, NLO_MISMATCH, NLO_DGLAP, NLO_REAL) selected_nlo_parts(cmd%nlo_component (i)) = .true. case (NLO_FULL) selected_nlo_parts = .true. selected_nlo_parts (NLO_SUBTRACTION) = .false. case default string = var_str ("") do j = BORN, NLO_DGLAP string = string // component_status (j) // ", " end do string = string // component_status (NLO_FULL) call msg_fatal ("Invalid NLO mode. Valid modes are: " // & char (string)) end select end do global%nlo_fixed_order = any (selected_nlo_parts) global%selected_nlo_parts = selected_nlo_parts allocate (global%nlo_component (size (cmd%nlo_component))) global%nlo_component = cmd%nlo_component end subroutine cmd_nlo_execute @ %def cmd_nlo_execute @ \subsubsection{Process compilation} <>= type, extends (command_t) :: cmd_compile_t private type(string_t), dimension(:), allocatable :: libname logical :: make_executable = .false. type(string_t) :: exec_name contains <> end type cmd_compile_t @ %def cmd_compile_t @ Output: list all libraries to be compiled. <>= procedure :: write => cmd_compile_write <>= subroutine cmd_compile_write (cmd, unit, indent) class(cmd_compile_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u, i u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)", advance="no") "compile (" if (allocated (cmd%libname)) then do i = 1, size (cmd%libname) if (i > 1) write (u, "(A,1x)", advance="no") "," write (u, "('""',A,'""')", advance="no") char (cmd%libname(i)) end do end if write (u, "(A)") ")" end subroutine cmd_compile_write @ %def cmd_compile_write @ Compile the libraries specified in the argument. If the argument is empty, compile all libraries which can be found in the process library stack. <>= procedure :: compile => cmd_compile_compile <>= subroutine cmd_compile_compile (cmd, global) class(cmd_compile_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_cmd, pn_clause, pn_arg, pn_lib type(parse_node_t), pointer :: pn_exec_name_spec, pn_exec_name integer :: n_lib, i pn_cmd => parse_node_get_sub_ptr (cmd%pn) pn_clause => parse_node_get_sub_ptr (pn_cmd) pn_exec_name_spec => parse_node_get_sub_ptr (pn_clause, 2) if (associated (pn_exec_name_spec)) then pn_exec_name => parse_node_get_sub_ptr (pn_exec_name_spec, 2) else pn_exec_name => null () end if pn_arg => parse_node_get_next_ptr (pn_clause) cmd%pn_opt => parse_node_get_next_ptr (pn_cmd) call cmd%compile_options (global) if (associated (pn_arg)) then n_lib = parse_node_get_n_sub (pn_arg) else n_lib = 0 end if if (n_lib > 0) then allocate (cmd%libname (n_lib)) pn_lib => parse_node_get_sub_ptr (pn_arg) do i = 1, n_lib cmd%libname(i) = parse_node_get_string (pn_lib) pn_lib => parse_node_get_next_ptr (pn_lib) end do end if if (associated (pn_exec_name)) then cmd%make_executable = .true. cmd%exec_name = parse_node_get_string (pn_exec_name) end if end subroutine cmd_compile_compile @ %def cmd_compile_compile @ Command execution. Generate code, write driver, compile and link. Do this for all libraries in the list. If no library names have been given and stored while compiling this command, we collect all libraries from the current stack and compile those. As a bonus, a compiled library may be able to spawn new process libraries. For instance, a processes may ask for a set of resonant subprocesses which go into their own library, but this can be determined only after the process is available as a compiled object. Therefore, the compilation loop is implemented as a recursive internal subroutine. We can compile static libraries (which actually just loads them). However, we can't incorporate in a generated executable. <>= procedure :: execute => cmd_compile_execute <>= subroutine cmd_compile_execute (cmd, global) class(cmd_compile_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(string_t), dimension(:), allocatable :: libname, libname_static integer :: i, n_lib <> <> if (allocated (cmd%libname)) then allocate (libname (size (cmd%libname))) libname = cmd%libname else call cmd%local%prclib_stack%get_names (libname) end if n_lib = size (libname) if (cmd%make_executable) then call get_prclib_static (libname_static) do i = 1, n_lib if (any (libname_static == libname(i))) then call msg_fatal ("Compile: can't include static library '" & // char (libname(i)) // "'") end if end do call compile_executable (cmd%exec_name, libname, cmd%local) else call compile_libraries (libname) call global%update_prclib & (global%prclib_stack%get_library_ptr (libname(n_lib))) end if <> contains recursive subroutine compile_libraries (libname) type(string_t), dimension(:), intent(in) :: libname integer :: i type(string_t), dimension(:), allocatable :: libname_extra type(process_library_t), pointer :: lib_saved do i = 1, size (libname) call compile_library (libname(i), cmd%local) lib_saved => global%prclib call spawn_extra_libraries & (libname(i), cmd%local, global, libname_extra) call compile_libraries (libname_extra) call global%update_prclib (lib_saved) end do end subroutine compile_libraries end subroutine cmd_compile_execute @ %def cmd_compile_execute <>= <>= <>= @ The parallelization leads to undefined behavior while writing simultaneously to one file. The master worker has to initialize single-handed the corresponding library files. The slave worker will wait with a blocking [[MPI_BCAST]] until they receive a logical flag. <>= logical :: compile_init integer :: rank, n_size <>= if (debug_on) call msg_debug (D_MPI, "cmd_compile_execute") compile_init = .false. call mpi_get_comm_id (n_size, rank) if (debug_on) call msg_debug (D_MPI, "n_size", rank) if (debug_on) call msg_debug (D_MPI, "rank", rank) if (rank /= 0) then if (debug_on) call msg_debug (D_MPI, "wait for master") call MPI_bcast (compile_init, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD) else compile_init = .true. end if if (compile_init) then <>= if (rank == 0) then if (debug_on) call msg_debug (D_MPI, "load slaves") call MPI_bcast (compile_init, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD) end if end if call MPI_barrier (MPI_COMM_WORLD) @ %def cmd_compile_execute_mpi @ This is the interface to the external procedure which returns the names of all static libraries which are part of the executable. (The default is none.) The routine must allocate the array. <>= public :: get_prclib_static <>= interface subroutine get_prclib_static (libname) import type(string_t), dimension(:), intent(inout), allocatable :: libname end subroutine get_prclib_static end interface @ %def get_prclib_static @ Spawn extra libraries. We can ask the processes within a compiled library, which we have available at this point, whether they need additional processes which should go into their own libraries. The current implementation only concerns resonant subprocesses. Note that the libraries should be created (source code), but not be compiled here. This is done afterwards. <>= subroutine spawn_extra_libraries (libname, local, global, libname_extra) type(string_t), intent(in) :: libname type(rt_data_t), intent(inout), target :: local type(rt_data_t), intent(inout), target :: global type(string_t), dimension(:), allocatable, intent(out) :: libname_extra type(string_t), dimension(:), allocatable :: libname_res allocate (libname_extra (0)) call spawn_resonant_subprocess_libraries & (libname, local, global, libname_res) if (allocated (libname_res)) libname_extra = [libname_extra, libname_res] end subroutine spawn_extra_libraries @ %def spawn_extra_libraries @ \subsubsection{Execute a shell command} The argument is a string expression. <>= type, extends (command_t) :: cmd_exec_t private type(parse_node_t), pointer :: pn_command => null () contains <> end type cmd_exec_t @ %def cmd_exec_t @ Simply tell the status. <>= procedure :: write => cmd_exec_write <>= subroutine cmd_exec_write (cmd, unit, indent) class(cmd_exec_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) if (associated (cmd%pn_command)) then write (u, "(1x,A)") "exec: [command associated]" else write (u, "(1x,A)") "exec: [undefined]" end if end subroutine cmd_exec_write @ %def cmd_exec_write @ Compile the exec command. <>= procedure :: compile => cmd_exec_compile <>= subroutine cmd_exec_compile (cmd, global) class(cmd_exec_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_arg, pn_command pn_arg => parse_node_get_sub_ptr (cmd%pn, 2) pn_command => parse_node_get_sub_ptr (pn_arg) cmd%pn_command => pn_command end subroutine cmd_exec_compile @ %def cmd_exec_compile @ Execute the specified shell command. <>= procedure :: execute => cmd_exec_execute <>= subroutine cmd_exec_execute (cmd, global) class(cmd_exec_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(string_t) :: command logical :: is_known integer :: status command = eval_string (cmd%pn_command, global%var_list, is_known=is_known) if (is_known) then if (command /= "") then call os_system_call (command, status, verbose=.true.) if (status /= 0) then write (msg_buffer, "(A,I0)") "Return code = ", status call msg_message () call msg_error ("System command returned with nonzero status code") end if end if end if end subroutine cmd_exec_execute @ %def cmd_exec_execute @ \subsubsection{Variable declaration} A variable can have various types. Hold the definition as an eval tree. There are intrinsic variables, user variables, and model variables. The latter are further divided in independent variables and dependent variables. Regarding model variables: When dealing with them, we always look at two variable lists in parallel. The global (or local) variable list contains the user-visible values. It includes variables that correspond to variables in the current model's list. These, in turn, are pointers to the model's parameter list, so the model is always in sync, internally. To keep the global variable list in sync with the model, the global variables carry the [[is_copy]] property and contain a separate pointer to the model variable. (The pointer is reassigned whenever the model changes.) Modifying the global variable changes two values simultaneously: the visible value and the model variable, via this extra pointer. After each modification, we update dependent parameters in the model variable list and re-synchronize the global variable list (again, using these pointers) with the model variable this. In the last step, modifications in the derived parameters become visible. When we integrate a process, we capture the current variable list of the current model in a separate model instance, which is stored in the process object. Thus, the model parameters associated to this process at this time are preserved for the lifetime of the process object. When we generate or rescan events, we can again capture a local model variable list in a model instance. This allows us to reweight event by event with different parameter sets simultaneously. <>= type, extends (command_t) :: cmd_var_t private type(string_t) :: name integer :: type = V_NONE type(parse_node_t), pointer :: pn_value => null () logical :: is_intrinsic = .false. logical :: is_model_var = .false. contains <> end type cmd_var_t @ %def cmd_var_t @ Output. We know name, type, and properties, but not the value. <>= procedure :: write => cmd_var_write <>= subroutine cmd_var_write (cmd, unit, indent) class(cmd_var_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A,A,A)", advance="no") "var: ", char (cmd%name), " (" select case (cmd%type) case (V_NONE) write (u, "(A)", advance="no") "[unknown]" case (V_LOG) write (u, "(A)", advance="no") "logical" case (V_INT) write (u, "(A)", advance="no") "int" case (V_REAL) write (u, "(A)", advance="no") "real" case (V_CMPLX) write (u, "(A)", advance="no") "complex" case (V_STR) write (u, "(A)", advance="no") "string" case (V_PDG) write (u, "(A)", advance="no") "alias" end select if (cmd%is_intrinsic) then write (u, "(A)", advance="no") ", intrinsic" end if if (cmd%is_model_var) then write (u, "(A)", advance="no") ", model" end if write (u, "(A)") ")" end subroutine cmd_var_write @ %def cmd_var_write @ Compile the lhs and determine the variable name and type. Check whether this variable can be created or modified as requested, and append the value to the variable list, if appropriate. The value is initially undefined. The rhs is assigned to a pointer, to be compiled and evaluated when the command is executed. <>= procedure :: compile => cmd_var_compile <>= subroutine cmd_var_compile (cmd, global) class(cmd_var_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_var, pn_name type(parse_node_t), pointer :: pn_result, pn_proc type(string_t) :: var_name type(var_list_t), pointer :: model_vars integer :: type logical :: new pn_result => null () new = .false. select case (char (parse_node_get_rule_key (cmd%pn))) case ("cmd_log_decl"); type = V_LOG pn_var => parse_node_get_sub_ptr (cmd%pn, 2) if (.not. associated (pn_var)) then ! handle masked syntax error cmd%type = V_NONE; return end if pn_name => parse_node_get_sub_ptr (pn_var, 2) new = .true. case ("cmd_log"); type = V_LOG pn_name => parse_node_get_sub_ptr (cmd%pn, 2) case ("cmd_int"); type = V_INT pn_name => parse_node_get_sub_ptr (cmd%pn, 2) new = .true. case ("cmd_real"); type = V_REAL pn_name => parse_node_get_sub_ptr (cmd%pn, 2) new = .true. case ("cmd_complex"); type = V_CMPLX pn_name => parse_node_get_sub_ptr (cmd%pn, 2) new = .true. case ("cmd_num"); type = V_NONE pn_name => parse_node_get_sub_ptr (cmd%pn) case ("cmd_string_decl"); type = V_STR pn_var => parse_node_get_sub_ptr (cmd%pn, 2) if (.not. associated (pn_var)) then ! handle masked syntax error cmd%type = V_NONE; return end if pn_name => parse_node_get_sub_ptr (pn_var, 2) new = .true. case ("cmd_string"); type = V_STR pn_name => parse_node_get_sub_ptr (cmd%pn, 2) case ("cmd_alias"); type = V_PDG pn_name => parse_node_get_sub_ptr (cmd%pn, 2) new = .true. case ("cmd_result"); type = V_REAL pn_name => parse_node_get_sub_ptr (cmd%pn) pn_result => parse_node_get_sub_ptr (pn_name) pn_proc => parse_node_get_next_ptr (pn_result) case default call parse_node_mismatch & ("logical|int|real|complex|?|$|alias|var_name", cmd%pn) ! $ end select if (.not. associated (pn_name)) then ! handle masked syntax error cmd%type = V_NONE; return end if if (.not. associated (pn_result)) then var_name = parse_node_get_string (pn_name) else var_name = parse_node_get_key (pn_result) & // "(" // parse_node_get_string (pn_proc) // ")" end if select case (type) case (V_LOG); var_name = "?" // var_name case (V_STR); var_name = "$" // var_name ! $ end select if (associated (global%model)) then model_vars => global%model%get_var_list_ptr () else model_vars => null () end if call var_list_check_observable (global%var_list, var_name, type) call var_list_check_result_var (global%var_list, var_name, type) call global%var_list%check_user_var (var_name, type, new) cmd%name = var_name cmd%pn_value => parse_node_get_next_ptr (pn_name, 2) if (global%var_list%contains (cmd%name, follow_link = .false.)) then ! local variable cmd%is_intrinsic = & global%var_list%is_intrinsic (cmd%name, follow_link = .false.) cmd%type = & global%var_list%get_type (cmd%name, follow_link = .false.) else if (new) cmd%type = type if (global%var_list%contains (cmd%name, follow_link = .true.)) then ! global variable cmd%is_intrinsic = & global%var_list%is_intrinsic (cmd%name, follow_link = .true.) if (cmd%type == V_NONE) then cmd%type = & global%var_list%get_type (cmd%name, follow_link = .true.) end if else if (associated (model_vars)) then ! check model variable cmd%is_model_var = & model_vars%contains (cmd%name) if (cmd%type == V_NONE) then cmd%type = & model_vars%get_type (cmd%name) end if end if if (cmd%type == V_NONE) then call msg_fatal ("Variable '" // char (cmd%name) // "' " & // "set without declaration") cmd%type = V_NONE; return end if if (cmd%is_model_var) then if (new) then call msg_fatal ("Model variable '" // char (cmd%name) // "' " & // "redeclared") else if (model_vars%is_locked (cmd%name)) then call msg_fatal ("Model variable '" // char (cmd%name) // "' " & // "is locked") end if else select case (cmd%type) case (V_LOG) call global%var_list%append_log (cmd%name, & intrinsic=cmd%is_intrinsic, user=.true.) case (V_INT) call global%var_list%append_int (cmd%name, & intrinsic=cmd%is_intrinsic, user=.true.) case (V_REAL) call global%var_list%append_real (cmd%name, & intrinsic=cmd%is_intrinsic, user=.true.) case (V_CMPLX) call global%var_list%append_cmplx (cmd%name, & intrinsic=cmd%is_intrinsic, user=.true.) case (V_PDG) call global%var_list%append_pdg_array (cmd%name, & intrinsic=cmd%is_intrinsic, user=.true.) case (V_STR) call global%var_list%append_string (cmd%name, & intrinsic=cmd%is_intrinsic, user=.true.) end select end if end if end subroutine cmd_var_compile @ %def cmd_var_compile @ Execute. Evaluate the definition and assign the variable value. If the variable is a model variable, take a snapshot of the model if necessary and set the variable in the local model. <>= procedure :: execute => cmd_var_execute <>= subroutine cmd_var_execute (cmd, global) class(cmd_var_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list real(default) :: rval logical :: is_known, pacified var_list => global%get_var_list_ptr () if (cmd%is_model_var) then pacified = var_list%get_lval (var_str ("?pacify")) rval = eval_real (cmd%pn_value, var_list, is_known=is_known) call global%model_set_real & (cmd%name, rval, verbose=.true., pacified=pacified) else if (cmd%type /= V_NONE) then call cmd%set_value (var_list, verbose=.true.) end if end subroutine cmd_var_execute @ %def cmd_var_execute @ Copy the value to the variable list, where the variable should already exist. <>= procedure :: set_value => cmd_var_set_value <>= subroutine cmd_var_set_value (var, var_list, verbose, model_name) class(cmd_var_t), intent(inout) :: var type(var_list_t), intent(inout), target :: var_list logical, intent(in), optional :: verbose type(string_t), intent(in), optional :: model_name logical :: lval, pacified integer :: ival real(default) :: rval complex(default) :: cval type(pdg_array_t) :: aval type(string_t) :: sval logical :: is_known pacified = var_list%get_lval (var_str ("?pacify")) select case (var%type) case (V_LOG) lval = eval_log (var%pn_value, var_list, is_known=is_known) call var_list%set_log (var%name, & lval, is_known, verbose=verbose, model_name=model_name) case (V_INT) ival = eval_int (var%pn_value, var_list, is_known=is_known) call var_list%set_int (var%name, & ival, is_known, verbose=verbose, model_name=model_name) case (V_REAL) rval = eval_real (var%pn_value, var_list, is_known=is_known) call var_list%set_real (var%name, & rval, is_known, verbose=verbose, & model_name=model_name, pacified = pacified) case (V_CMPLX) cval = eval_cmplx (var%pn_value, var_list, is_known=is_known) call var_list%set_cmplx (var%name, & cval, is_known, verbose=verbose, & model_name=model_name, pacified = pacified) case (V_PDG) aval = eval_pdg_array (var%pn_value, var_list, is_known=is_known) call var_list%set_pdg_array (var%name, & aval, is_known, verbose=verbose, model_name=model_name) case (V_STR) sval = eval_string (var%pn_value, var_list, is_known=is_known) call var_list%set_string (var%name, & sval, is_known, verbose=verbose, model_name=model_name) end select end subroutine cmd_var_set_value @ %def cmd_var_set_value @ \subsubsection{SLHA} Read a SLHA (SUSY Les Houches Accord) file to fill the appropriate model parameters. We do not access the current variable record, but directly work on the appropriate SUSY model, which is loaded if necessary. We may be in read or write mode. In the latter case, we may write just input parameters, or the complete spectrum, or the spectrum with all decays. <>= type, extends (command_t) :: cmd_slha_t private type(string_t) :: file logical :: write_mode = .false. contains <> end type cmd_slha_t @ %def cmd_slha_t @ Output. <>= procedure :: write => cmd_slha_write <>= subroutine cmd_slha_write (cmd, unit, indent) class(cmd_slha_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A,A)") "slha: file name = ", char (cmd%file) write (u, "(1x,A,L1)") "slha: write mode = ", cmd%write_mode end subroutine cmd_slha_write @ %def cmd_slha_write @ Compile. Read the filename and store it. <>= procedure :: compile => cmd_slha_compile <>= subroutine cmd_slha_compile (cmd, global) class(cmd_slha_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_key, pn_arg, pn_file pn_key => parse_node_get_sub_ptr (cmd%pn) pn_arg => parse_node_get_next_ptr (pn_key) pn_file => parse_node_get_sub_ptr (pn_arg) call cmd%compile_options (global) cmd%pn_opt => parse_node_get_next_ptr (pn_arg) select case (char (parse_node_get_key (pn_key))) case ("read_slha") cmd%write_mode = .false. case ("write_slha") cmd%write_mode = .true. case default call parse_node_mismatch ("read_slha|write_slha", cmd%pn) end select cmd%file = parse_node_get_string (pn_file) end subroutine cmd_slha_compile @ %def cmd_slha_compile @ Execute. Read or write the specified SLHA file. Behind the scenes, this will first read the WHIZARD model file, then read the SLHA file and assign the SLHA parameters as far as determined by [[dispatch_slha]]. Finally, the global variables are synchronized with the model. This is similar to executing [[cmd_model]]. <>= procedure :: execute => cmd_slha_execute <>= subroutine cmd_slha_execute (cmd, global) class(cmd_slha_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global logical :: input, spectrum, decays if (cmd%write_mode) then input = .true. spectrum = .false. decays = .false. if (.not. associated (cmd%local%model)) then call msg_fatal ("SLHA: local model not associated") return end if call slha_write_file & (cmd%file, cmd%local%model, & input = input, spectrum = spectrum, decays = decays) else if (.not. associated (global%model)) then call msg_fatal ("SLHA: global model not associated") return end if call dispatch_slha (cmd%local%var_list, & input = input, spectrum = spectrum, decays = decays) call global%ensure_model_copy () call slha_read_file & (cmd%file, cmd%local%os_data, global%model, & input = input, spectrum = spectrum, decays = decays) end if end subroutine cmd_slha_execute @ %def cmd_slha_execute @ \subsubsection{Show values} This command shows the current values of variables or other objects, in a suitably condensed form. <>= type, extends (command_t) :: cmd_show_t private type(string_t), dimension(:), allocatable :: name contains <> end type cmd_show_t @ %def cmd_show_t @ Output: list the object names, not values. <>= procedure :: write => cmd_show_write <>= subroutine cmd_show_write (cmd, unit, indent) class(cmd_show_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u, i u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)", advance="no") "show: " if (allocated (cmd%name)) then do i = 1, size (cmd%name) write (u, "(1x,A)", advance="no") char (cmd%name(i)) end do write (u, *) else write (u, "(5x,A)") "[undefined]" end if end subroutine cmd_show_write @ %def cmd_show_write @ Compile. Allocate an array which is filled with the names of the variables to show. <>= procedure :: compile => cmd_show_compile <>= subroutine cmd_show_compile (cmd, global) class(cmd_show_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_arg, pn_var, pn_prefix, pn_name type(string_t) :: key integer :: i, n_args pn_arg => parse_node_get_sub_ptr (cmd%pn, 2) if (associated (pn_arg)) then select case (char (parse_node_get_rule_key (pn_arg))) case ("show_arg") cmd%pn_opt => parse_node_get_next_ptr (pn_arg) case default cmd%pn_opt => pn_arg pn_arg => null () end select end if call cmd%compile_options (global) if (associated (pn_arg)) then n_args = parse_node_get_n_sub (pn_arg) allocate (cmd%name (n_args)) pn_var => parse_node_get_sub_ptr (pn_arg) i = 0 do while (associated (pn_var)) i = i + 1 select case (char (parse_node_get_rule_key (pn_var))) case ("model", "library", "beams", "iterations", & "cuts", "weight", "int", "real", "complex", & "scale", "factorization_scale", "renormalization_scale", & "selection", "reweight", "analysis", "pdg", & "stable", "unstable", "polarized", "unpolarized", & "results", "expect", "intrinsic", "string", "logical") cmd%name(i) = parse_node_get_key (pn_var) case ("result_var") pn_prefix => parse_node_get_sub_ptr (pn_var) pn_name => parse_node_get_next_ptr (pn_prefix) if (associated (pn_name)) then cmd%name(i) = parse_node_get_key (pn_prefix) & // "(" // parse_node_get_string (pn_name) // ")" else cmd%name(i) = parse_node_get_key (pn_prefix) end if case ("log_var", "string_var", "alias_var") pn_prefix => parse_node_get_sub_ptr (pn_var) pn_name => parse_node_get_next_ptr (pn_prefix) key = parse_node_get_key (pn_prefix) if (associated (pn_name)) then select case (char (parse_node_get_rule_key (pn_name))) case ("var_name") select case (char (key)) case ("?", "$") ! $ sign cmd%name(i) = key // parse_node_get_string (pn_name) case ("alias") cmd%name(i) = parse_node_get_string (pn_name) end select case default call parse_node_mismatch & ("var_name", pn_name) end select else cmd%name(i) = key end if case default cmd%name(i) = parse_node_get_string (pn_var) end select pn_var => parse_node_get_next_ptr (pn_var) end do else allocate (cmd%name (0)) end if end subroutine cmd_show_compile @ %def cmd_show_compile @ Execute. Scan the list of objects to show. <>= integer, parameter, public :: SHOW_BUFFER_SIZE = 4096 <>= procedure :: execute => cmd_show_execute <>= subroutine cmd_show_execute (cmd, global) class(cmd_show_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list, model_vars type(model_t), pointer :: model type(string_t) :: name integer :: n, pdg type(flavor_t) :: flv type(process_library_t), pointer :: prc_lib type(process_t), pointer :: process logical :: pacified character(SHOW_BUFFER_SIZE) :: buffer type(string_t) :: out_file integer :: i, j, u, u_log, u_out, u_ext u = free_unit () var_list => cmd%local%var_list if (associated (cmd%local%model)) then model_vars => cmd%local%model%get_var_list_ptr () else model_vars => null () end if pacified = var_list%get_lval (var_str ("?pacify")) out_file = var_list%get_sval (var_str ("$out_file")) if (file_list_is_open (global%out_files, out_file, action="write")) then call msg_message ("show: copying output to file '" & // char (out_file) // "'") u_ext = file_list_get_unit (global%out_files, out_file) else u_ext = -1 end if open (u, status = "scratch", action = "readwrite") if (associated (cmd%local%model)) then name = cmd%local%model%get_name () end if if (size (cmd%name) == 0) then if (associated (model_vars)) then call model_vars%write (model_name = name, & unit = u, pacified = pacified, follow_link = .false.) end if call var_list%write (unit = u, pacified = pacified) else do i = 1, size (cmd%name) select case (char (cmd%name(i))) case ("model") if (associated (cmd%local%model)) then call cmd%local%model%show (u) else write (u, "(A)") "Model: [undefined]" end if case ("library") if (associated (cmd%local%prclib)) then call cmd%local%prclib%show (u) else write (u, "(A)") "Process library: [undefined]" end if case ("beams") call cmd%local%show_beams (u) case ("iterations") call cmd%local%it_list%write (u) case ("results") call cmd%local%process_stack%show (u, fifo=.true.) case ("stable") call cmd%local%model%show_stable (u) case ("polarized") call cmd%local%model%show_polarized (u) case ("unpolarized") call cmd%local%model%show_unpolarized (u) case ("unstable") model => cmd%local%model call model%show_unstable (u) n = model%get_n_field () do j = 1, n pdg = model%get_pdg (j) call flv%init (pdg, model) if (.not. flv%is_stable ()) & call show_unstable (cmd%local, pdg, u) if (flv%has_antiparticle ()) then associate (anti => flv%anti ()) if (.not. anti%is_stable ()) & call show_unstable (cmd%local, -pdg, u) end associate end if end do case ("cuts", "weight", "scale", & "factorization_scale", "renormalization_scale", & "selection", "reweight", "analysis") call cmd%local%pn%show (cmd%name(i), u) case ("expect") call expect_summary (force = .true.) case ("intrinsic") call var_list%write (intrinsic=.true., unit=u, & pacified = pacified) case ("logical") if (associated (model_vars)) then call model_vars%write (only_type=V_LOG, & model_name = name, unit=u, pacified = pacified, & follow_link=.false.) end if call var_list%write (& only_type=V_LOG, unit=u, pacified = pacified) case ("int") if (associated (model_vars)) then call model_vars%write (only_type=V_INT, & model_name = name, unit=u, pacified = pacified, & follow_link=.false.) end if call var_list%write (only_type=V_INT, & unit=u, pacified = pacified) case ("real") if (associated (model_vars)) then call model_vars%write (only_type=V_REAL, & model_name = name, unit=u, pacified = pacified, & follow_link=.false.) end if call var_list%write (only_type=V_REAL, & unit=u, pacified = pacified) case ("complex") if (associated (model_vars)) then call model_vars%write (only_type=V_CMPLX, & model_name = name, unit=u, pacified = pacified, & follow_link=.false.) end if call var_list%write (only_type=V_CMPLX, & unit=u, pacified = pacified) case ("pdg") if (associated (model_vars)) then call model_vars%write (only_type=V_PDG, & model_name = name, unit=u, pacified = pacified, & follow_link=.false.) end if call var_list%write (only_type=V_PDG, & unit=u, pacified = pacified) case ("string") if (associated (model_vars)) then call model_vars%write (only_type=V_STR, & model_name = name, unit=u, pacified = pacified, & follow_link=.false.) end if call var_list%write (only_type=V_STR, & unit=u, pacified = pacified) case default if (analysis_exists (cmd%name(i))) then call analysis_write (cmd%name(i), u) else if (cmd%local%process_stack%exists (cmd%name(i))) then process => cmd%local%process_stack%get_process_ptr (cmd%name(i)) call process%show (u) else if (associated (cmd%local%prclib_stack%get_library_ptr & (cmd%name(i)))) then prc_lib => cmd%local%prclib_stack%get_library_ptr (cmd%name(i)) call prc_lib%show (u) else if (associated (model_vars)) then if (model_vars%contains (cmd%name(i), follow_link=.false.)) then call model_vars%write_var (cmd%name(i), & unit = u, model_name = name, pacified = pacified) else if (var_list%contains (cmd%name(i))) then call var_list%write_var (cmd%name(i), & unit = u, pacified = pacified) else call msg_error ("show: object '" // char (cmd%name(i)) & // "' not found") end if else if (var_list%contains (cmd%name(i))) then call var_list%write_var (cmd%name(i), & unit = u, pacified = pacified) else call msg_error ("show: object '" // char (cmd%name(i)) & // "' not found") end if end select end do end if rewind (u) u_log = logfile_unit () u_out = given_output_unit () do read (u, "(A)", end = 1) buffer if (u_log > 0) write (u_log, "(A)") trim (buffer) if (u_out > 0) write (u_out, "(A)") trim (buffer) if (u_ext > 0) write (u_ext, "(A)") trim (buffer) end do 1 close (u) if (u_log > 0) flush (u_log) if (u_out > 0) flush (u_out) if (u_ext > 0) flush (u_ext) end subroutine cmd_show_execute @ %def cmd_show_execute @ \subsubsection{Clear values} This command clears the current values of variables or other objects, where this makes sense. It parallels the [[show]] command. The objects are cleared, but not deleted. <>= type, extends (command_t) :: cmd_clear_t private type(string_t), dimension(:), allocatable :: name contains <> end type cmd_clear_t @ %def cmd_clear_t @ Output: list the names of the objects to be cleared. <>= procedure :: write => cmd_clear_write <>= subroutine cmd_clear_write (cmd, unit, indent) class(cmd_clear_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u, i u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)", advance="no") "clear: " if (allocated (cmd%name)) then do i = 1, size (cmd%name) write (u, "(1x,A)", advance="no") char (cmd%name(i)) end do write (u, *) else write (u, "(5x,A)") "[undefined]" end if end subroutine cmd_clear_write @ %def cmd_clear_write @ Compile. Allocate an array which is filled with the names of the objects to be cleared. Note: there is currently no need to account for options, but we prepare for that possibility. <>= procedure :: compile => cmd_clear_compile <>= subroutine cmd_clear_compile (cmd, global) class(cmd_clear_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_arg, pn_var, pn_prefix, pn_name type(string_t) :: key integer :: i, n_args pn_arg => parse_node_get_sub_ptr (cmd%pn, 2) if (associated (pn_arg)) then select case (char (parse_node_get_rule_key (pn_arg))) case ("clear_arg") cmd%pn_opt => parse_node_get_next_ptr (pn_arg) case default cmd%pn_opt => pn_arg pn_arg => null () end select end if call cmd%compile_options (global) if (associated (pn_arg)) then n_args = parse_node_get_n_sub (pn_arg) allocate (cmd%name (n_args)) pn_var => parse_node_get_sub_ptr (pn_arg) i = 0 do while (associated (pn_var)) i = i + 1 select case (char (parse_node_get_rule_key (pn_var))) case ("beams", "iterations", & "cuts", "weight", & "scale", "factorization_scale", "renormalization_scale", & "selection", "reweight", "analysis", & "unstable", "polarized", & "expect") cmd%name(i) = parse_node_get_key (pn_var) case ("log_var", "string_var") pn_prefix => parse_node_get_sub_ptr (pn_var) pn_name => parse_node_get_next_ptr (pn_prefix) key = parse_node_get_key (pn_prefix) if (associated (pn_name)) then select case (char (parse_node_get_rule_key (pn_name))) case ("var_name") select case (char (key)) case ("?", "$") ! $ sign cmd%name(i) = key // parse_node_get_string (pn_name) end select case default call parse_node_mismatch & ("var_name", pn_name) end select else cmd%name(i) = key end if case default cmd%name(i) = parse_node_get_string (pn_var) end select pn_var => parse_node_get_next_ptr (pn_var) end do else allocate (cmd%name (0)) end if end subroutine cmd_clear_compile @ %def cmd_clear_compile @ Execute. Scan the list of objects to clear. Objects that can be shown but not cleared: model, library, results <>= procedure :: execute => cmd_clear_execute <>= subroutine cmd_clear_execute (cmd, global) class(cmd_clear_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global integer :: i logical :: success type(var_list_t), pointer :: model_vars if (size (cmd%name) == 0) then call msg_warning ("clear: no object specified") else do i = 1, size (cmd%name) success = .true. select case (char (cmd%name(i))) case ("beams") call cmd%local%clear_beams () case ("iterations") call cmd%local%it_list%clear () case ("polarized") call cmd%local%model%clear_polarized () case ("unstable") call cmd%local%model%clear_unstable () case ("cuts", "weight", "scale", & "factorization_scale", "renormalization_scale", & "selection", "reweight", "analysis") call cmd%local%pn%clear (cmd%name(i)) case ("expect") call expect_clear () case default if (analysis_exists (cmd%name(i))) then call analysis_clear (cmd%name(i)) else if (cmd%local%var_list%contains (cmd%name(i))) then if (.not. cmd%local%var_list%is_locked (cmd%name(i))) then call cmd%local%var_list%unset (cmd%name(i)) else call msg_error ("clear: variable '" // char (cmd%name(i)) & // "' is locked and can't be cleared") success = .false. end if else if (associated (cmd%local%model)) then model_vars => cmd%local%model%get_var_list_ptr () if (model_vars%contains (cmd%name(i), follow_link=.false.)) then call msg_error ("clear: variable '" // char (cmd%name(i)) & // "' is a model variable and can't be cleared") else call msg_error ("clear: object '" // char (cmd%name(i)) & // "' not found") end if success = .false. else call msg_error ("clear: object '" // char (cmd%name(i)) & // "' not found") success = .false. end if end select if (success) call msg_message ("cleared: " // char (cmd%name(i))) end do end if end subroutine cmd_clear_execute @ %def cmd_clear_execute @ \subsubsection{Compare values of variables to expectation} The implementation is similar to the [[show]] command. There are just two arguments: two values that should be compared. For providing local values for the numerical tolerance, the command has a local argument list. If the expectation fails, an error condition is recorded. <>= type, extends (command_t) :: cmd_expect_t private type(parse_node_t), pointer :: pn_lexpr => null () contains <> end type cmd_expect_t @ %def cmd_expect_t @ Simply tell the status. <>= procedure :: write => cmd_expect_write <>= subroutine cmd_expect_write (cmd, unit, indent) class(cmd_expect_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) if (associated (cmd%pn_lexpr)) then write (u, "(1x,A)") "expect: [expression associated]" else write (u, "(1x,A)") "expect: [undefined]" end if end subroutine cmd_expect_write @ %def cmd_expect_write @ Compile. This merely assigns the parse node, the actual compilation is done at execution. This is necessary because the origin of variables (local/global) may change during execution. <>= procedure :: compile => cmd_expect_compile <>= subroutine cmd_expect_compile (cmd, global) class(cmd_expect_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_arg pn_arg => parse_node_get_sub_ptr (cmd%pn, 2) cmd%pn_opt => parse_node_get_next_ptr (pn_arg) cmd%pn_lexpr => parse_node_get_sub_ptr (pn_arg) call cmd%compile_options (global) end subroutine cmd_expect_compile @ %def cmd_expect_compile @ Execute. Evaluate both arguments, print them and their difference (if numerical), and whether they agree. Record the result. <>= procedure :: execute => cmd_expect_execute <>= subroutine cmd_expect_execute (cmd, global) class(cmd_expect_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list logical :: success, is_known var_list => cmd%local%get_var_list_ptr () success = eval_log (cmd%pn_lexpr, var_list, is_known=is_known) if (is_known) then if (success) then call msg_message ("expect: success") else call msg_error ("expect: failure") end if else call msg_error ("expect: undefined result") success = .false. end if call expect_record (success) end subroutine cmd_expect_execute @ %def cmd_expect_execute @ \subsubsection{Beams} The beam command includes both beam and structure-function definition. <>= type, extends (command_t) :: cmd_beams_t private integer :: n_in = 0 type(parse_node_p), dimension(:), allocatable :: pn_pdg integer :: n_sf_record = 0 integer, dimension(:), allocatable :: n_entry type(parse_node_p), dimension(:,:), allocatable :: pn_sf_entry contains <> end type cmd_beams_t @ %def cmd_beams_t @ Output. The particle expressions are not resolved. <>= procedure :: write => cmd_beams_write <>= subroutine cmd_beams_write (cmd, unit, indent) class(cmd_beams_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) select case (cmd%n_in) case (1) write (u, "(1x,A)") "beams: 1 [decay]" case (2) write (u, "(1x,A)") "beams: 2 [scattering]" case default write (u, "(1x,A)") "beams: [undefined]" end select if (allocated (cmd%n_entry)) then if (cmd%n_sf_record > 0) then write (u, "(1x,A,99(1x,I0))") "structure function entries:", & cmd%n_entry end if end if end subroutine cmd_beams_write @ %def cmd_beams_write @ Compile. Find and assign the parse nodes. Note: local environments are not yet supported. <>= procedure :: compile => cmd_beams_compile <>= subroutine cmd_beams_compile (cmd, global) class(cmd_beams_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_beam_def, pn_beam_spec type(parse_node_t), pointer :: pn_beam_list type(parse_node_t), pointer :: pn_codes type(parse_node_t), pointer :: pn_strfun_seq, pn_strfun_pair type(parse_node_t), pointer :: pn_strfun_def integer :: i pn_beam_def => parse_node_get_sub_ptr (cmd%pn, 3) pn_beam_spec => parse_node_get_sub_ptr (pn_beam_def) pn_strfun_seq => parse_node_get_next_ptr (pn_beam_spec) pn_beam_list => parse_node_get_sub_ptr (pn_beam_spec) call cmd%compile_options (global) cmd%n_in = parse_node_get_n_sub (pn_beam_list) allocate (cmd%pn_pdg (cmd%n_in)) pn_codes => parse_node_get_sub_ptr (pn_beam_list) do i = 1, cmd%n_in cmd%pn_pdg(i)%ptr => pn_codes pn_codes => parse_node_get_next_ptr (pn_codes) end do if (associated (pn_strfun_seq)) then cmd%n_sf_record = parse_node_get_n_sub (pn_beam_def) - 1 allocate (cmd%n_entry (cmd%n_sf_record), source = 1) allocate (cmd%pn_sf_entry (2, cmd%n_sf_record)) do i = 1, cmd%n_sf_record pn_strfun_pair => parse_node_get_sub_ptr (pn_strfun_seq, 2) pn_strfun_def => parse_node_get_sub_ptr (pn_strfun_pair) cmd%pn_sf_entry(1,i)%ptr => pn_strfun_def pn_strfun_def => parse_node_get_next_ptr (pn_strfun_def) cmd%pn_sf_entry(2,i)%ptr => pn_strfun_def if (associated (pn_strfun_def)) cmd%n_entry(i) = 2 pn_strfun_seq => parse_node_get_next_ptr (pn_strfun_seq) end do else allocate (cmd%n_entry (0)) allocate (cmd%pn_sf_entry (0, 0)) end if end subroutine cmd_beams_compile @ %def cmd_beams_compile @ Command execution: Determine beam particles and structure-function names, if any. The results are stored in the [[beam_structure]] component of the [[global]] data block. <>= procedure :: execute => cmd_beams_execute <>= subroutine cmd_beams_execute (cmd, global) class(cmd_beams_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list type(pdg_array_t) :: pdg_array integer, dimension(:), allocatable :: pdg type(flavor_t), dimension(:), allocatable :: flv type(parse_node_t), pointer :: pn_key type(string_t) :: sf_name integer :: i, j call lhapdf_global_reset () var_list => cmd%local%get_var_list_ptr () allocate (flv (cmd%n_in)) do i = 1, cmd%n_in pdg_array = eval_pdg_array (cmd%pn_pdg(i)%ptr, var_list) pdg = pdg_array select case (size (pdg)) case (1) call flv(i)%init ( pdg(1), cmd%local%model) case default call msg_fatal ("Beams: beam particles must be unique") end select end do select case (cmd%n_in) case (1) if (cmd%n_sf_record > 0) then call msg_fatal ("Beam setup: no structure functions allowed & &for decay") end if call global%beam_structure%init_sf (flv%get_name ()) case (2) call global%beam_structure%init_sf (flv%get_name (), cmd%n_entry) do i = 1, cmd%n_sf_record do j = 1, cmd%n_entry(i) pn_key => parse_node_get_sub_ptr (cmd%pn_sf_entry(j,i)%ptr) sf_name = parse_node_get_key (pn_key) call global%beam_structure%set_sf (i, j, sf_name) end do end do end select end subroutine cmd_beams_execute @ %def cmd_beams_execute @ \subsubsection{Density matrices for beam polarization} For holding beam polarization, we define a notation and a data structure for sparse matrices. The entries (and the index expressions) are numerical expressions, so we use evaluation trees. Each entry in the sparse matrix is an n-tuple of expressions. The first tuple elements represent index values, the last one is an arbitrary (complex) number. Absent expressions are replaced by default-value rules. Note: Here, and in some other commands, we would like to store an evaluation tree, not just a parse node pointer. However, the current expression handler wants all variables defined, so the evaluation tree can only be built by [[evaluate]], i.e., compiled just-in-time and evaluated immediately. <>= type :: sentry_expr_t type(parse_node_p), dimension(:), allocatable :: expr contains <> end type sentry_expr_t @ %def sentry_expr_t @ Compile parse nodes into evaluation trees. <>= procedure :: compile => sentry_expr_compile <>= subroutine sentry_expr_compile (sentry, pn) class(sentry_expr_t), intent(out) :: sentry type(parse_node_t), intent(in), target :: pn type(parse_node_t), pointer :: pn_expr, pn_extra integer :: n_expr, i n_expr = parse_node_get_n_sub (pn) allocate (sentry%expr (n_expr)) if (n_expr > 0) then i = 0 pn_expr => parse_node_get_sub_ptr (pn) pn_extra => parse_node_get_next_ptr (pn_expr) do i = 1, n_expr sentry%expr(i)%ptr => pn_expr if (associated (pn_extra)) then pn_expr => parse_node_get_sub_ptr (pn_extra, 2) pn_extra => parse_node_get_next_ptr (pn_extra) end if end do end if end subroutine sentry_expr_compile @ %def sentry_expr_compile @ Evaluate the expressions and return an index array of predefined length together with a complex value. If the value (as the last expression) is undefined, set it to unity. If index values are undefined, repeat the previous index value. <>= procedure :: evaluate => sentry_expr_evaluate <>= subroutine sentry_expr_evaluate (sentry, index, value, global) class(sentry_expr_t), intent(inout) :: sentry integer, dimension(:), intent(out) :: index complex(default), intent(out) :: value type(rt_data_t), intent(in), target :: global type(var_list_t), pointer :: var_list integer :: i, n_expr, n_index type(eval_tree_t) :: eval_tree var_list => global%get_var_list_ptr () n_expr = size (sentry%expr) n_index = size (index) if (n_expr <= n_index + 1) then do i = 1, min (n_expr, n_index) associate (expr => sentry%expr(i)) call eval_tree%init_expr (expr%ptr, var_list) call eval_tree%evaluate () if (eval_tree%is_known ()) then index(i) = eval_tree%get_int () else call msg_fatal ("Evaluating density matrix: undefined index") end if end associate end do do i = n_expr + 1, n_index index(i) = index(n_expr) end do if (n_expr == n_index + 1) then associate (expr => sentry%expr(n_expr)) call eval_tree%init_expr (expr%ptr, var_list) call eval_tree%evaluate () if (eval_tree%is_known ()) then value = eval_tree%get_cmplx () else call msg_fatal ("Evaluating density matrix: undefined index") end if call eval_tree%final () end associate else value = 1 end if else call msg_fatal ("Evaluating density matrix: index expression too long") end if end subroutine sentry_expr_evaluate @ %def sentry_expr_evaluate @ The sparse matrix itself consists of an arbitrary number of entries. <>= type :: smatrix_expr_t type(sentry_expr_t), dimension(:), allocatable :: entry contains <> end type smatrix_expr_t @ %def smatrix_expr_t @ Compile: assign sub-nodes to sentry-expressions and compile those. <>= procedure :: compile => smatrix_expr_compile <>= subroutine smatrix_expr_compile (smatrix_expr, pn) class(smatrix_expr_t), intent(out) :: smatrix_expr type(parse_node_t), intent(in), target :: pn type(parse_node_t), pointer :: pn_arg, pn_entry integer :: n_entry, i pn_arg => parse_node_get_sub_ptr (pn, 2) if (associated (pn_arg)) then n_entry = parse_node_get_n_sub (pn_arg) allocate (smatrix_expr%entry (n_entry)) pn_entry => parse_node_get_sub_ptr (pn_arg) do i = 1, n_entry call smatrix_expr%entry(i)%compile (pn_entry) pn_entry => parse_node_get_next_ptr (pn_entry) end do else allocate (smatrix_expr%entry (0)) end if end subroutine smatrix_expr_compile @ %def smatrix_expr_compile @ Evaluate the entries and build a new [[smatrix]] object, which contains just the numerical results. <>= procedure :: evaluate => smatrix_expr_evaluate <>= subroutine smatrix_expr_evaluate (smatrix_expr, smatrix, global) class(smatrix_expr_t), intent(inout) :: smatrix_expr type(smatrix_t), intent(out) :: smatrix type(rt_data_t), intent(in), target :: global integer, dimension(2) :: idx complex(default) :: value integer :: i, n_entry n_entry = size (smatrix_expr%entry) call smatrix%init (2, n_entry) do i = 1, n_entry call smatrix_expr%entry(i)%evaluate (idx, value, global) call smatrix%set_entry (i, idx, value) end do end subroutine smatrix_expr_evaluate @ %def smatrix_expr_evaluate @ \subsubsection{Beam polarization density} The beam polarization command defines spin density matrix for one or two beams (scattering or decay). <>= type, extends (command_t) :: cmd_beams_pol_density_t private integer :: n_in = 0 type(smatrix_expr_t), dimension(:), allocatable :: smatrix contains <> end type cmd_beams_pol_density_t @ %def cmd_beams_pol_density_t @ Output. <>= procedure :: write => cmd_beams_pol_density_write <>= subroutine cmd_beams_pol_density_write (cmd, unit, indent) class(cmd_beams_pol_density_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) select case (cmd%n_in) case (1) write (u, "(1x,A)") "beams polarization setup: 1 [decay]" case (2) write (u, "(1x,A)") "beams polarization setup: 2 [scattering]" case default write (u, "(1x,A)") "beams polarization setup: [undefined]" end select end subroutine cmd_beams_pol_density_write @ %def cmd_beams_pol_density_write @ Compile. Find and assign the parse nodes. Note: local environments are not yet supported. <>= procedure :: compile => cmd_beams_pol_density_compile <>= subroutine cmd_beams_pol_density_compile (cmd, global) class(cmd_beams_pol_density_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_pol_spec, pn_smatrix integer :: i pn_pol_spec => parse_node_get_sub_ptr (cmd%pn, 3) call cmd%compile_options (global) cmd%n_in = parse_node_get_n_sub (pn_pol_spec) allocate (cmd%smatrix (cmd%n_in)) pn_smatrix => parse_node_get_sub_ptr (pn_pol_spec) do i = 1, cmd%n_in call cmd%smatrix(i)%compile (pn_smatrix) pn_smatrix => parse_node_get_next_ptr (pn_smatrix) end do end subroutine cmd_beams_pol_density_compile @ %def cmd_beams_pol_density_compile @ Command execution: Fill polarization density matrices. No check yet, the matrices are checked and normalized when the actual beam object is created, just before integration. For intermediate storage, we use the [[beam_structure]] object in the [[global]] data set. <>= procedure :: execute => cmd_beams_pol_density_execute <>= subroutine cmd_beams_pol_density_execute (cmd, global) class(cmd_beams_pol_density_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(smatrix_t) :: smatrix integer :: i call global%beam_structure%init_pol (cmd%n_in) do i = 1, cmd%n_in call cmd%smatrix(i)%evaluate (smatrix, global) call global%beam_structure%set_smatrix (i, smatrix) end do end subroutine cmd_beams_pol_density_execute @ %def cmd_beams_pol_density_execute @ \subsubsection{Beam polarization fraction} In addition to the polarization density matrix, we can independently specify the polarization fraction for one or both beams. <>= type, extends (command_t) :: cmd_beams_pol_fraction_t private integer :: n_in = 0 type(parse_node_p), dimension(:), allocatable :: expr contains <> end type cmd_beams_pol_fraction_t @ %def cmd_beams_pol_fraction_t @ Output. <>= procedure :: write => cmd_beams_pol_fraction_write <>= subroutine cmd_beams_pol_fraction_write (cmd, unit, indent) class(cmd_beams_pol_fraction_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) select case (cmd%n_in) case (1) write (u, "(1x,A)") "beams polarization fraction: 1 [decay]" case (2) write (u, "(1x,A)") "beams polarization fraction: 2 [scattering]" case default write (u, "(1x,A)") "beams polarization fraction: [undefined]" end select end subroutine cmd_beams_pol_fraction_write @ %def cmd_beams_pol_fraction_write @ Compile. Find and assign the parse nodes. Note: local environments are not yet supported. <>= procedure :: compile => cmd_beams_pol_fraction_compile <>= subroutine cmd_beams_pol_fraction_compile (cmd, global) class(cmd_beams_pol_fraction_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_frac_spec, pn_expr integer :: i pn_frac_spec => parse_node_get_sub_ptr (cmd%pn, 3) call cmd%compile_options (global) cmd%n_in = parse_node_get_n_sub (pn_frac_spec) allocate (cmd%expr (cmd%n_in)) pn_expr => parse_node_get_sub_ptr (pn_frac_spec) do i = 1, cmd%n_in cmd%expr(i)%ptr => pn_expr pn_expr => parse_node_get_next_ptr (pn_expr) end do end subroutine cmd_beams_pol_fraction_compile @ %def cmd_beams_pol_fraction_compile @ Command execution: Retrieve the numerical values of the beam polarization fractions. The results are stored in the [[beam_structure]] component of the [[global]] data block. <>= procedure :: execute => cmd_beams_pol_fraction_execute <>= subroutine cmd_beams_pol_fraction_execute (cmd, global) class(cmd_beams_pol_fraction_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list real(default), dimension(:), allocatable :: pol_f type(eval_tree_t) :: expr integer :: i var_list => global%get_var_list_ptr () allocate (pol_f (cmd%n_in)) do i = 1, cmd%n_in call expr%init_expr (cmd%expr(i)%ptr, var_list) call expr%evaluate () if (expr%is_known ()) then pol_f(i) = expr%get_real () else call msg_fatal ("beams polarization fraction: undefined value") end if call expr%final () end do call global%beam_structure%set_pol_f (pol_f) end subroutine cmd_beams_pol_fraction_execute @ %def cmd_beams_pol_fraction_execute @ \subsubsection{Beam momentum} This is completely analogous to the previous command, hence we can use inheritance. <>= type, extends (cmd_beams_pol_fraction_t) :: cmd_beams_momentum_t contains <> end type cmd_beams_momentum_t @ %def cmd_beams_momentum_t @ Output. <>= procedure :: write => cmd_beams_momentum_write <>= subroutine cmd_beams_momentum_write (cmd, unit, indent) class(cmd_beams_momentum_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) select case (cmd%n_in) case (1) write (u, "(1x,A)") "beams momentum: 1 [decay]" case (2) write (u, "(1x,A)") "beams momentum: 2 [scattering]" case default write (u, "(1x,A)") "beams momentum: [undefined]" end select end subroutine cmd_beams_momentum_write @ %def cmd_beams_momentum_write @ Compile: inherited. Command execution: Not inherited, but just the error string and the final command are changed. <>= procedure :: execute => cmd_beams_momentum_execute <>= subroutine cmd_beams_momentum_execute (cmd, global) class(cmd_beams_momentum_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list real(default), dimension(:), allocatable :: p type(eval_tree_t) :: expr integer :: i var_list => global%get_var_list_ptr () allocate (p (cmd%n_in)) do i = 1, cmd%n_in call expr%init_expr (cmd%expr(i)%ptr, var_list) call expr%evaluate () if (expr%is_known ()) then p(i) = expr%get_real () else call msg_fatal ("beams momentum: undefined value") end if call expr%final () end do call global%beam_structure%set_momentum (p) end subroutine cmd_beams_momentum_execute @ %def cmd_beams_momentum_execute @ \subsubsection{Beam angles} Again, this is analogous. There are two angles, polar angle $\theta$ and azimuthal angle $\phi$, which can be set independently for both beams. <>= type, extends (cmd_beams_pol_fraction_t) :: cmd_beams_theta_t contains <> end type cmd_beams_theta_t type, extends (cmd_beams_pol_fraction_t) :: cmd_beams_phi_t contains <> end type cmd_beams_phi_t @ %def cmd_beams_theta_t @ %def cmd_beams_phi_t @ Output. <>= procedure :: write => cmd_beams_theta_write <>= procedure :: write => cmd_beams_phi_write <>= subroutine cmd_beams_theta_write (cmd, unit, indent) class(cmd_beams_theta_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) select case (cmd%n_in) case (1) write (u, "(1x,A)") "beams theta: 1 [decay]" case (2) write (u, "(1x,A)") "beams theta: 2 [scattering]" case default write (u, "(1x,A)") "beams theta: [undefined]" end select end subroutine cmd_beams_theta_write subroutine cmd_beams_phi_write (cmd, unit, indent) class(cmd_beams_phi_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) select case (cmd%n_in) case (1) write (u, "(1x,A)") "beams phi: 1 [decay]" case (2) write (u, "(1x,A)") "beams phi: 2 [scattering]" case default write (u, "(1x,A)") "beams phi: [undefined]" end select end subroutine cmd_beams_phi_write @ %def cmd_beams_theta_write @ %def cmd_beams_phi_write @ Compile: inherited. Command execution: Not inherited, but just the error string and the final command are changed. <>= procedure :: execute => cmd_beams_theta_execute <>= procedure :: execute => cmd_beams_phi_execute <>= subroutine cmd_beams_theta_execute (cmd, global) class(cmd_beams_theta_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list real(default), dimension(:), allocatable :: theta type(eval_tree_t) :: expr integer :: i var_list => global%get_var_list_ptr () allocate (theta (cmd%n_in)) do i = 1, cmd%n_in call expr%init_expr (cmd%expr(i)%ptr, var_list) call expr%evaluate () if (expr%is_known ()) then theta(i) = expr%get_real () else call msg_fatal ("beams theta: undefined value") end if call expr%final () end do call global%beam_structure%set_theta (theta) end subroutine cmd_beams_theta_execute subroutine cmd_beams_phi_execute (cmd, global) class(cmd_beams_phi_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list real(default), dimension(:), allocatable :: phi type(eval_tree_t) :: expr integer :: i var_list => global%get_var_list_ptr () allocate (phi (cmd%n_in)) do i = 1, cmd%n_in call expr%init_expr (cmd%expr(i)%ptr, var_list) call expr%evaluate () if (expr%is_known ()) then phi(i) = expr%get_real () else call msg_fatal ("beams phi: undefined value") end if call expr%final () end do call global%beam_structure%set_phi (phi) end subroutine cmd_beams_phi_execute @ %def cmd_beams_theta_execute @ %def cmd_beams_phi_execute @ \subsubsection{Cuts} Define a cut expression. We store the parse tree for the right-hand side instead of compiling it. Compilation is deferred to the process environment where the cut expression is used. <>= type, extends (command_t) :: cmd_cuts_t private type(parse_node_t), pointer :: pn_lexpr => null () contains <> end type cmd_cuts_t @ %def cmd_cuts_t @ Output. Do not print the parse tree, since this may get cluttered. Just a message that cuts have been defined. <>= procedure :: write => cmd_cuts_write <>= subroutine cmd_cuts_write (cmd, unit, indent) class(cmd_cuts_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)") "cuts: [defined]" end subroutine cmd_cuts_write @ %def cmd_cuts_write @ Compile. Simply store the parse (sub)tree. <>= procedure :: compile => cmd_cuts_compile <>= subroutine cmd_cuts_compile (cmd, global) class(cmd_cuts_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global cmd%pn_lexpr => parse_node_get_sub_ptr (cmd%pn, 3) end subroutine cmd_cuts_compile @ %def cmd_cuts_compile @ Instead of evaluating the cut expression, link the parse tree to the global data set, such that it is compiled and executed in the appropriate process context. <>= procedure :: execute => cmd_cuts_execute <>= subroutine cmd_cuts_execute (cmd, global) class(cmd_cuts_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global global%pn%cuts_lexpr => cmd%pn_lexpr end subroutine cmd_cuts_execute @ %def cmd_cuts_execute @ \subsubsection{General, Factorization and Renormalization Scales} Define a scale expression for either the renormalization or the factorization scale. We store the parse tree for the right-hand side instead of compiling it. Compilation is deferred to the process environment where the expression is used. <>= type, extends (command_t) :: cmd_scale_t private type(parse_node_t), pointer :: pn_expr => null () contains <> end type cmd_scale_t @ %def cmd_scale_t <>= type, extends (command_t) :: cmd_fac_scale_t private type(parse_node_t), pointer :: pn_expr => null () contains <> end type cmd_fac_scale_t @ %def cmd_fac_scale_t <>= type, extends (command_t) :: cmd_ren_scale_t private type(parse_node_t), pointer :: pn_expr => null () contains <> end type cmd_ren_scale_t @ %def cmd_ren_scale_t @ Output. Do not print the parse tree, since this may get cluttered. Just a message that scale, renormalization and factorization have been defined, respectively. <>= procedure :: write => cmd_scale_write <>= subroutine cmd_scale_write (cmd, unit, indent) class(cmd_scale_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)") "scale: [defined]" end subroutine cmd_scale_write @ %def cmd_scale_write @ <>= procedure :: write => cmd_fac_scale_write <>= subroutine cmd_fac_scale_write (cmd, unit, indent) class(cmd_fac_scale_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)") "factorization scale: [defined]" end subroutine cmd_fac_scale_write @ %def cmd_fac_scale_write @ <>= procedure :: write => cmd_ren_scale_write <>= subroutine cmd_ren_scale_write (cmd, unit, indent) class(cmd_ren_scale_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)") "renormalization scale: [defined]" end subroutine cmd_ren_scale_write @ %def cmd_ren_scale_write @ Compile. Simply store the parse (sub)tree. <>= procedure :: compile => cmd_scale_compile <>= subroutine cmd_scale_compile (cmd, global) class(cmd_scale_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global cmd%pn_expr => parse_node_get_sub_ptr (cmd%pn, 3) end subroutine cmd_scale_compile @ %def cmd_scale_compile @ <>= procedure :: compile => cmd_fac_scale_compile <>= subroutine cmd_fac_scale_compile (cmd, global) class(cmd_fac_scale_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global cmd%pn_expr => parse_node_get_sub_ptr (cmd%pn, 3) end subroutine cmd_fac_scale_compile @ %def cmd_fac_scale_compile @ <>= procedure :: compile => cmd_ren_scale_compile <>= subroutine cmd_ren_scale_compile (cmd, global) class(cmd_ren_scale_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global cmd%pn_expr => parse_node_get_sub_ptr (cmd%pn, 3) end subroutine cmd_ren_scale_compile @ %def cmd_ren_scale_compile @ Instead of evaluating the scale expression, link the parse tree to the global data set, such that it is compiled and executed in the appropriate process context. <>= procedure :: execute => cmd_scale_execute <>= subroutine cmd_scale_execute (cmd, global) class(cmd_scale_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global global%pn%scale_expr => cmd%pn_expr end subroutine cmd_scale_execute @ %def cmd_scale_execute @ <>= procedure :: execute => cmd_fac_scale_execute <>= subroutine cmd_fac_scale_execute (cmd, global) class(cmd_fac_scale_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global global%pn%fac_scale_expr => cmd%pn_expr end subroutine cmd_fac_scale_execute @ %def cmd_fac_scale_execute @ <>= procedure :: execute => cmd_ren_scale_execute <>= subroutine cmd_ren_scale_execute (cmd, global) class(cmd_ren_scale_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global global%pn%ren_scale_expr => cmd%pn_expr end subroutine cmd_ren_scale_execute @ %def cmd_ren_scale_execute @ \subsubsection{Weight} Define a weight expression. The weight is applied to a process to be integrated, event by event. We store the parse tree for the right-hand side instead of compiling it. Compilation is deferred to the process environment where the expression is used. <>= type, extends (command_t) :: cmd_weight_t private type(parse_node_t), pointer :: pn_expr => null () contains <> end type cmd_weight_t @ %def cmd_weight_t @ Output. Do not print the parse tree, since this may get cluttered. Just a message that scale, renormalization and factorization have been defined, respectively. <>= procedure :: write => cmd_weight_write <>= subroutine cmd_weight_write (cmd, unit, indent) class(cmd_weight_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)") "weight expression: [defined]" end subroutine cmd_weight_write @ %def cmd_weight_write @ Compile. Simply store the parse (sub)tree. <>= procedure :: compile => cmd_weight_compile <>= subroutine cmd_weight_compile (cmd, global) class(cmd_weight_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global cmd%pn_expr => parse_node_get_sub_ptr (cmd%pn, 3) end subroutine cmd_weight_compile @ %def cmd_weight_compile @ Instead of evaluating the expression, link the parse tree to the global data set, such that it is compiled and executed in the appropriate process context. <>= procedure :: execute => cmd_weight_execute <>= subroutine cmd_weight_execute (cmd, global) class(cmd_weight_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global global%pn%weight_expr => cmd%pn_expr end subroutine cmd_weight_execute @ %def cmd_weight_execute @ \subsubsection{Selection} Define a selection expression. This is to be applied upon simulation or event-file rescanning, event by event. We store the parse tree for the right-hand side instead of compiling it. Compilation is deferred to the environment where the expression is used. <>= type, extends (command_t) :: cmd_selection_t private type(parse_node_t), pointer :: pn_expr => null () contains <> end type cmd_selection_t @ %def cmd_selection_t @ Output. Do not print the parse tree, since this may get cluttered. Just a message that scale, renormalization and factorization have been defined, respectively. <>= procedure :: write => cmd_selection_write <>= subroutine cmd_selection_write (cmd, unit, indent) class(cmd_selection_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)") "selection expression: [defined]" end subroutine cmd_selection_write @ %def cmd_selection_write @ Compile. Simply store the parse (sub)tree. <>= procedure :: compile => cmd_selection_compile <>= subroutine cmd_selection_compile (cmd, global) class(cmd_selection_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global cmd%pn_expr => parse_node_get_sub_ptr (cmd%pn, 3) end subroutine cmd_selection_compile @ %def cmd_selection_compile @ Instead of evaluating the expression, link the parse tree to the global data set, such that it is compiled and executed in the appropriate process context. <>= procedure :: execute => cmd_selection_execute <>= subroutine cmd_selection_execute (cmd, global) class(cmd_selection_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global global%pn%selection_lexpr => cmd%pn_expr end subroutine cmd_selection_execute @ %def cmd_selection_execute @ \subsubsection{Reweight} Define a reweight expression. This is to be applied upon simulation or event-file rescanning, event by event. We store the parse tree for the right-hand side instead of compiling it. Compilation is deferred to the environment where the expression is used. <>= type, extends (command_t) :: cmd_reweight_t private type(parse_node_t), pointer :: pn_expr => null () contains <> end type cmd_reweight_t @ %def cmd_reweight_t @ Output. Do not print the parse tree, since this may get cluttered. Just a message that scale, renormalization and factorization have been defined, respectively. <>= procedure :: write => cmd_reweight_write <>= subroutine cmd_reweight_write (cmd, unit, indent) class(cmd_reweight_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)") "reweight expression: [defined]" end subroutine cmd_reweight_write @ %def cmd_reweight_write @ Compile. Simply store the parse (sub)tree. <>= procedure :: compile => cmd_reweight_compile <>= subroutine cmd_reweight_compile (cmd, global) class(cmd_reweight_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global cmd%pn_expr => parse_node_get_sub_ptr (cmd%pn, 3) end subroutine cmd_reweight_compile @ %def cmd_reweight_compile @ Instead of evaluating the expression, link the parse tree to the global data set, such that it is compiled and executed in the appropriate process context. <>= procedure :: execute => cmd_reweight_execute <>= subroutine cmd_reweight_execute (cmd, global) class(cmd_reweight_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global global%pn%reweight_expr => cmd%pn_expr end subroutine cmd_reweight_execute @ %def cmd_reweight_execute @ \subsubsection{Alternative Simulation Setups} Together with simulation, we can re-evaluate event weights in the context of alternative setups. The [[cmd_alt_setup_t]] object is designed to hold these setups, which are brace-enclosed command lists. Compilation is deferred to the simulation environment where the setup expression is used. <>= type, extends (command_t) :: cmd_alt_setup_t private type(parse_node_p), dimension(:), allocatable :: setup contains <> end type cmd_alt_setup_t @ %def cmd_alt_setup_t @ Output. Print just a message that the alternative setup list has been defined. <>= procedure :: write => cmd_alt_setup_write <>= subroutine cmd_alt_setup_write (cmd, unit, indent) class(cmd_alt_setup_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A,I0,A)") "alt_setup: ", size (cmd%setup), " entries" end subroutine cmd_alt_setup_write @ %def cmd_alt_setup_write @ Compile. Store the parse sub-trees in an array. <>= procedure :: compile => cmd_alt_setup_compile <>= subroutine cmd_alt_setup_compile (cmd, global) class(cmd_alt_setup_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_list, pn_setup integer :: i pn_list => parse_node_get_sub_ptr (cmd%pn, 3) if (associated (pn_list)) then allocate (cmd%setup (parse_node_get_n_sub (pn_list))) i = 1 pn_setup => parse_node_get_sub_ptr (pn_list) do while (associated (pn_setup)) cmd%setup(i)%ptr => pn_setup i = i + 1 pn_setup => parse_node_get_next_ptr (pn_setup) end do else allocate (cmd%setup (0)) end if end subroutine cmd_alt_setup_compile @ %def cmd_alt_setup_compile @ Execute. Transfer the array of command lists to the global environment. <>= procedure :: execute => cmd_alt_setup_execute <>= subroutine cmd_alt_setup_execute (cmd, global) class(cmd_alt_setup_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global if (allocated (global%pn%alt_setup)) deallocate (global%pn%alt_setup) allocate (global%pn%alt_setup (size (cmd%setup))) global%pn%alt_setup = cmd%setup end subroutine cmd_alt_setup_execute @ %def cmd_alt_setup_execute @ \subsubsection{Integration} Integrate several processes, consecutively with identical parameters. <>= type, extends (command_t) :: cmd_integrate_t private integer :: n_proc = 0 type(string_t), dimension(:), allocatable :: process_id contains <> end type cmd_integrate_t @ %def cmd_integrate_t @ Output: we know the process IDs. <>= procedure :: write => cmd_integrate_write <>= subroutine cmd_integrate_write (cmd, unit, indent) class(cmd_integrate_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u, i u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)", advance="no") "integrate (" do i = 1, cmd%n_proc if (i > 1) write (u, "(A,1x)", advance="no") "," write (u, "(A)", advance="no") char (cmd%process_id(i)) end do write (u, "(A)") ")" end subroutine cmd_integrate_write @ %def cmd_integrate_write @ Compile. <>= procedure :: compile => cmd_integrate_compile <>= subroutine cmd_integrate_compile (cmd, global) class(cmd_integrate_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_proclist, pn_proc integer :: i pn_proclist => parse_node_get_sub_ptr (cmd%pn, 2) cmd%pn_opt => parse_node_get_next_ptr (pn_proclist) call cmd%compile_options (global) cmd%n_proc = parse_node_get_n_sub (pn_proclist) allocate (cmd%process_id (cmd%n_proc)) pn_proc => parse_node_get_sub_ptr (pn_proclist) do i = 1, cmd%n_proc cmd%process_id(i) = parse_node_get_string (pn_proc) call global%process_stack%init_result_vars (cmd%process_id(i)) pn_proc => parse_node_get_next_ptr (pn_proc) end do end subroutine cmd_integrate_compile @ %def cmd_integrate_compile @ Command execution. Integrate the process(es) with the predefined number of passes, iterations and calls. For structure functions, cuts, weight and scale, use local definitions if present; by default, the local definitions are initialized with the global ones. The [[integrate]] procedure should take its input from the currently active local environment, but produce a process record in the stack of the global environment. Since the process acquires a snapshot of the variable list, so if the global list (or the local one) is deleted, this does no harm. This implies that later changes of the variable list do not affect the stored process. <>= procedure :: execute => cmd_integrate_execute <>= subroutine cmd_integrate_execute (cmd, global) class(cmd_integrate_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global integer :: i if (debug_on) call msg_debug (D_CORE, "cmd_integrate_execute") do i = 1, cmd%n_proc if (debug_on) call msg_debug (D_CORE, "cmd%process_id(i) ", cmd%process_id(i)) call integrate_process (cmd%process_id(i), cmd%local, global) call global%process_stack%fill_result_vars (cmd%process_id(i)) call global%process_stack%update_result_vars & (cmd%process_id(i), global%var_list) if (signal_is_pending ()) return end do end subroutine cmd_integrate_execute @ %def cmd_integrate_execute @ \subsubsection{Observables} Declare an observable. After the declaration, it can be used to record data, and at the end one can retrieve average and error. <>= type, extends (command_t) :: cmd_observable_t private type(string_t) :: id contains <> end type cmd_observable_t @ %def cmd_observable_t @ Output. We know the ID. <>= procedure :: write => cmd_observable_write <>= subroutine cmd_observable_write (cmd, unit, indent) class(cmd_observable_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A,A)") "observable: ", char (cmd%id) end subroutine cmd_observable_write @ %def cmd_observable_write @ Compile. Just record the observable ID. <>= procedure :: compile => cmd_observable_compile <>= subroutine cmd_observable_compile (cmd, global) class(cmd_observable_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_tag pn_tag => parse_node_get_sub_ptr (cmd%pn, 2) if (associated (pn_tag)) then cmd%pn_opt => parse_node_get_next_ptr (pn_tag) end if call cmd%compile_options (global) select case (char (parse_node_get_rule_key (pn_tag))) case ("analysis_id") cmd%id = parse_node_get_string (pn_tag) case default call msg_bug ("observable: name expression not implemented (yet)") end select end subroutine cmd_observable_compile @ %def cmd_observable_compile @ Command execution. This declares the observable and allocates it in the analysis store. <>= procedure :: execute => cmd_observable_execute <>= subroutine cmd_observable_execute (cmd, global) class(cmd_observable_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list type(graph_options_t) :: graph_options type(string_t) :: label, unit var_list => cmd%local%get_var_list_ptr () label = var_list%get_sval (var_str ("$obs_label")) unit = var_list%get_sval (var_str ("$obs_unit")) call graph_options%init () call set_graph_options (graph_options, var_list) call analysis_init_observable (cmd%id, label, unit, graph_options) end subroutine cmd_observable_execute @ %def cmd_observable_execute @ \subsubsection{Histograms} Declare a histogram. At minimum, we have to set lower and upper bound and bin width. <>= type, extends (command_t) :: cmd_histogram_t private type(string_t) :: id type(parse_node_t), pointer :: pn_lower_bound => null () type(parse_node_t), pointer :: pn_upper_bound => null () type(parse_node_t), pointer :: pn_bin_width => null () contains <> end type cmd_histogram_t @ %def cmd_histogram_t @ Output. Just print the ID. <>= procedure :: write => cmd_histogram_write <>= subroutine cmd_histogram_write (cmd, unit, indent) class(cmd_histogram_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A,A)") "histogram: ", char (cmd%id) end subroutine cmd_histogram_write @ %def cmd_histogram_write @ Compile. Record the histogram ID and initialize lower, upper bound and bin width. <>= procedure :: compile => cmd_histogram_compile <>= subroutine cmd_histogram_compile (cmd, global) class(cmd_histogram_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_tag, pn_args, pn_arg1, pn_arg2, pn_arg3 character(*), parameter :: e_illegal_use = & "illegal usage of 'histogram': insufficient number of arguments" pn_tag => parse_node_get_sub_ptr (cmd%pn, 2) pn_args => parse_node_get_next_ptr (pn_tag) if (associated (pn_args)) then pn_arg1 => parse_node_get_sub_ptr (pn_args) if (.not. associated (pn_arg1)) call msg_fatal (e_illegal_use) pn_arg2 => parse_node_get_next_ptr (pn_arg1) if (.not. associated (pn_arg2)) call msg_fatal (e_illegal_use) pn_arg3 => parse_node_get_next_ptr (pn_arg2) cmd%pn_opt => parse_node_get_next_ptr (pn_args) end if call cmd%compile_options (global) select case (char (parse_node_get_rule_key (pn_tag))) case ("analysis_id") cmd%id = parse_node_get_string (pn_tag) case default call msg_bug ("histogram: name expression not implemented (yet)") end select cmd%pn_lower_bound => pn_arg1 cmd%pn_upper_bound => pn_arg2 cmd%pn_bin_width => pn_arg3 end subroutine cmd_histogram_compile @ %def cmd_histogram_compile @ Command execution. This declares the histogram and allocates it in the analysis store. <>= procedure :: execute => cmd_histogram_execute <>= subroutine cmd_histogram_execute (cmd, global) class(cmd_histogram_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list real(default) :: lower_bound, upper_bound, bin_width integer :: bin_number logical :: bin_width_is_used, normalize_bins type(string_t) :: obs_label, obs_unit type(graph_options_t) :: graph_options type(drawing_options_t) :: drawing_options var_list => cmd%local%get_var_list_ptr () lower_bound = eval_real (cmd%pn_lower_bound, var_list) upper_bound = eval_real (cmd%pn_upper_bound, var_list) if (associated (cmd%pn_bin_width)) then bin_width = eval_real (cmd%pn_bin_width, var_list) bin_width_is_used = .true. else if (var_list%is_known (var_str ("n_bins"))) then bin_number = & var_list%get_ival (var_str ("n_bins")) bin_width_is_used = .false. else call msg_error ("Cmd '" // char (cmd%id) // & "': neither bin width nor number is defined") end if normalize_bins = & var_list%get_lval (var_str ("?normalize_bins")) obs_label = & var_list%get_sval (var_str ("$obs_label")) obs_unit = & var_list%get_sval (var_str ("$obs_unit")) call graph_options%init () call set_graph_options (graph_options, var_list) call drawing_options%init_histogram () call set_drawing_options (drawing_options, var_list) if (bin_width_is_used) then call analysis_init_histogram & (cmd%id, lower_bound, upper_bound, bin_width, & normalize_bins, & obs_label, obs_unit, & graph_options, drawing_options) else call analysis_init_histogram & (cmd%id, lower_bound, upper_bound, bin_number, & normalize_bins, & obs_label, obs_unit, & graph_options, drawing_options) end if end subroutine cmd_histogram_execute @ %def cmd_histogram_execute @ Set the graph options from a variable list. <>= subroutine set_graph_options (gro, var_list) type(graph_options_t), intent(inout) :: gro type(var_list_t), intent(in) :: var_list call gro%set (title = var_list%get_sval (var_str ("$title"))) call gro%set (description = var_list%get_sval (var_str ("$description"))) call gro%set (x_label = var_list%get_sval (var_str ("$x_label"))) call gro%set (y_label = var_list%get_sval (var_str ("$y_label"))) call gro%set (width_mm = var_list%get_ival (var_str ("graph_width_mm"))) call gro%set (height_mm = var_list%get_ival (var_str ("graph_height_mm"))) call gro%set (x_log = var_list%get_lval (var_str ("?x_log"))) call gro%set (y_log = var_list%get_lval (var_str ("?y_log"))) if (var_list%is_known (var_str ("x_min"))) & call gro%set (x_min = var_list%get_rval (var_str ("x_min"))) if (var_list%is_known (var_str ("x_max"))) & call gro%set (x_max = var_list%get_rval (var_str ("x_max"))) if (var_list%is_known (var_str ("y_min"))) & call gro%set (y_min = var_list%get_rval (var_str ("y_min"))) if (var_list%is_known (var_str ("y_max"))) & call gro%set (y_max = var_list%get_rval (var_str ("y_max"))) call gro%set (gmlcode_bg = var_list%get_sval (var_str ("$gmlcode_bg"))) call gro%set (gmlcode_fg = var_list%get_sval (var_str ("$gmlcode_fg"))) end subroutine set_graph_options @ %def set_graph_options @ Set the drawing options from a variable list. <>= subroutine set_drawing_options (dro, var_list) type(drawing_options_t), intent(inout) :: dro type(var_list_t), intent(in) :: var_list if (var_list%is_known (var_str ("?draw_histogram"))) then if (var_list%get_lval (var_str ("?draw_histogram"))) then call dro%set (with_hbars = .true.) else call dro%set (with_hbars = .false., & with_base = .false., fill = .false., piecewise = .false.) end if end if if (var_list%is_known (var_str ("?draw_base"))) then if (var_list%get_lval (var_str ("?draw_base"))) then call dro%set (with_base = .true.) else call dro%set (with_base = .false., fill = .false.) end if end if if (var_list%is_known (var_str ("?draw_piecewise"))) then if (var_list%get_lval (var_str ("?draw_piecewise"))) then call dro%set (piecewise = .true.) else call dro%set (piecewise = .false.) end if end if if (var_list%is_known (var_str ("?fill_curve"))) then if (var_list%get_lval (var_str ("?fill_curve"))) then call dro%set (fill = .true., with_base = .true.) else call dro%set (fill = .false.) end if end if if (var_list%is_known (var_str ("?draw_curve"))) then if (var_list%get_lval (var_str ("?draw_curve"))) then call dro%set (draw = .true.) else call dro%set (draw = .false.) end if end if if (var_list%is_known (var_str ("?draw_errors"))) then if (var_list%get_lval (var_str ("?draw_errors"))) then call dro%set (err = .true.) else call dro%set (err = .false.) end if end if if (var_list%is_known (var_str ("?draw_symbols"))) then if (var_list%get_lval (var_str ("?draw_symbols"))) then call dro%set (symbols = .true.) else call dro%set (symbols = .false.) end if end if if (var_list%is_known (var_str ("$fill_options"))) then call dro%set (fill_options = & var_list%get_sval (var_str ("$fill_options"))) end if if (var_list%is_known (var_str ("$draw_options"))) then call dro%set (draw_options = & var_list%get_sval (var_str ("$draw_options"))) end if if (var_list%is_known (var_str ("$err_options"))) then call dro%set (err_options = & var_list%get_sval (var_str ("$err_options"))) end if if (var_list%is_known (var_str ("$symbol"))) then call dro%set (symbol = & var_list%get_sval (var_str ("$symbol"))) end if if (var_list%is_known (var_str ("$gmlcode_bg"))) then call dro%set (gmlcode_bg = & var_list%get_sval (var_str ("$gmlcode_bg"))) end if if (var_list%is_known (var_str ("$gmlcode_fg"))) then call dro%set (gmlcode_fg = & var_list%get_sval (var_str ("$gmlcode_fg"))) end if end subroutine set_drawing_options @ %def set_drawing_options @ \subsubsection{Plots} Declare a plot. No mandatory arguments, just options. <>= type, extends (command_t) :: cmd_plot_t private type(string_t) :: id contains <> end type cmd_plot_t @ %def cmd_plot_t @ Output. Just print the ID. <>= procedure :: write => cmd_plot_write <>= subroutine cmd_plot_write (cmd, unit, indent) class(cmd_plot_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A,A)") "plot: ", char (cmd%id) end subroutine cmd_plot_write @ %def cmd_plot_write @ Compile. Record the plot ID and initialize lower, upper bound and bin width. <>= procedure :: compile => cmd_plot_compile <>= subroutine cmd_plot_compile (cmd, global) class(cmd_plot_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_tag pn_tag => parse_node_get_sub_ptr (cmd%pn, 2) cmd%pn_opt => parse_node_get_next_ptr (pn_tag) call cmd%init (pn_tag, global) end subroutine cmd_plot_compile @ %def cmd_plot_compile @ This init routine is separated because it is reused below for graph initialization. <>= procedure :: init => cmd_plot_init <>= subroutine cmd_plot_init (plot, pn_tag, global) class(cmd_plot_t), intent(inout) :: plot type(parse_node_t), intent(in), pointer :: pn_tag type(rt_data_t), intent(inout), target :: global call plot%compile_options (global) select case (char (parse_node_get_rule_key (pn_tag))) case ("analysis_id") plot%id = parse_node_get_string (pn_tag) case default call msg_bug ("plot: name expression not implemented (yet)") end select end subroutine cmd_plot_init @ %def cmd_plot_init @ Command execution. This declares the plot and allocates it in the analysis store. <>= procedure :: execute => cmd_plot_execute <>= subroutine cmd_plot_execute (cmd, global) class(cmd_plot_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list type(graph_options_t) :: graph_options type(drawing_options_t) :: drawing_options var_list => cmd%local%get_var_list_ptr () call graph_options%init () call set_graph_options (graph_options, var_list) call drawing_options%init_plot () call set_drawing_options (drawing_options, var_list) call analysis_init_plot (cmd%id, graph_options, drawing_options) end subroutine cmd_plot_execute @ %def cmd_plot_execute @ \subsubsection{Graphs} Declare a graph. The graph is defined in terms of its contents. Both the graph and its contents may carry options. The graph object contains its own ID as well as the IDs of its elements. For the elements, we reuse the [[cmd_plot_t]] defined above. <>= type, extends (command_t) :: cmd_graph_t private type(string_t) :: id integer :: n_elements = 0 type(cmd_plot_t), dimension(:), allocatable :: el type(string_t), dimension(:), allocatable :: element_id contains <> end type cmd_graph_t @ %def cmd_graph_t @ Output. Just print the ID. <>= procedure :: write => cmd_graph_write <>= subroutine cmd_graph_write (cmd, unit, indent) class(cmd_graph_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A,A,A,I0,A)") "graph: ", char (cmd%id), & " (", cmd%n_elements, " entries)" end subroutine cmd_graph_write @ %def cmd_graph_write @ Compile. Record the graph ID and initialize lower, upper bound and bin width. For compiling the graph element syntax, we use part of the [[cmd_plot_t]] compiler. Note: currently, we do not respect options, therefore just IDs on the RHS. <>= procedure :: compile => cmd_graph_compile <>= subroutine cmd_graph_compile (cmd, global) class(cmd_graph_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_term, pn_tag, pn_def, pn_app integer :: i pn_term => parse_node_get_sub_ptr (cmd%pn, 2) pn_tag => parse_node_get_sub_ptr (pn_term) cmd%pn_opt => parse_node_get_next_ptr (pn_tag) call cmd%compile_options (global) select case (char (parse_node_get_rule_key (pn_tag))) case ("analysis_id") cmd%id = parse_node_get_string (pn_tag) case default call msg_bug ("graph: name expression not implemented (yet)") end select pn_def => parse_node_get_next_ptr (pn_term, 2) cmd%n_elements = parse_node_get_n_sub (pn_def) allocate (cmd%element_id (cmd%n_elements)) allocate (cmd%el (cmd%n_elements)) pn_term => parse_node_get_sub_ptr (pn_def) pn_tag => parse_node_get_sub_ptr (pn_term) cmd%el(1)%pn_opt => parse_node_get_next_ptr (pn_tag) call cmd%el(1)%init (pn_tag, global) cmd%element_id(1) = parse_node_get_string (pn_tag) pn_app => parse_node_get_next_ptr (pn_term) do i = 2, cmd%n_elements pn_term => parse_node_get_sub_ptr (pn_app, 2) pn_tag => parse_node_get_sub_ptr (pn_term) cmd%el(i)%pn_opt => parse_node_get_next_ptr (pn_tag) call cmd%el(i)%init (pn_tag, global) cmd%element_id(i) = parse_node_get_string (pn_tag) pn_app => parse_node_get_next_ptr (pn_app) end do end subroutine cmd_graph_compile @ %def cmd_graph_compile @ Command execution. This declares the graph, allocates it in the analysis store, and copies the graph elements. For the graph, we set graph and default drawing options. For the elements, we reset individual drawing options. This accesses internals of the contained elements of type [[cmd_plot_t]], see above. We might disentangle such an interdependency when this code is rewritten using proper type extension. <>= procedure :: execute => cmd_graph_execute <>= subroutine cmd_graph_execute (cmd, global) class(cmd_graph_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list type(graph_options_t) :: graph_options type(drawing_options_t) :: drawing_options integer :: i, type var_list => cmd%local%get_var_list_ptr () call graph_options%init () call set_graph_options (graph_options, var_list) call analysis_init_graph (cmd%id, cmd%n_elements, graph_options) do i = 1, cmd%n_elements if (associated (cmd%el(i)%options)) then call cmd%el(i)%options%execute (cmd%el(i)%local) end if type = analysis_store_get_object_type (cmd%element_id(i)) select case (type) case (AN_HISTOGRAM) call drawing_options%init_histogram () case (AN_PLOT) call drawing_options%init_plot () end select call set_drawing_options (drawing_options, var_list) if (associated (cmd%el(i)%options)) then call set_drawing_options (drawing_options, cmd%el(i)%local%var_list) end if call analysis_fill_graph (cmd%id, i, cmd%element_id(i), drawing_options) end do end subroutine cmd_graph_execute @ %def cmd_graph_execute @ \subsubsection{Analysis} Hold the analysis ID either as a string or as an expression: <>= type :: analysis_id_t type(string_t) :: tag type(parse_node_t), pointer :: pn_sexpr => null () end type analysis_id_t @ %def analysis_id_t @ Define the analysis expression. We store the parse tree for the right-hand side instead of compiling it. Compilation is deferred to the process environment where the analysis expression is used. <>= type, extends (command_t) :: cmd_analysis_t private type(parse_node_t), pointer :: pn_lexpr => null () contains <> end type cmd_analysis_t @ %def cmd_analysis_t @ Output. Print just a message that analysis has been defined. <>= procedure :: write => cmd_analysis_write <>= subroutine cmd_analysis_write (cmd, unit, indent) class(cmd_analysis_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)") "analysis: [defined]" end subroutine cmd_analysis_write @ %def cmd_analysis_write @ Compile. Simply store the parse (sub)tree. <>= procedure :: compile => cmd_analysis_compile <>= subroutine cmd_analysis_compile (cmd, global) class(cmd_analysis_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global cmd%pn_lexpr => parse_node_get_sub_ptr (cmd%pn, 3) end subroutine cmd_analysis_compile @ %def cmd_analysis_compile @ Instead of evaluating the cut expression, link the parse tree to the global data set, such that it is compiled and executed in the appropriate process context. <>= procedure :: execute => cmd_analysis_execute <>= subroutine cmd_analysis_execute (cmd, global) class(cmd_analysis_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global global%pn%analysis_lexpr => cmd%pn_lexpr end subroutine cmd_analysis_execute @ %def cmd_analysis_execute @ \subsubsection{Write histograms and plots} The data type encapsulating the command: <>= type, extends (command_t) :: cmd_write_analysis_t private type(analysis_id_t), dimension(:), allocatable :: id type(string_t), dimension(:), allocatable :: tag contains <> end type cmd_write_analysis_t @ %def analysis_id_t @ %def cmd_write_analysis_t @ Output. Just the keyword. <>= procedure :: write => cmd_write_analysis_write <>= subroutine cmd_write_analysis_write (cmd, unit, indent) class(cmd_write_analysis_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)") "write_analysis" end subroutine cmd_write_analysis_write @ %def cmd_write_analysis_write @ Compile. <>= procedure :: compile => cmd_write_analysis_compile <>= subroutine cmd_write_analysis_compile (cmd, global) class(cmd_write_analysis_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_clause, pn_args, pn_id integer :: n, i pn_clause => parse_node_get_sub_ptr (cmd%pn) pn_args => parse_node_get_sub_ptr (pn_clause, 2) cmd%pn_opt => parse_node_get_next_ptr (pn_clause) call cmd%compile_options (global) if (associated (pn_args)) then n = parse_node_get_n_sub (pn_args) allocate (cmd%id (n)) do i = 1, n pn_id => parse_node_get_sub_ptr (pn_args, i) if (char (parse_node_get_rule_key (pn_id)) == "analysis_id") then cmd%id(i)%tag = parse_node_get_string (pn_id) else cmd%id(i)%pn_sexpr => pn_id end if end do else allocate (cmd%id (0)) end if end subroutine cmd_write_analysis_compile @ %def cmd_write_analysis_compile @ The output format for real data values: <>= character(*), parameter, public :: & DEFAULT_ANALYSIS_FILENAME = "whizard_analysis.dat" character(len=1), dimension(2), parameter, public :: & FORBIDDEN_ENDINGS1 = [ "o", "a" ] character(len=2), dimension(6), parameter, public :: & FORBIDDEN_ENDINGS2 = [ "mp", "ps", "vg", "pg", "lo", "la" ] character(len=3), dimension(18), parameter, public :: & FORBIDDEN_ENDINGS3 = [ "aux", "dvi", "evt", "evx", "f03", "f90", & "f95", "log", "ltp", "mpx", "olc", "olp", "pdf", "phs", "sin", & "tex", "vg2", "vgx" ] @ %def DEFAULT_ANALYSIS_FILENAME @ %def FORBIDDEN_ENDINGS1 @ %def FORBIDDEN_ENDINGS2 @ %def FORBIDDEN_ENDINGS3 @ As this contains a lot of similar code to [[cmd_compile_analysis_execute]] we outsource the main code to a subroutine. <>= procedure :: execute => cmd_write_analysis_execute <>= subroutine cmd_write_analysis_execute (cmd, global) class(cmd_write_analysis_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list var_list => cmd%local%get_var_list_ptr () call write_analysis_wrap (var_list, global%out_files, & cmd%id, tag = cmd%tag) end subroutine cmd_write_analysis_execute @ %def cmd_write_analysis_execute @ If the [[data_file]] optional argument is present, this is called from [[cmd_compile_analysis_execute]], which needs the file name for further processing, and requires the default format. For the moment, parameters and macros for custom data processing are disabled. <>= subroutine write_analysis_wrap (var_list, out_files, id, tag, data_file) type(var_list_t), intent(inout), target :: var_list type(file_list_t), intent(inout), target :: out_files type(analysis_id_t), dimension(:), intent(in), target :: id type(string_t), dimension(:), allocatable, intent(out) :: tag type(string_t), intent(out), optional :: data_file type(string_t) :: defaultfile, file integer :: i logical :: keep_open type(string_t) :: extension logical :: one_file defaultfile = var_list%get_sval (var_str ("$out_file")) if (present (data_file)) then if (defaultfile == "" .or. defaultfile == ".") then defaultfile = DEFAULT_ANALYSIS_FILENAME else if (scan (".", defaultfile) > 0) then call split (defaultfile, extension, ".", back=.true.) if (any (lower_case (char(extension)) == FORBIDDEN_ENDINGS1) .or. & any (lower_case (char(extension)) == FORBIDDEN_ENDINGS2) .or. & any (lower_case (char(extension)) == FORBIDDEN_ENDINGS3)) & call msg_fatal ("The ending " // char(extension) // & " is internal and not allowed as data file.") if (extension /= "") then if (defaultfile /= "") then defaultfile = defaultfile // "." // extension else defaultfile = "whizard_analysis." // extension end if else defaultfile = defaultfile // ".dat" endif else defaultfile = defaultfile // ".dat" end if end if data_file = defaultfile end if one_file = defaultfile /= "" if (one_file) then file = defaultfile keep_open = file_list_is_open (out_files, file, & action = "write") if (keep_open) then if (present (data_file)) then call msg_fatal ("Compiling analysis: File '" & // char (data_file) & // "' can't be used, it is already open.") else call msg_message ("Appending analysis data to file '" & // char (file) // "'") end if else call file_list_open (out_files, file, & action = "write", status = "replace", position = "asis") call msg_message ("Writing analysis data to file '" & // char (file) // "'") end if end if call get_analysis_tags (tag, id, var_list) do i = 1, size (tag) call file_list_write_analysis & (out_files, file, tag(i)) end do if (one_file .and. .not. keep_open) then call file_list_close (out_files, file) end if contains subroutine get_analysis_tags (analysis_tag, id, var_list) type(string_t), dimension(:), intent(out), allocatable :: analysis_tag type(analysis_id_t), dimension(:), intent(in) :: id type(var_list_t), intent(in), target :: var_list if (size (id) /= 0) then allocate (analysis_tag (size (id))) do i = 1, size (id) if (associated (id(i)%pn_sexpr)) then analysis_tag(i) = eval_string (id(i)%pn_sexpr, var_list) else analysis_tag(i) = id(i)%tag end if end do else call analysis_store_get_ids (tag) end if end subroutine get_analysis_tags end subroutine write_analysis_wrap @ %def write_analysis_wrap \subsubsection{Compile analysis results} This command writes files in a form suitable for GAMELAN and executes the appropriate commands to compile them. The first part is identical to [[cmd_write_analysis]]. <>= type, extends (command_t) :: cmd_compile_analysis_t private type(analysis_id_t), dimension(:), allocatable :: id type(string_t), dimension(:), allocatable :: tag contains <> end type cmd_compile_analysis_t @ %def cmd_compile_analysis_t @ Output. Just the keyword. <>= procedure :: write => cmd_compile_analysis_write <>= subroutine cmd_compile_analysis_write (cmd, unit, indent) class(cmd_compile_analysis_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)") "compile_analysis" end subroutine cmd_compile_analysis_write @ %def cmd_compile_analysis_write @ Compile. <>= procedure :: compile => cmd_compile_analysis_compile <>= subroutine cmd_compile_analysis_compile (cmd, global) class(cmd_compile_analysis_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_clause, pn_args, pn_id integer :: n, i pn_clause => parse_node_get_sub_ptr (cmd%pn) pn_args => parse_node_get_sub_ptr (pn_clause, 2) cmd%pn_opt => parse_node_get_next_ptr (pn_clause) call cmd%compile_options (global) if (associated (pn_args)) then n = parse_node_get_n_sub (pn_args) allocate (cmd%id (n)) do i = 1, n pn_id => parse_node_get_sub_ptr (pn_args, i) if (char (parse_node_get_rule_key (pn_id)) == "analysis_id") then cmd%id(i)%tag = parse_node_get_string (pn_id) else cmd%id(i)%pn_sexpr => pn_id end if end do else allocate (cmd%id (0)) end if end subroutine cmd_compile_analysis_compile @ %def cmd_compile_analysis_compile @ First write the analysis data to file, then write a GAMELAN driver and produce MetaPost and \TeX\ output. <>= procedure :: execute => cmd_compile_analysis_execute <>= subroutine cmd_compile_analysis_execute (cmd, global) class(cmd_compile_analysis_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list type(string_t) :: file, basename, extension, driver_file, & makefile integer :: u_driver, u_makefile logical :: has_gmlcode, only_file var_list => cmd%local%get_var_list_ptr () call write_analysis_wrap (var_list, & global%out_files, cmd%id, tag = cmd%tag, & data_file = file) basename = file if (scan (".", basename) > 0) then call split (basename, extension, ".", back=.true.) else extension = "" end if driver_file = basename // ".tex" makefile = basename // "_ana.makefile" u_driver = free_unit () open (unit=u_driver, file=char(driver_file), & action="write", status="replace") if (allocated (cmd%tag)) then call analysis_write_driver (file, cmd%tag, unit=u_driver) has_gmlcode = analysis_has_plots (cmd%tag) else call analysis_write_driver (file, unit=u_driver) has_gmlcode = analysis_has_plots () end if close (u_driver) u_makefile = free_unit () open (unit=u_makefile, file=char(makefile), & action="write", status="replace") call analysis_write_makefile (basename, u_makefile, & has_gmlcode, global%os_data) close (u_makefile) call msg_message ("Compiling analysis results display in '" & // char (driver_file) // "'") call msg_message ("Providing analysis steering makefile '" & // char (makefile) // "'") only_file = global%var_list%get_lval & (var_str ("?analysis_file_only")) if (.not. only_file) call analysis_compile_tex & (basename, has_gmlcode, global%os_data) end subroutine cmd_compile_analysis_execute @ %def cmd_compile_analysis_execute @ \subsection{User-controlled output to data files} \subsubsection{Open file (output)} Open a file for output. <>= type, extends (command_t) :: cmd_open_out_t private type(parse_node_t), pointer :: file_expr => null () contains <> end type cmd_open_out_t @ %def cmd_open_out @ Finalizer for the embedded eval tree. <>= subroutine cmd_open_out_final (object) class(cmd_open_out_t), intent(inout) :: object end subroutine cmd_open_out_final @ %def cmd_open_out_final @ Output (trivial here). <>= procedure :: write => cmd_open_out_write <>= subroutine cmd_open_out_write (cmd, unit, indent) class(cmd_open_out_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)", advance="no") "open_out: " end subroutine cmd_open_out_write @ %def cmd_open_out_write @ Compile: create an eval tree for the filename expression. <>= procedure :: compile => cmd_open_out_compile <>= subroutine cmd_open_out_compile (cmd, global) class(cmd_open_out_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global cmd%file_expr => parse_node_get_sub_ptr (cmd%pn, 2) if (associated (cmd%file_expr)) then cmd%pn_opt => parse_node_get_next_ptr (cmd%file_expr) end if call cmd%compile_options (global) end subroutine cmd_open_out_compile @ %def cmd_open_out_compile @ Execute: append the file to the global list of open files. <>= procedure :: execute => cmd_open_out_execute <>= subroutine cmd_open_out_execute (cmd, global) class(cmd_open_out_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list type(eval_tree_t) :: file_expr type(string_t) :: file var_list => cmd%local%get_var_list_ptr () call file_expr%init_sexpr (cmd%file_expr, var_list) call file_expr%evaluate () if (file_expr%is_known ()) then file = file_expr%get_string () call file_list_open (global%out_files, file, & action = "write", status = "replace", position = "asis") else call msg_fatal ("open_out: file name argument evaluates to unknown") end if call file_expr%final () end subroutine cmd_open_out_execute @ %def cmd_open_out_execute \subsubsection{Open file (output)} Close an output file. Except for the [[execute]] method, everything is analogous to the open command, so we can just inherit. <>= type, extends (cmd_open_out_t) :: cmd_close_out_t private contains <> end type cmd_close_out_t @ %def cmd_close_out @ Execute: remove the file from the global list of output files. <>= procedure :: execute => cmd_close_out_execute <>= subroutine cmd_close_out_execute (cmd, global) class(cmd_close_out_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list type(eval_tree_t) :: file_expr type(string_t) :: file var_list => cmd%local%var_list call file_expr%init_sexpr (cmd%file_expr, var_list) call file_expr%evaluate () if (file_expr%is_known ()) then file = file_expr%get_string () call file_list_close (global%out_files, file) else call msg_fatal ("close_out: file name argument evaluates to unknown") end if call file_expr%final () end subroutine cmd_close_out_execute @ %def cmd_close_out_execute @ \subsection{Print custom-formatted values} <>= type, extends (command_t) :: cmd_printf_t private type(parse_node_t), pointer :: sexpr => null () type(parse_node_t), pointer :: sprintf_fun => null () type(parse_node_t), pointer :: sprintf_clause => null () type(parse_node_t), pointer :: sprintf => null () contains <> end type cmd_printf_t @ %def cmd_printf_t @ Finalize. <>= procedure :: final => cmd_printf_final <>= subroutine cmd_printf_final (cmd) class(cmd_printf_t), intent(inout) :: cmd call parse_node_final (cmd%sexpr, recursive = .false.) deallocate (cmd%sexpr) call parse_node_final (cmd%sprintf_fun, recursive = .false.) deallocate (cmd%sprintf_fun) call parse_node_final (cmd%sprintf_clause, recursive = .false.) deallocate (cmd%sprintf_clause) call parse_node_final (cmd%sprintf, recursive = .false.) deallocate (cmd%sprintf) end subroutine cmd_printf_final @ %def cmd_printf_final @ Output. Do not print the parse tree, since this may get cluttered. Just a message that cuts have been defined. <>= procedure :: write => cmd_printf_write <>= subroutine cmd_printf_write (cmd, unit, indent) class(cmd_printf_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)") "printf:" end subroutine cmd_printf_write @ %def cmd_printf_write @ Compile. We create a fake parse node (subtree) with a [[sprintf]] command with identical arguments which can then be handled by the corresponding evaluation procedure. <>= procedure :: compile => cmd_printf_compile <>= subroutine cmd_printf_compile (cmd, global) class(cmd_printf_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_cmd, pn_clause, pn_args, pn_format pn_cmd => parse_node_get_sub_ptr (cmd%pn) pn_clause => parse_node_get_sub_ptr (pn_cmd) pn_format => parse_node_get_sub_ptr (pn_clause, 2) pn_args => parse_node_get_next_ptr (pn_clause) cmd%pn_opt => parse_node_get_next_ptr (pn_cmd) call cmd%compile_options (global) allocate (cmd%sexpr) call parse_node_create_branch (cmd%sexpr, & syntax_get_rule_ptr (syntax_cmd_list, var_str ("sexpr"))) allocate (cmd%sprintf_fun) call parse_node_create_branch (cmd%sprintf_fun, & syntax_get_rule_ptr (syntax_cmd_list, var_str ("sprintf_fun"))) allocate (cmd%sprintf_clause) call parse_node_create_branch (cmd%sprintf_clause, & syntax_get_rule_ptr (syntax_cmd_list, var_str ("sprintf_clause"))) allocate (cmd%sprintf) call parse_node_create_key (cmd%sprintf, & syntax_get_rule_ptr (syntax_cmd_list, var_str ("sprintf"))) call parse_node_append_sub (cmd%sprintf_clause, cmd%sprintf) call parse_node_append_sub (cmd%sprintf_clause, pn_format) call parse_node_freeze_branch (cmd%sprintf_clause) call parse_node_append_sub (cmd%sprintf_fun, cmd%sprintf_clause) if (associated (pn_args)) then call parse_node_append_sub (cmd%sprintf_fun, pn_args) end if call parse_node_freeze_branch (cmd%sprintf_fun) call parse_node_append_sub (cmd%sexpr, cmd%sprintf_fun) call parse_node_freeze_branch (cmd%sexpr) end subroutine cmd_printf_compile @ %def cmd_printf_compile @ Execute. Evaluate the string (pretending this is a [[sprintf]] expression) and print it. <>= procedure :: execute => cmd_printf_execute <>= subroutine cmd_printf_execute (cmd, global) class(cmd_printf_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list type(string_t) :: string, file type(eval_tree_t) :: sprintf_expr logical :: advance var_list => cmd%local%get_var_list_ptr () advance = var_list%get_lval (& var_str ("?out_advance")) file = var_list%get_sval (& var_str ("$out_file")) call sprintf_expr%init_sexpr (cmd%sexpr, var_list) call sprintf_expr%evaluate () if (sprintf_expr%is_known ()) then string = sprintf_expr%get_string () if (len (file) == 0) then call msg_result (char (string)) else call file_list_write (global%out_files, file, string, advance) end if end if end subroutine cmd_printf_execute @ %def cmd_printf_execute @ \subsubsection{Record data} The expression syntax already contains a [[record]] keyword; this evaluates to a logical which is always true, but it has the side-effect of recording data into analysis objects. Here we define a command as an interface to this construct. <>= type, extends (command_t) :: cmd_record_t private type(parse_node_t), pointer :: pn_lexpr => null () contains <> end type cmd_record_t @ %def cmd_record_t @ Output. With the compile hack below, there is nothing of interest to print here. <>= procedure :: write => cmd_record_write <>= subroutine cmd_record_write (cmd, unit, indent) class(cmd_record_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)") "record" end subroutine cmd_record_write @ %def cmd_record_write @ Compile. This is a hack which transforms the [[record]] command into a [[record]] expression, which we handle in the [[expressions]] module. <>= procedure :: compile => cmd_record_compile <>= subroutine cmd_record_compile (cmd, global) class(cmd_record_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_lexpr, pn_lsinglet, pn_lterm, pn_record call parse_node_create_branch (pn_lexpr, & syntax_get_rule_ptr (syntax_cmd_list, var_str ("lexpr"))) call parse_node_create_branch (pn_lsinglet, & syntax_get_rule_ptr (syntax_cmd_list, var_str ("lsinglet"))) call parse_node_append_sub (pn_lexpr, pn_lsinglet) call parse_node_create_branch (pn_lterm, & syntax_get_rule_ptr (syntax_cmd_list, var_str ("lterm"))) call parse_node_append_sub (pn_lsinglet, pn_lterm) pn_record => parse_node_get_sub_ptr (cmd%pn) call parse_node_append_sub (pn_lterm, pn_record) cmd%pn_lexpr => pn_lexpr end subroutine cmd_record_compile @ %def cmd_record_compile @ Command execution. Again, transfer this to the embedded expression and just forget the logical result. <>= procedure :: execute => cmd_record_execute <>= subroutine cmd_record_execute (cmd, global) class(cmd_record_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list logical :: lval var_list => global%get_var_list_ptr () lval = eval_log (cmd%pn_lexpr, var_list) end subroutine cmd_record_execute @ %def cmd_record_execute @ \subsubsection{Unstable particles} Mark a particle as unstable. For each unstable particle, we store a number of decay channels and compute their respective BRs. <>= type, extends (command_t) :: cmd_unstable_t private integer :: n_proc = 0 type(string_t), dimension(:), allocatable :: process_id type(parse_node_t), pointer :: pn_prt_in => null () contains <> end type cmd_unstable_t @ %def cmd_unstable_t @ Output: we know the process IDs. <>= procedure :: write => cmd_unstable_write <>= subroutine cmd_unstable_write (cmd, unit, indent) class(cmd_unstable_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u, i u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A,1x,I0,1x,A)", advance="no") & "unstable:", 1, "(" do i = 1, cmd%n_proc if (i > 1) write (u, "(A,1x)", advance="no") "," write (u, "(A)", advance="no") char (cmd%process_id(i)) end do write (u, "(A)") ")" end subroutine cmd_unstable_write @ %def cmd_unstable_write @ Compile. Initiate an eval tree for the decaying particle and determine the decay channel process IDs. <>= procedure :: compile => cmd_unstable_compile <>= subroutine cmd_unstable_compile (cmd, global) class(cmd_unstable_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_list, pn_proc integer :: i cmd%pn_prt_in => parse_node_get_sub_ptr (cmd%pn, 2) pn_list => parse_node_get_next_ptr (cmd%pn_prt_in) if (associated (pn_list)) then select case (char (parse_node_get_rule_key (pn_list))) case ("unstable_arg") cmd%n_proc = parse_node_get_n_sub (pn_list) cmd%pn_opt => parse_node_get_next_ptr (pn_list) case default cmd%n_proc = 0 cmd%pn_opt => pn_list pn_list => null () end select end if call cmd%compile_options (global) if (associated (pn_list)) then allocate (cmd%process_id (cmd%n_proc)) pn_proc => parse_node_get_sub_ptr (pn_list) do i = 1, cmd%n_proc cmd%process_id(i) = parse_node_get_string (pn_proc) call cmd%local%process_stack%init_result_vars (cmd%process_id(i)) pn_proc => parse_node_get_next_ptr (pn_proc) end do else allocate (cmd%process_id (0)) end if end subroutine cmd_unstable_compile @ %def cmd_unstable_compile @ Command execution. Evaluate the decaying particle and mark the decays in the current model object. <>= procedure :: execute => cmd_unstable_execute <>= subroutine cmd_unstable_execute (cmd, global) class(cmd_unstable_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list logical :: auto_decays, auto_decays_radiative integer :: auto_decays_multiplicity logical :: isotropic_decay, diagonal_decay, polarized_decay integer :: decay_helicity type(pdg_array_t) :: pa_in integer :: pdg_in type(string_t) :: libname_cur, libname_dec type(string_t), dimension(:), allocatable :: auto_id, tmp_id integer :: n_proc_user integer :: i, u_tmp character(80) :: buffer var_list => cmd%local%get_var_list_ptr () auto_decays = & var_list%get_lval (var_str ("?auto_decays")) if (auto_decays) then auto_decays_multiplicity = & var_list%get_ival (var_str ("auto_decays_multiplicity")) auto_decays_radiative = & var_list%get_lval (var_str ("?auto_decays_radiative")) end if isotropic_decay = & var_list%get_lval (var_str ("?isotropic_decay")) if (isotropic_decay) then diagonal_decay = .false. polarized_decay = .false. else diagonal_decay = & var_list%get_lval (var_str ("?diagonal_decay")) if (diagonal_decay) then polarized_decay = .false. else polarized_decay = & var_list%is_known (var_str ("decay_helicity")) if (polarized_decay) then decay_helicity = var_list%get_ival (var_str ("decay_helicity")) end if end if end if pa_in = eval_pdg_array (cmd%pn_prt_in, var_list) if (pa_in%get_length () /= 1) & call msg_fatal ("Unstable: decaying particle must be unique") pdg_in = pa_in%get (1) n_proc_user = cmd%n_proc if (auto_decays) then call create_auto_decays (pdg_in, & auto_decays_multiplicity, auto_decays_radiative, & libname_dec, auto_id, cmd%local) allocate (tmp_id (cmd%n_proc + size (auto_id))) tmp_id(:cmd%n_proc) = cmd%process_id tmp_id(cmd%n_proc+1:) = auto_id call move_alloc (from = tmp_id, to = cmd%process_id) cmd%n_proc = size (cmd%process_id) end if libname_cur = cmd%local%prclib%get_name () do i = 1, cmd%n_proc if (i == n_proc_user + 1) then call cmd%local%update_prclib & (cmd%local%prclib_stack%get_library_ptr (libname_dec)) end if if (.not. global%process_stack%exists (cmd%process_id(i))) then call var_list%set_log & (var_str ("?decay_rest_frame"), .false., is_known = .true.) call integrate_process (cmd%process_id(i), cmd%local, global) call global%process_stack%fill_result_vars (cmd%process_id(i)) end if end do call cmd%local%update_prclib & (cmd%local%prclib_stack%get_library_ptr (libname_cur)) if (cmd%n_proc > 0) then if (polarized_decay) then call global%modify_particle (pdg_in, stable = .false., & decay = cmd%process_id, & isotropic_decay = .false., & diagonal_decay = .false., & decay_helicity = decay_helicity, & polarized = .false.) else call global%modify_particle (pdg_in, stable = .false., & decay = cmd%process_id, & isotropic_decay = isotropic_decay, & diagonal_decay = diagonal_decay, & polarized = .false.) end if u_tmp = free_unit () open (u_tmp, status = "scratch", action = "readwrite") call show_unstable (global, pdg_in, u_tmp) rewind (u_tmp) do read (u_tmp, "(A)", end = 1) buffer write (msg_buffer, "(A)") trim (buffer) call msg_message () end do 1 continue close (u_tmp) else call err_unstable (global, pdg_in) end if end subroutine cmd_unstable_execute @ %def cmd_unstable_execute @ Show data for the current unstable particle. This is called both by the [[unstable]] and by the [[show]] command. To determine decay branching rations, we look at the decay process IDs and inspect the corresponding [[integral()]] result variables. <>= subroutine show_unstable (global, pdg, u) type(rt_data_t), intent(in), target :: global integer, intent(in) :: pdg, u type(flavor_t) :: flv type(string_t), dimension(:), allocatable :: decay real(default), dimension(:), allocatable :: br real(default) :: width type(process_t), pointer :: process type(process_component_def_t), pointer :: prc_def type(string_t), dimension(:), allocatable :: prt_out, prt_out_str integer :: i, j logical :: opened call flv%init (pdg, global%model) call flv%get_decays (decay) if (.not. allocated (decay)) return allocate (prt_out_str (size (decay))) allocate (br (size (decay))) do i = 1, size (br) process => global%process_stack%get_process_ptr (decay(i)) prc_def => process%get_component_def_ptr (1) call prc_def%get_prt_out (prt_out) prt_out_str(i) = prt_out(1) do j = 2, size (prt_out) prt_out_str(i) = prt_out_str(i) // ", " // prt_out(j) end do br(i) = global%get_rval ("integral(" // decay(i) // ")") end do if (all (br >= 0)) then if (any (br > 0)) then width = sum (br) br = br / sum (br) write (u, "(A)") "Unstable particle " & // char (flv%get_name ()) & // ": computed branching ratios:" do i = 1, size (br) write (u, "(2x,A,':'," // FMT_14 // ",3x,A)") & char (decay(i)), br(i), char (prt_out_str(i)) end do write (u, "(2x,'Total width ='," // FMT_14 // ",' GeV (computed)')") width write (u, "(2x,' ='," // FMT_14 // ",' GeV (preset)')") & flv%get_width () if (flv%decays_isotropically ()) then write (u, "(2x,A)") "Decay options: isotropic" else if (flv%decays_diagonal ()) then write (u, "(2x,A)") "Decay options: & &projection on diagonal helicity states" else if (flv%has_decay_helicity ()) then write (u, "(2x,A,1x,I0)") "Decay options: projection onto helicity =", & flv%get_decay_helicity () else write (u, "(2x,A)") "Decay options: helicity treated exactly" end if else inquire (unit = u, opened = opened) if (opened .and. .not. mask_fatal_errors) close (u) call msg_fatal ("Unstable particle " & // char (flv%get_name ()) & // ": partial width vanishes for all decay channels") end if else inquire (unit = u, opened = opened) if (opened .and. .not. mask_fatal_errors) close (u) call msg_fatal ("Unstable particle " & // char (flv%get_name ()) & // ": partial width is negative") end if end subroutine show_unstable @ %def show_unstable @ If no decays have been found, issue a non-fatal error. <>= subroutine err_unstable (global, pdg) type(rt_data_t), intent(in), target :: global integer, intent(in) :: pdg type(flavor_t) :: flv call flv%init (pdg, global%model) call msg_error ("Unstable: no allowed decays found for particle " & // char (flv%get_name ()) // ", keeping as stable") end subroutine err_unstable @ %def err_unstable @ Auto decays: create process IDs and make up process configurations, using the PDG codes generated by the [[ds_table]] make method. We allocate and use a self-contained process library that contains only the decay processes of the current particle. When done, we revert the global library pointer to the original library but return the name of the new one. The new library becomes part of the global library stack and can thus be referred to at any time. <>= subroutine create_auto_decays & (pdg_in, mult, rad, libname_dec, process_id, global) integer, intent(in) :: pdg_in integer, intent(in) :: mult logical, intent(in) :: rad type(string_t), intent(out) :: libname_dec type(string_t), dimension(:), allocatable, intent(out) :: process_id type(rt_data_t), intent(inout) :: global type(prclib_entry_t), pointer :: lib_entry type(process_library_t), pointer :: lib type(ds_table_t) :: ds_table type(split_constraints_t) :: constraints type(pdg_array_t), dimension(:), allocatable :: pa_out character(80) :: buffer character :: p_or_a type(string_t) :: process_string, libname_cur type(flavor_t) :: flv_in, flv_out type(string_t) :: prt_in type(string_t), dimension(:), allocatable :: prt_out type(process_configuration_t) :: prc_config integer :: i, j, k call flv_in%init (pdg_in, global%model) if (rad) then call constraints%init (2) else call constraints%init (3) call constraints%set (3, constrain_radiation ()) end if call constraints%set (1, constrain_n_tot (mult)) call constraints%set (2, & constrain_mass_sum (flv_in%get_mass (), margin = 0._default)) call ds_table%make (global%model, pdg_in, constraints) prt_in = flv_in%get_name () if (pdg_in > 0) then p_or_a = "p" else p_or_a = "a" end if if (ds_table%get_length () == 0) then call msg_warning ("Auto-decays: Particle " // char (prt_in) // ": " & // "no decays found") libname_dec = "" allocate (process_id (0)) else call msg_message ("Creating decay process library for particle " & // char (prt_in)) libname_cur = global%prclib%get_name () write (buffer, "(A,A,I0)") "_d", p_or_a, abs (pdg_in) libname_dec = libname_cur // trim (buffer) lib => global%prclib_stack%get_library_ptr (libname_dec) if (.not. (associated (lib))) then allocate (lib_entry) call lib_entry%init (libname_dec) lib => lib_entry%process_library_t call global%add_prclib (lib_entry) else call global%update_prclib (lib) end if allocate (process_id (ds_table%get_length ())) do i = 1, size (process_id) write (buffer, "(A,'_',A,I0,'_',I0)") & "decay", p_or_a, abs (pdg_in), i process_id(i) = trim (buffer) process_string = process_id(i) // ": " // prt_in // " =>" call ds_table%get_pdg_out (i, pa_out) allocate (prt_out (size (pa_out))) do j = 1, size (pa_out) do k = 1, pa_out(j)%get_length () call flv_out%init (pa_out(j)%get (k), global%model) if (k == 1) then prt_out(j) = flv_out%get_name () else prt_out(j) = prt_out(j) // ":" // flv_out%get_name () end if end do process_string = process_string // " " // prt_out(j) end do call msg_message (char (process_string)) call prc_config%init (process_id(i), 1, 1, & global%model, global%var_list, & nlo_process = global%nlo_fixed_order) call prc_config%setup_component (1, new_prt_spec ([prt_in]), & new_prt_spec (prt_out), global%model, global%var_list) call prc_config%record (global) deallocate (prt_out) deallocate (pa_out) end do lib => global%prclib_stack%get_library_ptr (libname_cur) call global%update_prclib (lib) end if call ds_table%final () end subroutine create_auto_decays @ %def create_auto_decays @ \subsubsection{(Stable particles} Revert the unstable declaration for a list of particles. <>= type, extends (command_t) :: cmd_stable_t private type(parse_node_p), dimension(:), allocatable :: pn_pdg contains <> end type cmd_stable_t @ %def cmd_stable_t @ Output: we know only the number of particles. <>= procedure :: write => cmd_stable_write <>= subroutine cmd_stable_write (cmd, unit, indent) class(cmd_stable_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A,1x,I0)") "stable:", size (cmd%pn_pdg) end subroutine cmd_stable_write @ %def cmd_stable_write @ Compile. Assign parse nodes for the particle IDs. <>= procedure :: compile => cmd_stable_compile <>= subroutine cmd_stable_compile (cmd, global) class(cmd_stable_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_list, pn_prt integer :: n, i pn_list => parse_node_get_sub_ptr (cmd%pn, 2) cmd%pn_opt => parse_node_get_next_ptr (pn_list) call cmd%compile_options (global) n = parse_node_get_n_sub (pn_list) allocate (cmd%pn_pdg (n)) pn_prt => parse_node_get_sub_ptr (pn_list) i = 1 do while (associated (pn_prt)) cmd%pn_pdg(i)%ptr => pn_prt pn_prt => parse_node_get_next_ptr (pn_prt) i = i + 1 end do end subroutine cmd_stable_compile @ %def cmd_stable_compile @ Execute: apply the modifications to the current model. <>= procedure :: execute => cmd_stable_execute <>= subroutine cmd_stable_execute (cmd, global) class(cmd_stable_t), intent(inout) :: cmd type(rt_data_t), target, intent(inout) :: global type(var_list_t), pointer :: var_list type(pdg_array_t) :: pa integer :: pdg type(flavor_t) :: flv integer :: i var_list => cmd%local%get_var_list_ptr () do i = 1, size (cmd%pn_pdg) pa = eval_pdg_array (cmd%pn_pdg(i)%ptr, var_list) if (pa%get_length () /= 1) & call msg_fatal ("Stable: listed particles must be unique") pdg = pa%get (1) call global%modify_particle (pdg, stable = .true., & isotropic_decay = .false., & diagonal_decay = .false., & polarized = .false.) call flv%init (pdg, cmd%local%model) call msg_message ("Particle " & // char (flv%get_name ()) & // " declared as stable") end do end subroutine cmd_stable_execute @ %def cmd_stable_execute @ \subsubsection{Polarized particles} These commands mark particles as (un)polarized, to be applied in subsequent simulation passes. Since this is technically the same as the [[stable]] command, we take a shortcut and make this an extension, just overriding methods. <>= type, extends (cmd_stable_t) :: cmd_polarized_t contains <> end type cmd_polarized_t type, extends (cmd_stable_t) :: cmd_unpolarized_t contains <> end type cmd_unpolarized_t @ %def cmd_polarized_t cmd_unpolarized_t @ Output: we know only the number of particles. <>= procedure :: write => cmd_polarized_write <>= procedure :: write => cmd_unpolarized_write <>= subroutine cmd_polarized_write (cmd, unit, indent) class(cmd_polarized_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A,1x,I0)") "polarized:", size (cmd%pn_pdg) end subroutine cmd_polarized_write subroutine cmd_unpolarized_write (cmd, unit, indent) class(cmd_unpolarized_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A,1x,I0)") "unpolarized:", size (cmd%pn_pdg) end subroutine cmd_unpolarized_write @ %def cmd_polarized_write @ %def cmd_unpolarized_write @ Compile: accounted for by the base command. Execute: apply the modifications to the current model. <>= procedure :: execute => cmd_polarized_execute <>= procedure :: execute => cmd_unpolarized_execute <>= subroutine cmd_polarized_execute (cmd, global) class(cmd_polarized_t), intent(inout) :: cmd type(rt_data_t), target, intent(inout) :: global type(var_list_t), pointer :: var_list type(pdg_array_t) :: pa integer :: pdg type(flavor_t) :: flv integer :: i var_list => cmd%local%get_var_list_ptr () do i = 1, size (cmd%pn_pdg) pa = eval_pdg_array (cmd%pn_pdg(i)%ptr, var_list) if (pa%get_length () /= 1) & call msg_fatal ("Polarized: listed particles must be unique") pdg = pa%get (1) call global%modify_particle (pdg, polarized = .true., & stable = .true., & isotropic_decay = .false., & diagonal_decay = .false.) call flv%init (pdg, cmd%local%model) call msg_message ("Particle " & // char (flv%get_name ()) & // " declared as polarized") end do end subroutine cmd_polarized_execute subroutine cmd_unpolarized_execute (cmd, global) class(cmd_unpolarized_t), intent(inout) :: cmd type(rt_data_t), target, intent(inout) :: global type(var_list_t), pointer :: var_list type(pdg_array_t) :: pa integer :: pdg type(flavor_t) :: flv integer :: i var_list => cmd%local%get_var_list_ptr () do i = 1, size (cmd%pn_pdg) pa = eval_pdg_array (cmd%pn_pdg(i)%ptr, var_list) if (pa%get_length () /= 1) & call msg_fatal ("Unpolarized: listed particles must be unique") pdg = pa%get (1) call global%modify_particle (pdg, polarized = .false., & stable = .true., & isotropic_decay = .false., & diagonal_decay = .false.) call flv%init (pdg, cmd%local%model) call msg_message ("Particle " & // char (flv%get_name ()) & // " declared as unpolarized") end do end subroutine cmd_unpolarized_execute @ %def cmd_polarized_execute @ %def cmd_unpolarized_execute @ \subsubsection{Parameters: formats for event-sample output} Specify all event formats that are to be used for output files in the subsequent simulation run. (The raw format is on by default and can be turned off here.) <>= type, extends (command_t) :: cmd_sample_format_t private type(string_t), dimension(:), allocatable :: format contains <> end type cmd_sample_format_t @ %def cmd_sample_format_t @ Output: here, everything is known. <>= procedure :: write => cmd_sample_format_write <>= subroutine cmd_sample_format_write (cmd, unit, indent) class(cmd_sample_format_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u, i u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)", advance="no") "sample_format = " do i = 1, size (cmd%format) if (i > 1) write (u, "(A,1x)", advance="no") "," write (u, "(A)", advance="no") char (cmd%format(i)) end do write (u, "(A)") end subroutine cmd_sample_format_write @ %def cmd_sample_format_write @ Compile. Initialize evaluation trees. <>= procedure :: compile => cmd_sample_format_compile <>= subroutine cmd_sample_format_compile (cmd, global) class(cmd_sample_format_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_arg type(parse_node_t), pointer :: pn_format integer :: i, n_format pn_arg => parse_node_get_sub_ptr (cmd%pn, 3) if (associated (pn_arg)) then n_format = parse_node_get_n_sub (pn_arg) allocate (cmd%format (n_format)) pn_format => parse_node_get_sub_ptr (pn_arg) i = 0 do while (associated (pn_format)) i = i + 1 cmd%format(i) = parse_node_get_string (pn_format) pn_format => parse_node_get_next_ptr (pn_format) end do else allocate (cmd%format (0)) end if end subroutine cmd_sample_format_compile @ %def cmd_sample_format_compile @ Execute. Transfer the list of format specifications to the corresponding array in the runtime data set. <>= procedure :: execute => cmd_sample_format_execute <>= subroutine cmd_sample_format_execute (cmd, global) class(cmd_sample_format_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global if (allocated (global%sample_fmt)) deallocate (global%sample_fmt) allocate (global%sample_fmt (size (cmd%format)), source = cmd%format) end subroutine cmd_sample_format_execute @ %def cmd_sample_format_execute @ \subsubsection{The simulate command} This is the actual SINDARIN command. <>= type, extends (command_t) :: cmd_simulate_t ! not private anymore as required by the whizard-c-interface integer :: n_proc = 0 type(string_t), dimension(:), allocatable :: process_id contains <> end type cmd_simulate_t @ %def cmd_simulate_t @ Output: we know the process IDs. <>= procedure :: write => cmd_simulate_write <>= subroutine cmd_simulate_write (cmd, unit, indent) class(cmd_simulate_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u, i u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)", advance="no") "simulate (" do i = 1, cmd%n_proc if (i > 1) write (u, "(A,1x)", advance="no") "," write (u, "(A)", advance="no") char (cmd%process_id(i)) end do write (u, "(A)") ")" end subroutine cmd_simulate_write @ %def cmd_simulate_write @ Compile. In contrast to WHIZARD 1 the confusing option to give the number of unweighted events for weighted events as if unweighting were to take place has been abandoned. (We both use [[n_events]] for weighted and unweighted events, the variable [[n_calls]] from WHIZARD 1 has been discarded. <>= procedure :: compile => cmd_simulate_compile <>= subroutine cmd_simulate_compile (cmd, global) class(cmd_simulate_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_proclist, pn_proc integer :: i pn_proclist => parse_node_get_sub_ptr (cmd%pn, 2) cmd%pn_opt => parse_node_get_next_ptr (pn_proclist) call cmd%compile_options (global) cmd%n_proc = parse_node_get_n_sub (pn_proclist) allocate (cmd%process_id (cmd%n_proc)) pn_proc => parse_node_get_sub_ptr (pn_proclist) do i = 1, cmd%n_proc cmd%process_id(i) = parse_node_get_string (pn_proc) call global%process_stack%init_result_vars (cmd%process_id(i)) pn_proc => parse_node_get_next_ptr (pn_proc) end do end subroutine cmd_simulate_compile @ %def cmd_simulate_compile @ Execute command: Simulate events. This is done via a [[simulation_t]] object and its associated methods. Signal handling: the [[generate]] method may exit abnormally if there is a pending signal. The current logic ensures that the [[es_array]] output channels are closed before the [[execute]] routine returns. The program will terminate then in [[command_list_execute]]. <>= procedure :: execute => cmd_simulate_execute <>= subroutine cmd_simulate_execute (cmd, global) class(cmd_simulate_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list type(rt_data_t), dimension(:), allocatable, target :: alt_env integer :: n_events type(simulation_t), target :: sim type(event_stream_array_t) :: es_array integer :: i, checkpoint, callback var_list => cmd%local%var_list if (cmd%local%nlo_fixed_order) then call check_nlo_options (cmd%local) end if if (allocated (cmd%local%pn%alt_setup)) then allocate (alt_env (size (cmd%local%pn%alt_setup))) do i = 1, size (alt_env) call build_alt_setup (alt_env(i), cmd%local, & cmd%local%pn%alt_setup(i)%ptr) end do call sim%init (cmd%process_id, .true., .true., cmd%local, global, & alt_env) else call sim%init (cmd%process_id, .true., .true., cmd%local, global) end if if (signal_is_pending ()) return if (sim%is_valid ()) then call sim%init_process_selector () call sim%setup_openmp () call sim%compute_n_events (n_events) call sim%set_n_events_requested (n_events) call sim%activate_extra_logging () call sim%prepare_event_streams (es_array) if (es_array%is_valid ()) then call sim%generate (es_array) else call sim%generate () end if call es_array%final () if (allocated (alt_env)) then do i = 1, size (alt_env) call alt_env(i)%local_final () end do end if end if call sim%final () end subroutine cmd_simulate_execute @ %def cmd_simulate_execute @ Build an alternative setup: the parse tree is stored in the global environment. We create a temporary command list to compile and execute this; the result is an alternative local environment [[alt_env]] which we can hand over to the [[simulate]] command. <>= recursive subroutine build_alt_setup (alt_env, global, pn) type(rt_data_t), intent(inout), target :: alt_env type(rt_data_t), intent(inout), target :: global type(parse_node_t), intent(in), target :: pn type(command_list_t), allocatable :: alt_options allocate (alt_options) call alt_env%local_init (global) call alt_env%activate () call alt_options%compile (pn, alt_env) call alt_options%execute (alt_env) call alt_env%deactivate (global, keep_local = .true.) call alt_options%final () end subroutine build_alt_setup @ %def build_alt_setup @ \subsubsection{The rescan command} This is the actual SINDARIN command. <>= type, extends (command_t) :: cmd_rescan_t ! private type(parse_node_t), pointer :: pn_filename => null () integer :: n_proc = 0 type(string_t), dimension(:), allocatable :: process_id contains <> end type cmd_rescan_t @ %def cmd_rescan_t @ Output: we know the process IDs. <>= procedure :: write => cmd_rescan_write <>= subroutine cmd_rescan_write (cmd, unit, indent) class(cmd_rescan_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u, i u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)", advance="no") "rescan (" do i = 1, cmd%n_proc if (i > 1) write (u, "(A,1x)", advance="no") "," write (u, "(A)", advance="no") char (cmd%process_id(i)) end do write (u, "(A)") ")" end subroutine cmd_rescan_write @ %def cmd_rescan_write @ Compile. The command takes a suffix argument, namely the file name of requested event file. <>= procedure :: compile => cmd_rescan_compile <>= subroutine cmd_rescan_compile (cmd, global) class(cmd_rescan_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_filename, pn_proclist, pn_proc integer :: i pn_filename => parse_node_get_sub_ptr (cmd%pn, 2) pn_proclist => parse_node_get_next_ptr (pn_filename) cmd%pn_opt => parse_node_get_next_ptr (pn_proclist) call cmd%compile_options (global) cmd%pn_filename => pn_filename cmd%n_proc = parse_node_get_n_sub (pn_proclist) allocate (cmd%process_id (cmd%n_proc)) pn_proc => parse_node_get_sub_ptr (pn_proclist) do i = 1, cmd%n_proc cmd%process_id(i) = parse_node_get_string (pn_proc) pn_proc => parse_node_get_next_ptr (pn_proc) end do end subroutine cmd_rescan_compile @ %def cmd_rescan_compile @ Execute command: Rescan events. This is done via a [[simulation_t]] object and its associated methods. <>= procedure :: execute => cmd_rescan_execute <>= subroutine cmd_rescan_execute (cmd, global) class(cmd_rescan_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list type(rt_data_t), dimension(:), allocatable, target :: alt_env type(string_t) :: sample, sample_suffix logical :: exist, write_raw, update_event, update_sqme type(simulation_t), target :: sim type(event_sample_data_t) :: input_data, data type(string_t) :: input_sample integer :: n_fmt type(string_t), dimension(:), allocatable :: sample_fmt type(string_t) :: input_format, input_ext, input_file type(string_t) :: lhef_extension, extension_hepmc, extension_lcio type(event_stream_array_t) :: es_array integer :: i, n_events <> var_list => cmd%local%var_list if (allocated (cmd%local%pn%alt_setup)) then allocate (alt_env (size (cmd%local%pn%alt_setup))) do i = 1, size (alt_env) call build_alt_setup (alt_env(i), cmd%local, & cmd%local%pn%alt_setup(i)%ptr) end do call sim%init (cmd%process_id, .false., .false., cmd%local, global, & alt_env) else call sim%init (cmd%process_id, .false., .false., cmd%local, global) end if call sim%compute_n_events (n_events) input_sample = eval_string (cmd%pn_filename, var_list) input_format = var_list%get_sval (& var_str ("$rescan_input_format")) sample_suffix = "" <> sample = var_list%get_sval (var_str ("$sample")) if (sample == "") then sample = sim%get_default_sample_name () // sample_suffix else sample = var_list%get_sval (var_str ("$sample")) // sample_suffix end if write_raw = var_list%get_lval (var_str ("?write_raw")) if (allocated (cmd%local%sample_fmt)) then n_fmt = size (cmd%local%sample_fmt) else n_fmt = 0 end if if (write_raw) then if (sample == input_sample) then call msg_error ("Rescan: ?write_raw = true: " & // "suppressing raw event output (filename clashes with input)") allocate (sample_fmt (n_fmt)) if (n_fmt > 0) sample_fmt = cmd%local%sample_fmt else allocate (sample_fmt (n_fmt + 1)) if (n_fmt > 0) sample_fmt(:n_fmt) = cmd%local%sample_fmt sample_fmt(n_fmt+1) = var_str ("raw") end if else allocate (sample_fmt (n_fmt)) if (n_fmt > 0) sample_fmt = cmd%local%sample_fmt end if update_event = & var_list%get_lval (var_str ("?update_event")) update_sqme = & var_list%get_lval (var_str ("?update_sqme")) if (update_event .or. update_sqme) then call msg_message ("Recalculating observables") if (update_sqme) then call msg_message ("Recalculating squared matrix elements") end if end if lhef_extension = & var_list%get_sval (var_str ("$lhef_extension")) extension_hepmc = & var_list%get_sval (var_str ("$extension_hepmc")) extension_lcio = & var_list%get_sval (var_str ("$extension_lcio")) select case (char (input_format)) case ("raw"); input_ext = "evx" call cmd%local%set_log & (var_str ("?recover_beams"), .false., is_known=.true.) case ("lhef"); input_ext = lhef_extension case ("hepmc"); input_ext = extension_hepmc case ("lcio"); input_ext = extension_lcio case default call msg_fatal ("rescan: input sample format '" // char (input_format) & // "' not supported") end select input_file = input_sample // "." // input_ext inquire (file = char (input_file), exist = exist) if (exist) then input_data = sim%get_data (alt = .false.) input_data%n_evt = n_events data = sim%get_data () data%n_evt = n_events input_data%md5sum_cfg = "" call es_array%init (sample, & sample_fmt, cmd%local, data, & input = input_format, input_sample = input_sample, & input_data = input_data, & allow_switch = .false.) call sim%rescan (n_events, es_array, global = cmd%local) call es_array%final () else call msg_fatal ("Rescan: event file '" & // char (input_file) // "' not found") end if if (allocated (alt_env)) then do i = 1, size (alt_env) call alt_env(i)%local_final () end do end if call sim%final () end subroutine cmd_rescan_execute @ %def cmd_rescan_execute @ MPI: Append rank id to sample name. <>= <>= logical :: mpi_logging integer :: rank, n_size <>= <>= call mpi_get_comm_id (n_size, rank) if (n_size > 1) then sample_suffix = var_str ("_") // str (rank) end if mpi_logging = (("vamp2" == char (var_list%get_sval (var_str ("$integration_method"))) & & .and. (n_size > 1)) & & .or. var_list%get_lval (var_str ("?mpi_logging"))) call mpi_set_logging (mpi_logging) @ \subsubsection{Parameters: number of iterations} Specify number of iterations and number of calls for one integration pass. <>= type, extends (command_t) :: cmd_iterations_t private integer :: n_pass = 0 type(parse_node_p), dimension(:), allocatable :: pn_expr_n_it type(parse_node_p), dimension(:), allocatable :: pn_expr_n_calls type(parse_node_p), dimension(:), allocatable :: pn_sexpr_adapt contains <> end type cmd_iterations_t @ %def cmd_iterations_t @ Output. Display the number of passes, which is known after compilation. <>= procedure :: write => cmd_iterations_write <>= subroutine cmd_iterations_write (cmd, unit, indent) class(cmd_iterations_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) select case (cmd%n_pass) case (0) write (u, "(1x,A)") "iterations: [empty]" case (1) write (u, "(1x,A,I0,A)") "iterations: ", cmd%n_pass, " pass" case default write (u, "(1x,A,I0,A)") "iterations: ", cmd%n_pass, " passes" end select end subroutine cmd_iterations_write @ %def cmd_iterations_write @ Compile. Initialize evaluation trees. <>= procedure :: compile => cmd_iterations_compile <>= subroutine cmd_iterations_compile (cmd, global) class(cmd_iterations_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_arg, pn_n_it, pn_n_calls, pn_adapt type(parse_node_t), pointer :: pn_it_spec, pn_calls_spec, pn_adapt_spec integer :: i pn_arg => parse_node_get_sub_ptr (cmd%pn, 3) if (associated (pn_arg)) then cmd%n_pass = parse_node_get_n_sub (pn_arg) allocate (cmd%pn_expr_n_it (cmd%n_pass)) allocate (cmd%pn_expr_n_calls (cmd%n_pass)) allocate (cmd%pn_sexpr_adapt (cmd%n_pass)) pn_it_spec => parse_node_get_sub_ptr (pn_arg) i = 1 do while (associated (pn_it_spec)) pn_n_it => parse_node_get_sub_ptr (pn_it_spec) pn_calls_spec => parse_node_get_next_ptr (pn_n_it) pn_n_calls => parse_node_get_sub_ptr (pn_calls_spec, 2) pn_adapt_spec => parse_node_get_next_ptr (pn_calls_spec) if (associated (pn_adapt_spec)) then pn_adapt => parse_node_get_sub_ptr (pn_adapt_spec, 2) else pn_adapt => null () end if cmd%pn_expr_n_it(i)%ptr => pn_n_it cmd%pn_expr_n_calls(i)%ptr => pn_n_calls cmd%pn_sexpr_adapt(i)%ptr => pn_adapt i = i + 1 pn_it_spec => parse_node_get_next_ptr (pn_it_spec) end do else allocate (cmd%pn_expr_n_it (0)) allocate (cmd%pn_expr_n_calls (0)) end if end subroutine cmd_iterations_compile @ %def cmd_iterations_compile @ Execute. Evaluate the trees and transfer the results to the iteration list in the runtime data set. <>= procedure :: execute => cmd_iterations_execute <>= subroutine cmd_iterations_execute (cmd, global) class(cmd_iterations_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list integer, dimension(cmd%n_pass) :: n_it, n_calls logical, dimension(cmd%n_pass) :: custom_adapt type(string_t), dimension(cmd%n_pass) :: adapt_code integer :: i var_list => global%get_var_list_ptr () do i = 1, cmd%n_pass n_it(i) = eval_int (cmd%pn_expr_n_it(i)%ptr, var_list) n_calls(i) = & eval_int (cmd%pn_expr_n_calls(i)%ptr, var_list) if (associated (cmd%pn_sexpr_adapt(i)%ptr)) then adapt_code(i) = & eval_string (cmd%pn_sexpr_adapt(i)%ptr, & var_list, is_known = custom_adapt(i)) else custom_adapt(i) = .false. end if end do call global%it_list%init (n_it, n_calls, custom_adapt, adapt_code) end subroutine cmd_iterations_execute @ %def cmd_iterations_execute @ \subsubsection{Range expressions} We need a special type for storing and evaluating range expressions. <>= integer, parameter :: STEP_NONE = 0 integer, parameter :: STEP_ADD = 1 integer, parameter :: STEP_SUB = 2 integer, parameter :: STEP_MUL = 3 integer, parameter :: STEP_DIV = 4 integer, parameter :: STEP_COMP_ADD = 11 integer, parameter :: STEP_COMP_MUL = 13 @ There is an abstract base type and two implementations: scan over integers and scan over reals. <>= type, abstract :: range_t type(parse_node_t), pointer :: pn_expr => null () type(parse_node_t), pointer :: pn_term => null () type(parse_node_t), pointer :: pn_factor => null () type(parse_node_t), pointer :: pn_value => null () type(parse_node_t), pointer :: pn_literal => null () type(parse_node_t), pointer :: pn_beg => null () type(parse_node_t), pointer :: pn_end => null () type(parse_node_t), pointer :: pn_step => null () type(eval_tree_t) :: expr_beg type(eval_tree_t) :: expr_end type(eval_tree_t) :: expr_step integer :: step_mode = 0 integer :: n_step = 0 contains <> end type range_t @ %def range_t @ These are the implementations: <>= type, extends (range_t) :: range_int_t integer :: i_beg = 0 integer :: i_end = 0 integer :: i_step = 0 contains <> end type range_int_t type, extends (range_t) :: range_real_t real(default) :: r_beg = 0 real(default) :: r_end = 0 real(default) :: r_step = 0 real(default) :: lr_beg = 0 real(default) :: lr_end = 0 real(default) :: lr_step = 0 contains <> end type range_real_t @ %def range_int_t range_real_t @ Finalize the allocated dummy node. The other nodes are just pointers. <>= procedure :: final => range_final <>= subroutine range_final (object) class(range_t), intent(inout) :: object if (associated (object%pn_expr)) then call parse_node_final (object%pn_expr, recursive = .false.) call parse_node_final (object%pn_term, recursive = .false.) call parse_node_final (object%pn_factor, recursive = .false.) call parse_node_final (object%pn_value, recursive = .false.) call parse_node_final (object%pn_literal, recursive = .false.) deallocate (object%pn_expr) deallocate (object%pn_term) deallocate (object%pn_factor) deallocate (object%pn_value) deallocate (object%pn_literal) end if end subroutine range_final @ %def range_final @ Output. <>= procedure (range_write), deferred :: write procedure :: base_write => range_write <>= procedure :: write => range_int_write <>= procedure :: write => range_real_write <>= subroutine range_write (object, unit) class(range_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Range specification:" if (associated (object%pn_expr)) then write (u, "(1x,A)") "Dummy value:" call parse_node_write_rec (object%pn_expr, u) end if if (associated (object%pn_beg)) then write (u, "(1x,A)") "Initial value:" call parse_node_write_rec (object%pn_beg, u) call object%expr_beg%write (u) if (associated (object%pn_end)) then write (u, "(1x,A)") "Final value:" call parse_node_write_rec (object%pn_end, u) call object%expr_end%write (u) if (associated (object%pn_step)) then write (u, "(1x,A)") "Step value:" call parse_node_write_rec (object%pn_step, u) select case (object%step_mode) case (STEP_ADD); write (u, "(1x,A)") "Step mode: +" case (STEP_SUB); write (u, "(1x,A)") "Step mode: -" case (STEP_MUL); write (u, "(1x,A)") "Step mode: *" case (STEP_DIV); write (u, "(1x,A)") "Step mode: /" case (STEP_COMP_ADD); write (u, "(1x,A)") "Division mode: +" case (STEP_COMP_MUL); write (u, "(1x,A)") "Division mode: *" end select end if end if else write (u, "(1x,A)") "Expressions: [undefined]" end if end subroutine range_write subroutine range_int_write (object, unit) class(range_int_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) call object%base_write (unit) write (u, "(1x,A)") "Range parameters:" write (u, "(3x,A,I0)") "i_beg = ", object%i_beg write (u, "(3x,A,I0)") "i_end = ", object%i_end write (u, "(3x,A,I0)") "i_step = ", object%i_step write (u, "(3x,A,I0)") "n_step = ", object%n_step end subroutine range_int_write subroutine range_real_write (object, unit) class(range_real_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) call object%base_write (unit) write (u, "(1x,A)") "Range parameters:" write (u, "(3x,A," // FMT_19 // ")") "r_beg = ", object%r_beg write (u, "(3x,A," // FMT_19 // ")") "r_end = ", object%r_end write (u, "(3x,A," // FMT_19 // ")") "r_step = ", object%r_end write (u, "(3x,A,I0)") "n_step = ", object%n_step end subroutine range_real_write @ %def range_write @ Initialize, given a range expression parse node. This is common to the implementations. <>= procedure :: init => range_init <>= subroutine range_init (range, pn) class(range_t), intent(out) :: range type(parse_node_t), intent(in), target :: pn type(parse_node_t), pointer :: pn_spec, pn_end, pn_step_spec, pn_op select case (char (parse_node_get_rule_key (pn))) case ("expr") case ("range_expr") range%pn_beg => parse_node_get_sub_ptr (pn) pn_spec => parse_node_get_next_ptr (range%pn_beg) if (associated (pn_spec)) then pn_end => parse_node_get_sub_ptr (pn_spec, 2) range%pn_end => pn_end pn_step_spec => parse_node_get_next_ptr (pn_end) if (associated (pn_step_spec)) then pn_op => parse_node_get_sub_ptr (pn_step_spec) range%pn_step => parse_node_get_next_ptr (pn_op) select case (char (parse_node_get_rule_key (pn_op))) case ("/+"); range%step_mode = STEP_ADD case ("/-"); range%step_mode = STEP_SUB case ("/*"); range%step_mode = STEP_MUL case ("//"); range%step_mode = STEP_DIV case ("/+/"); range%step_mode = STEP_COMP_ADD case ("/*/"); range%step_mode = STEP_COMP_MUL case default call range%write () call msg_bug ("Range: step mode not implemented") end select else range%step_mode = STEP_ADD end if else range%step_mode = STEP_NONE end if call range%create_value_node () case default call msg_bug ("range expression: node type '" & // char (parse_node_get_rule_key (pn)) & // "' not implemented") end select end subroutine range_init @ %def range_init @ This method manually creates a parse node (actually, a cascade of parse nodes) that hold a constant value as a literal. The idea is that this node is inserted as the right-hand side of a fake variable assignment, which is prepended to each scan iteration. Before the variable assignment is compiled and executed, we can manually reset the value of the literal and thus pretend that the loop variable is assigned this value. <>= procedure :: create_value_node => range_create_value_node <>= subroutine range_create_value_node (range) class(range_t), intent(inout) :: range allocate (range%pn_literal) allocate (range%pn_value) select type (range) type is (range_int_t) call parse_node_create_value (range%pn_literal, & syntax_get_rule_ptr (syntax_cmd_list, var_str ("integer_literal")),& ival = 0) call parse_node_create_branch (range%pn_value, & syntax_get_rule_ptr (syntax_cmd_list, var_str ("integer_value"))) type is (range_real_t) call parse_node_create_value (range%pn_literal, & syntax_get_rule_ptr (syntax_cmd_list, var_str ("real_literal")),& rval = 0._default) call parse_node_create_branch (range%pn_value, & syntax_get_rule_ptr (syntax_cmd_list, var_str ("real_value"))) class default call msg_bug ("range: create value node: type not implemented") end select call parse_node_append_sub (range%pn_value, range%pn_literal) call parse_node_freeze_branch (range%pn_value) allocate (range%pn_factor) call parse_node_create_branch (range%pn_factor, & syntax_get_rule_ptr (syntax_cmd_list, var_str ("factor"))) call parse_node_append_sub (range%pn_factor, range%pn_value) call parse_node_freeze_branch (range%pn_factor) allocate (range%pn_term) call parse_node_create_branch (range%pn_term, & syntax_get_rule_ptr (syntax_cmd_list, var_str ("term"))) call parse_node_append_sub (range%pn_term, range%pn_factor) call parse_node_freeze_branch (range%pn_term) allocate (range%pn_expr) call parse_node_create_branch (range%pn_expr, & syntax_get_rule_ptr (syntax_cmd_list, var_str ("expr"))) call parse_node_append_sub (range%pn_expr, range%pn_term) call parse_node_freeze_branch (range%pn_expr) end subroutine range_create_value_node @ %def range_create_value_node @ Compile, given an environment. <>= procedure :: compile => range_compile <>= subroutine range_compile (range, global) class(range_t), intent(inout) :: range type(rt_data_t), intent(in), target :: global type(var_list_t), pointer :: var_list var_list => global%get_var_list_ptr () if (associated (range%pn_beg)) then call range%expr_beg%init_expr (range%pn_beg, var_list) if (associated (range%pn_end)) then call range%expr_end%init_expr (range%pn_end, var_list) if (associated (range%pn_step)) then call range%expr_step%init_expr (range%pn_step, var_list) end if end if end if end subroutine range_compile @ %def range_compile @ Evaluate: compute the actual bounds and parameters that determine the values that we can iterate. This is implementation-specific. <>= procedure (range_evaluate), deferred :: evaluate <>= abstract interface subroutine range_evaluate (range) import class(range_t), intent(inout) :: range end subroutine range_evaluate end interface @ %def range_evaluate @ The version for an integer variable. If the step is subtractive, we invert the sign and treat it as an additive step. For a multiplicative step, the step must be greater than one, and the initial and final values must be of same sign and strictly ordered. Analogously for a division step. <>= procedure :: evaluate => range_int_evaluate <>= subroutine range_int_evaluate (range) class(range_int_t), intent(inout) :: range integer :: ival if (associated (range%pn_beg)) then call range%expr_beg%evaluate () if (range%expr_beg%is_known ()) then range%i_beg = range%expr_beg%get_int () else call range%write () call msg_fatal & ("Range expression: initial value evaluates to unknown") end if if (associated (range%pn_end)) then call range%expr_end%evaluate () if (range%expr_end%is_known ()) then range%i_end = range%expr_end%get_int () if (associated (range%pn_step)) then call range%expr_step%evaluate () if (range%expr_step%is_known ()) then range%i_step = range%expr_step%get_int () select case (range%step_mode) case (STEP_SUB); range%i_step = - range%i_step end select else call range%write () call msg_fatal & ("Range expression: step value evaluates to unknown") end if else range%i_step = 1 end if else call range%write () call msg_fatal & ("Range expression: final value evaluates to unknown") end if else range%i_end = range%i_beg range%i_step = 1 end if select case (range%step_mode) case (STEP_NONE) range%n_step = 1 case (STEP_ADD, STEP_SUB) if (range%i_step /= 0) then if (range%i_beg == range%i_end) then range%n_step = 1 else if (sign (1, range%i_end - range%i_beg) & == sign (1, range%i_step)) then range%n_step = (range%i_end - range%i_beg) / range%i_step + 1 else range%n_step = 0 end if else call msg_fatal ("range evaluation (add): step value is zero") end if case (STEP_MUL) if (range%i_step > 1) then if (range%i_beg == range%i_end) then range%n_step = 1 else if (range%i_beg == 0) then call msg_fatal ("range evaluation (mul): initial value is zero") else if (sign (1, range%i_beg) == sign (1, range%i_end) & .and. abs (range%i_beg) < abs (range%i_end)) then range%n_step = 0 ival = range%i_beg do while (abs (ival) <= abs (range%i_end)) range%n_step = range%n_step + 1 ival = ival * range%i_step end do else range%n_step = 0 end if else call msg_fatal & ("range evaluation (mult): step value is one or less") end if case (STEP_DIV) if (range%i_step > 1) then if (range%i_beg == range%i_end) then range%n_step = 1 else if (sign (1, range%i_beg) == sign (1, range%i_end) & .and. abs (range%i_beg) > abs (range%i_end)) then range%n_step = 0 ival = range%i_beg do while (abs (ival) >= abs (range%i_end)) range%n_step = range%n_step + 1 if (ival == 0) exit ival = ival / range%i_step end do else range%n_step = 0 end if else call msg_fatal & ("range evaluation (div): step value is one or less") end if case (STEP_COMP_ADD) call msg_fatal ("range evaluation: & &step mode /+/ not allowed for integer variable") case (STEP_COMP_MUL) call msg_fatal ("range evaluation: & &step mode /*/ not allowed for integer variable") case default call range%write () call msg_bug ("range evaluation: step mode not implemented") end select end if end subroutine range_int_evaluate @ %def range_int_evaluate @ The version for a real variable. <>= procedure :: evaluate => range_real_evaluate <>= subroutine range_real_evaluate (range) class(range_real_t), intent(inout) :: range if (associated (range%pn_beg)) then call range%expr_beg%evaluate () if (range%expr_beg%is_known ()) then range%r_beg = range%expr_beg%get_real () else call range%write () call msg_fatal & ("Range expression: initial value evaluates to unknown") end if if (associated (range%pn_end)) then call range%expr_end%evaluate () if (range%expr_end%is_known ()) then range%r_end = range%expr_end%get_real () if (associated (range%pn_step)) then if (range%expr_step%is_known ()) then select case (range%step_mode) case (STEP_ADD, STEP_SUB, STEP_MUL, STEP_DIV) call range%expr_step%evaluate () range%r_step = range%expr_step%get_real () select case (range%step_mode) case (STEP_SUB); range%r_step = - range%r_step end select case (STEP_COMP_ADD, STEP_COMP_MUL) range%n_step = & max (range%expr_step%get_int (), 0) end select else call range%write () call msg_fatal & ("Range expression: step value evaluates to unknown") end if else call range%write () call msg_fatal & ("Range expression (real): step value must be provided") end if else call range%write () call msg_fatal & ("Range expression: final value evaluates to unknown") end if else range%r_end = range%r_beg range%r_step = 1 end if select case (range%step_mode) case (STEP_NONE) range%n_step = 1 case (STEP_ADD, STEP_SUB) if (range%r_step /= 0) then if (sign (1._default, range%r_end - range%r_beg) & == sign (1._default, range%r_step)) then range%n_step = & nint ((range%r_end - range%r_beg) / range%r_step + 1) else range%n_step = 0 end if else call msg_fatal ("range evaluation (add): step value is zero") end if case (STEP_MUL) if (range%r_step > 1) then if (range%r_beg == 0 .or. range%r_end == 0) then call msg_fatal ("range evaluation (mul): bound is zero") else if (sign (1._default, range%r_beg) & == sign (1._default, range%r_end) & .and. abs (range%r_beg) <= abs (range%r_end)) then range%lr_beg = log (abs (range%r_beg)) range%lr_end = log (abs (range%r_end)) range%lr_step = log (range%r_step) range%n_step = nint & (abs ((range%lr_end - range%lr_beg) / range%lr_step) + 1) else range%n_step = 0 end if else call msg_fatal & ("range evaluation (mult): step value is one or less") end if case (STEP_DIV) if (range%r_step > 1) then if (range%r_beg == 0 .or. range%r_end == 0) then call msg_fatal ("range evaluation (div): bound is zero") else if (sign (1._default, range%r_beg) & == sign (1._default, range%r_end) & .and. abs (range%r_beg) >= abs (range%r_end)) then range%lr_beg = log (abs (range%r_beg)) range%lr_end = log (abs (range%r_end)) range%lr_step = -log (range%r_step) range%n_step = nint & (abs ((range%lr_end - range%lr_beg) / range%lr_step) + 1) else range%n_step = 0 end if else call msg_fatal & ("range evaluation (mult): step value is one or less") end if case (STEP_COMP_ADD) ! Number of steps already known case (STEP_COMP_MUL) ! Number of steps already known if (range%r_beg == 0 .or. range%r_end == 0) then call msg_fatal ("range evaluation (mul): bound is zero") else if (sign (1._default, range%r_beg) & == sign (1._default, range%r_end)) then range%lr_beg = log (abs (range%r_beg)) range%lr_end = log (abs (range%r_end)) else range%n_step = 0 end if case default call range%write () call msg_bug ("range evaluation: step mode not implemented") end select end if end subroutine range_real_evaluate @ %def range_real_evaluate @ Return the number of iterations: <>= procedure :: get_n_iterations => range_get_n_iterations <>= function range_get_n_iterations (range) result (n) class(range_t), intent(in) :: range integer :: n n = range%n_step end function range_get_n_iterations @ %def range_get_n_iterations @ Compute the value for iteration [[i]] and store it in the embedded token. <>= procedure (range_set_value), deferred :: set_value <>= abstract interface subroutine range_set_value (range, i) import class(range_t), intent(inout) :: range integer, intent(in) :: i end subroutine range_set_value end interface @ %def range_set_value @ In the integer case, we compute the value directly for additive step. For multiplicative step, we perform a loop in the same way as above, where the number of iteration was determined. <>= procedure :: set_value => range_int_set_value <>= subroutine range_int_set_value (range, i) class(range_int_t), intent(inout) :: range integer, intent(in) :: i integer :: k, ival select case (range%step_mode) case (STEP_NONE) ival = range%i_beg case (STEP_ADD, STEP_SUB) ival = range%i_beg + (i - 1) * range%i_step case (STEP_MUL) ival = range%i_beg do k = 1, i - 1 ival = ival * range%i_step end do case (STEP_DIV) ival = range%i_beg do k = 1, i - 1 ival = ival / range%i_step end do case default call range%write () call msg_bug ("range iteration: step mode not implemented") end select call parse_node_set_value (range%pn_literal, ival = ival) end subroutine range_int_set_value @ %def range_int_set_value @ In the integer case, we compute the value directly for additive step. For multiplicative step, we perform a loop in the same way as above, where the number of iteration was determined. <>= procedure :: set_value => range_real_set_value <>= subroutine range_real_set_value (range, i) class(range_real_t), intent(inout) :: range integer, intent(in) :: i real(default) :: rval, x select case (range%step_mode) case (STEP_NONE) rval = range%r_beg case (STEP_ADD, STEP_SUB, STEP_COMP_ADD) if (range%n_step > 1) then x = real (i - 1, default) / (range%n_step - 1) else x = 1._default / 2 end if rval = x * range%r_end + (1 - x) * range%r_beg case (STEP_MUL, STEP_DIV, STEP_COMP_MUL) if (range%n_step > 1) then x = real (i - 1, default) / (range%n_step - 1) else x = 1._default / 2 end if rval = sign & (exp (x * range%lr_end + (1 - x) * range%lr_beg), range%r_beg) case default call range%write () call msg_bug ("range iteration: step mode not implemented") end select call parse_node_set_value (range%pn_literal, rval = rval) end subroutine range_real_set_value @ %def range_real_set_value @ \subsubsection{Scan over parameters and other objects} The scan command allocates a new parse node for the variable assignment (the lhs). The rhs of this parse node is assigned from the available rhs expressions in the scan list, one at a time, so the compiled parse node can be prepended to the scan body. <>= type, extends (command_t) :: cmd_scan_t private type(string_t) :: name integer :: n_values = 0 type(parse_node_p), dimension(:), allocatable :: scan_cmd class(range_t), dimension(:), allocatable :: range contains <> end type cmd_scan_t @ %def cmd_scan_t @ Finalizer. The auxiliary parse nodes that we have constructed have to be treated carefully: the embedded pointers all point to persistent objects somewhere else and should not be finalized, so we should not call the finalizer recursively. <>= procedure :: final => cmd_scan_final <>= recursive subroutine cmd_scan_final (cmd) class(cmd_scan_t), intent(inout) :: cmd type(parse_node_t), pointer :: pn_var_single, pn_decl_single type(string_t) :: key integer :: i if (allocated (cmd%scan_cmd)) then do i = 1, size (cmd%scan_cmd) pn_var_single => parse_node_get_sub_ptr (cmd%scan_cmd(i)%ptr) key = parse_node_get_rule_key (pn_var_single) select case (char (key)) case ("scan_string_decl", "scan_log_decl") pn_decl_single => parse_node_get_sub_ptr (pn_var_single, 2) call parse_node_final (pn_decl_single, recursive=.false.) deallocate (pn_decl_single) end select call parse_node_final (pn_var_single, recursive=.false.) deallocate (pn_var_single) end do deallocate (cmd%scan_cmd) end if if (allocated (cmd%range)) then do i = 1, size (cmd%range) call cmd%range(i)%final () end do end if end subroutine cmd_scan_final @ %def cmd_scan_final @ Output. <>= procedure :: write => cmd_scan_write <>= subroutine cmd_scan_write (cmd, unit, indent) class(cmd_scan_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A,1x,A,1x,'(',I0,')')") "scan:", char (cmd%name), & cmd%n_values end subroutine cmd_scan_write @ %def cmd_scan_write @ Compile the scan command. We construct a new parse node that implements the variable assignment for a single element on the rhs, instead of the whole list that we get from the original parse tree. By simply copying the node, we copy all pointers and inherit the targets from the original. During execution, we should replace the rhs by the stored rhs pointers (the list elements), one by one, then (re)compile the redefined node. <>= procedure :: compile => cmd_scan_compile <>= recursive subroutine cmd_scan_compile (cmd, global) class(cmd_scan_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list type(parse_node_t), pointer :: pn_var, pn_body, pn_body_first type(parse_node_t), pointer :: pn_decl, pn_name type(parse_node_t), pointer :: pn_arg, pn_scan_cmd, pn_rhs type(parse_node_t), pointer :: pn_decl_single, pn_var_single type(syntax_rule_t), pointer :: var_rule_decl, var_rule type(string_t) :: key integer :: var_type integer :: i if (debug_on) call msg_debug (D_CORE, "cmd_scan_compile") if (debug_active (D_CORE)) call parse_node_write_rec (cmd%pn) pn_var => parse_node_get_sub_ptr (cmd%pn, 2) pn_body => parse_node_get_next_ptr (pn_var) if (associated (pn_body)) then pn_body_first => parse_node_get_sub_ptr (pn_body) else pn_body_first => null () end if key = parse_node_get_rule_key (pn_var) select case (char (key)) case ("scan_num") pn_name => parse_node_get_sub_ptr (pn_var) cmd%name = parse_node_get_string (pn_name) var_rule => syntax_get_rule_ptr (syntax_cmd_list, var_str ("cmd_num")) pn_arg => parse_node_get_next_ptr (pn_name, 2) case ("scan_int") pn_name => parse_node_get_sub_ptr (pn_var, 2) cmd%name = parse_node_get_string (pn_name) var_rule => syntax_get_rule_ptr (syntax_cmd_list, var_str ("cmd_int")) pn_arg => parse_node_get_next_ptr (pn_name, 2) case ("scan_real") pn_name => parse_node_get_sub_ptr (pn_var, 2) cmd%name = parse_node_get_string (pn_name) var_rule => syntax_get_rule_ptr (syntax_cmd_list, var_str ("cmd_real")) pn_arg => parse_node_get_next_ptr (pn_name, 2) case ("scan_complex") pn_name => parse_node_get_sub_ptr (pn_var, 2) cmd%name = parse_node_get_string (pn_name) var_rule => syntax_get_rule_ptr (syntax_cmd_list, var_str("cmd_complex")) pn_arg => parse_node_get_next_ptr (pn_name, 2) case ("scan_alias") pn_name => parse_node_get_sub_ptr (pn_var, 2) cmd%name = parse_node_get_string (pn_name) var_rule => syntax_get_rule_ptr (syntax_cmd_list, var_str ("cmd_alias")) pn_arg => parse_node_get_next_ptr (pn_name, 2) case ("scan_string_decl") pn_decl => parse_node_get_sub_ptr (pn_var, 2) pn_name => parse_node_get_sub_ptr (pn_decl, 2) cmd%name = parse_node_get_string (pn_name) var_rule_decl => syntax_get_rule_ptr (syntax_cmd_list, & var_str ("cmd_string")) var_rule => syntax_get_rule_ptr (syntax_cmd_list, & var_str ("cmd_string_decl")) pn_arg => parse_node_get_next_ptr (pn_name, 2) case ("scan_log_decl") pn_decl => parse_node_get_sub_ptr (pn_var, 2) pn_name => parse_node_get_sub_ptr (pn_decl, 2) cmd%name = parse_node_get_string (pn_name) var_rule_decl => syntax_get_rule_ptr (syntax_cmd_list, & var_str ("cmd_log")) var_rule => syntax_get_rule_ptr (syntax_cmd_list, & var_str ("cmd_log_decl")) pn_arg => parse_node_get_next_ptr (pn_name, 2) case ("scan_cuts") var_rule => syntax_get_rule_ptr (syntax_cmd_list, & var_str ("cmd_cuts")) cmd%name = "cuts" pn_arg => parse_node_get_sub_ptr (pn_var, 3) case ("scan_weight") var_rule => syntax_get_rule_ptr (syntax_cmd_list, & var_str ("cmd_weight")) cmd%name = "weight" pn_arg => parse_node_get_sub_ptr (pn_var, 3) case ("scan_scale") var_rule => syntax_get_rule_ptr (syntax_cmd_list, & var_str ("cmd_scale")) cmd%name = "scale" pn_arg => parse_node_get_sub_ptr (pn_var, 3) case ("scan_ren_scale") var_rule => syntax_get_rule_ptr (syntax_cmd_list, & var_str ("cmd_ren_scale")) cmd%name = "renormalization_scale" pn_arg => parse_node_get_sub_ptr (pn_var, 3) case ("scan_fac_scale") var_rule => syntax_get_rule_ptr (syntax_cmd_list, & var_str ("cmd_fac_scale")) cmd%name = "factorization_scale" pn_arg => parse_node_get_sub_ptr (pn_var, 3) case ("scan_selection") var_rule => syntax_get_rule_ptr (syntax_cmd_list, & var_str ("cmd_selection")) cmd%name = "selection" pn_arg => parse_node_get_sub_ptr (pn_var, 3) case ("scan_reweight") var_rule => syntax_get_rule_ptr (syntax_cmd_list, & var_str ("cmd_reweight")) cmd%name = "reweight" pn_arg => parse_node_get_sub_ptr (pn_var, 3) case ("scan_analysis") var_rule => syntax_get_rule_ptr (syntax_cmd_list, & var_str ("cmd_analysis")) cmd%name = "analysis" pn_arg => parse_node_get_sub_ptr (pn_var, 3) case ("scan_model") var_rule => syntax_get_rule_ptr (syntax_cmd_list, & var_str ("cmd_model")) cmd%name = "model" pn_arg => parse_node_get_sub_ptr (pn_var, 3) case ("scan_library") var_rule => syntax_get_rule_ptr (syntax_cmd_list, & var_str ("cmd_library")) cmd%name = "library" pn_arg => parse_node_get_sub_ptr (pn_var, 3) case default call msg_bug ("scan: case '" // char (key) // "' not implemented") end select if (associated (pn_arg)) then cmd%n_values = parse_node_get_n_sub (pn_arg) end if var_list => global%get_var_list_ptr () allocate (cmd%scan_cmd (cmd%n_values)) select case (char (key)) case ("scan_num") var_type = & var_list%get_type (cmd%name) select case (var_type) case (V_INT) allocate (range_int_t :: cmd%range (cmd%n_values)) case (V_REAL) allocate (range_real_t :: cmd%range (cmd%n_values)) case (V_CMPLX) call msg_fatal ("scan over complex variable not implemented") case (V_NONE) call msg_fatal ("scan: variable '" // char (cmd%name) //"' undefined") case default call msg_bug ("scan: impossible variable type") end select case ("scan_int") allocate (range_int_t :: cmd%range (cmd%n_values)) case ("scan_real") allocate (range_real_t :: cmd%range (cmd%n_values)) case ("scan_complex") call msg_fatal ("scan over complex variable not implemented") end select i = 1 if (associated (pn_arg)) then pn_rhs => parse_node_get_sub_ptr (pn_arg) else pn_rhs => null () end if do while (associated (pn_rhs)) allocate (pn_scan_cmd) call parse_node_create_branch (pn_scan_cmd, & syntax_get_rule_ptr (syntax_cmd_list, var_str ("command_list"))) allocate (pn_var_single) pn_var_single = pn_var call parse_node_replace_rule (pn_var_single, var_rule) select case (char (key)) case ("scan_num", "scan_int", "scan_real", & "scan_complex", "scan_alias", & "scan_cuts", "scan_weight", & "scan_scale", "scan_ren_scale", "scan_fac_scale", & "scan_selection", "scan_reweight", "scan_analysis", & "scan_model", "scan_library") if (allocated (cmd%range)) then call cmd%range(i)%init (pn_rhs) call parse_node_replace_last_sub & (pn_var_single, cmd%range(i)%pn_expr) else call parse_node_replace_last_sub (pn_var_single, pn_rhs) end if case ("scan_string_decl", "scan_log_decl") allocate (pn_decl_single) pn_decl_single = pn_decl call parse_node_replace_rule (pn_decl_single, var_rule_decl) call parse_node_replace_last_sub (pn_decl_single, pn_rhs) call parse_node_freeze_branch (pn_decl_single) call parse_node_replace_last_sub (pn_var_single, pn_decl_single) case default call msg_bug ("scan: case '" // char (key) & // "' broken") end select call parse_node_freeze_branch (pn_var_single) call parse_node_append_sub (pn_scan_cmd, pn_var_single) call parse_node_append_sub (pn_scan_cmd, pn_body_first) call parse_node_freeze_branch (pn_scan_cmd) cmd%scan_cmd(i)%ptr => pn_scan_cmd i = i + 1 pn_rhs => parse_node_get_next_ptr (pn_rhs) end do if (debug_active (D_CORE)) then do i = 1, cmd%n_values print *, "scan command ", i call parse_node_write_rec (cmd%scan_cmd(i)%ptr) if (allocated (cmd%range)) call cmd%range(i)%write () end do print *, "original" call parse_node_write_rec (cmd%pn) end if end subroutine cmd_scan_compile @ %def cmd_scan_compile @ Execute the loop for all values in the step list. We use the parse trees with single variable assignment that we have stored, to iteratively create a local environment, execute the stored commands, and destroy it again. When we encounter a range object, we execute the commands for each value that this object provides. Computing this value has the side effect of modifying the rhs of the variable assignment that heads the local command list, directly in the local parse tree. <>= procedure :: execute => cmd_scan_execute <>= recursive subroutine cmd_scan_execute (cmd, global) class(cmd_scan_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(rt_data_t), allocatable :: local integer :: i, j do i = 1, cmd%n_values if (allocated (cmd%range)) then call cmd%range(i)%compile (global) call cmd%range(i)%evaluate () do j = 1, cmd%range(i)%get_n_iterations () call cmd%range(i)%set_value (j) allocate (local) call build_alt_setup (local, global, cmd%scan_cmd(i)%ptr) call local%local_final () deallocate (local) end do else allocate (local) call build_alt_setup (local, global, cmd%scan_cmd(i)%ptr) call local%local_final () deallocate (local) end if end do end subroutine cmd_scan_execute @ %def cmd_scan_execute @ \subsubsection{Conditionals} Conditionals are implemented as a list that is compiled and evaluated recursively; this allows for a straightforward representation of [[else if]] constructs. A [[cmd_if_t]] object can hold either an [[else_if]] clause which is another object of this type, or an [[else_body]], but not both. If- or else-bodies are no scoping units, so all data remain global and no copy-in copy-out is needed. <>= type, extends (command_t) :: cmd_if_t private type(parse_node_t), pointer :: pn_if_lexpr => null () type(command_list_t), pointer :: if_body => null () type(cmd_if_t), dimension(:), pointer :: elsif_cmd => null () type(command_list_t), pointer :: else_body => null () contains <> end type cmd_if_t @ %def cmd_if_t @ Finalizer. There are no local options, therefore we can simply override the default finalizer. <>= procedure :: final => cmd_if_final <>= recursive subroutine cmd_if_final (cmd) class(cmd_if_t), intent(inout) :: cmd integer :: i if (associated (cmd%if_body)) then call command_list_final (cmd%if_body) deallocate (cmd%if_body) end if if (associated (cmd%elsif_cmd)) then do i = 1, size (cmd%elsif_cmd) call cmd_if_final (cmd%elsif_cmd(i)) end do deallocate (cmd%elsif_cmd) end if if (associated (cmd%else_body)) then call command_list_final (cmd%else_body) deallocate (cmd%else_body) end if end subroutine cmd_if_final @ %def cmd_if_final @ Output. Recursively write the command lists. <>= procedure :: write => cmd_if_write <>= subroutine cmd_if_write (cmd, unit, indent) class(cmd_if_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u, ind, i u = given_output_unit (unit); if (u < 0) return ind = 0; if (present (indent)) ind = indent call write_indent (u, indent) write (u, "(A)") "if then" if (associated (cmd%if_body)) then call cmd%if_body%write (unit, ind + 1) end if if (associated (cmd%elsif_cmd)) then do i = 1, size (cmd%elsif_cmd) call write_indent (u, indent) write (u, "(A)") "elsif then" if (associated (cmd%elsif_cmd(i)%if_body)) then call cmd%elsif_cmd(i)%if_body%write (unit, ind + 1) end if end do end if if (associated (cmd%else_body)) then call write_indent (u, indent) write (u, "(A)") "else" call cmd%else_body%write (unit, ind + 1) end if end subroutine cmd_if_write @ %def cmd_if_write @ Compile the conditional. <>= procedure :: compile => cmd_if_compile <>= recursive subroutine cmd_if_compile (cmd, global) class(cmd_if_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_lexpr, pn_body type(parse_node_t), pointer :: pn_elsif_clauses, pn_cmd_elsif type(parse_node_t), pointer :: pn_else_clause, pn_cmd_else integer :: i, n_elsif pn_lexpr => parse_node_get_sub_ptr (cmd%pn, 2) cmd%pn_if_lexpr => pn_lexpr pn_body => parse_node_get_next_ptr (pn_lexpr, 2) select case (char (parse_node_get_rule_key (pn_body))) case ("command_list") allocate (cmd%if_body) call cmd%if_body%compile (pn_body, global) pn_elsif_clauses => parse_node_get_next_ptr (pn_body) case default pn_elsif_clauses => pn_body end select select case (char (parse_node_get_rule_key (pn_elsif_clauses))) case ("elsif_clauses") n_elsif = parse_node_get_n_sub (pn_elsif_clauses) allocate (cmd%elsif_cmd (n_elsif)) pn_cmd_elsif => parse_node_get_sub_ptr (pn_elsif_clauses) do i = 1, n_elsif pn_lexpr => parse_node_get_sub_ptr (pn_cmd_elsif, 2) cmd%elsif_cmd(i)%pn_if_lexpr => pn_lexpr pn_body => parse_node_get_next_ptr (pn_lexpr, 2) if (associated (pn_body)) then allocate (cmd%elsif_cmd(i)%if_body) call cmd%elsif_cmd(i)%if_body%compile (pn_body, global) end if pn_cmd_elsif => parse_node_get_next_ptr (pn_cmd_elsif) end do pn_else_clause => parse_node_get_next_ptr (pn_elsif_clauses) case default pn_else_clause => pn_elsif_clauses end select select case (char (parse_node_get_rule_key (pn_else_clause))) case ("else_clause") pn_cmd_else => parse_node_get_sub_ptr (pn_else_clause) pn_body => parse_node_get_sub_ptr (pn_cmd_else, 2) if (associated (pn_body)) then allocate (cmd%else_body) call cmd%else_body%compile (pn_body, global) end if end select end subroutine cmd_if_compile @ %def global @ (Recursively) execute the condition. Context remains global in all cases. <>= procedure :: execute => cmd_if_execute <>= recursive subroutine cmd_if_execute (cmd, global) class(cmd_if_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list logical :: lval, is_known integer :: i var_list => global%get_var_list_ptr () lval = eval_log (cmd%pn_if_lexpr, var_list, is_known=is_known) if (is_known) then if (lval) then if (associated (cmd%if_body)) then call cmd%if_body%execute (global) end if return end if else call error_undecided () return end if if (associated (cmd%elsif_cmd)) then SCAN_ELSIF: do i = 1, size (cmd%elsif_cmd) lval = eval_log (cmd%elsif_cmd(i)%pn_if_lexpr, var_list, & is_known=is_known) if (is_known) then if (lval) then if (associated (cmd%elsif_cmd(i)%if_body)) then call cmd%elsif_cmd(i)%if_body%execute (global) end if return end if else call error_undecided () return end if end do SCAN_ELSIF end if if (associated (cmd%else_body)) then call cmd%else_body%execute (global) end if contains subroutine error_undecided () call msg_error ("Undefined result of cmditional expression: " & // "neither branch will be executed") end subroutine error_undecided end subroutine cmd_if_execute @ %def cmd_if_execute @ \subsubsection{Include another command-list file} The include command allocates a local parse tree. This must not be deleted before the command object itself is deleted, since pointers may point to subobjects of it. <>= type, extends (command_t) :: cmd_include_t private type(string_t) :: file type(command_list_t), pointer :: command_list => null () type(parse_tree_t) :: parse_tree contains <> end type cmd_include_t @ %def cmd_include_t @ Finalizer: delete the command list. No options, so we can simply override the default finalizer. <>= procedure :: final => cmd_include_final <>= subroutine cmd_include_final (cmd) class(cmd_include_t), intent(inout) :: cmd call parse_tree_final (cmd%parse_tree) if (associated (cmd%command_list)) then call cmd%command_list%final () deallocate (cmd%command_list) end if end subroutine cmd_include_final @ %def cmd_include_final @ Write: display the command list as-is, if allocated. <>= procedure :: write => cmd_include_write <>= subroutine cmd_include_write (cmd, unit, indent) class(cmd_include_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u, ind u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent call write_indent (u, indent) write (u, "(A,A,A,A)") "include ", '"', char (cmd%file), '"' if (associated (cmd%command_list)) then call cmd%command_list%write (u, ind + 1) end if end subroutine cmd_include_write @ %def cmd_include_write @ Compile file contents: First parse the file, then immediately compile its contents. Use the global data set. <>= procedure :: compile => cmd_include_compile <>= subroutine cmd_include_compile (cmd, global) class(cmd_include_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_arg, pn_file type(string_t) :: file logical :: exist integer :: u type(stream_t), target :: stream type(lexer_t) :: lexer pn_arg => parse_node_get_sub_ptr (cmd%pn, 2) pn_file => parse_node_get_sub_ptr (pn_arg) file = parse_node_get_string (pn_file) inquire (file=char(file), exist=exist) if (exist) then cmd%file = file else cmd%file = global%os_data%whizard_cutspath // "/" // file inquire (file=char(cmd%file), exist=exist) if (.not. exist) then call msg_error ("Include file '" // char (file) // "' not found") return end if end if u = free_unit () call lexer_init_cmd_list (lexer, global%lexer) call stream_init (stream, char (cmd%file)) call lexer_assign_stream (lexer, stream) call parse_tree_init (cmd%parse_tree, syntax_cmd_list, lexer) call stream_final (stream) call lexer_final (lexer) close (u) allocate (cmd%command_list) call cmd%command_list%compile (cmd%parse_tree%get_root_ptr (), & global) end subroutine cmd_include_compile @ %def cmd_include_compile @ Execute file contents in the global context. <>= procedure :: execute => cmd_include_execute <>= subroutine cmd_include_execute (cmd, global) class(cmd_include_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global if (associated (cmd%command_list)) then call msg_message & ("Including Sindarin from '" // char (cmd%file) // "'") call cmd%command_list%execute (global) call msg_message & ("End of included '" // char (cmd%file) // "'") end if end subroutine cmd_include_execute @ %def cmd_include_execute @ \subsubsection{Export values} This command exports the current values of variables or other objects to the surrounding scope. By default, a scope enclosed by braces keeps all objects local to it. The [[export]] command exports the values that are generated within the scope to the corresponding object in the outer scope. The allowed set of exportable objects is, in principle, the same as the set of objects that the [[show]] command supports. This includes some convenience abbreviations. TODO: The initial implementation inherits syntax from [[show]], but supports only the [[results]] pseudo-object. The results (i.e., the process stack) is appended to the outer process stack instead of being discarded. The behavior of the [[export]] command for other object kinds is to be defined on a case-by-case basis. It may involve replacing the outer value or, instead, doing some sort of appending or reduction. <>= type, extends (command_t) :: cmd_export_t private type(string_t), dimension(:), allocatable :: name contains <> end type cmd_export_t @ %def cmd_export_t @ Output: list the object names, not values. <>= procedure :: write => cmd_export_write <>= subroutine cmd_export_write (cmd, unit, indent) class(cmd_export_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u, i u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)", advance="no") "export: " if (allocated (cmd%name)) then do i = 1, size (cmd%name) write (u, "(1x,A)", advance="no") char (cmd%name(i)) end do write (u, *) else write (u, "(5x,A)") "[undefined]" end if end subroutine cmd_export_write @ %def cmd_export_write @ Compile. Allocate an array which is filled with the names of the variables to export. <>= procedure :: compile => cmd_export_compile <>= subroutine cmd_export_compile (cmd, global) class(cmd_export_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_arg, pn_var, pn_prefix, pn_name type(string_t) :: key integer :: i, n_args pn_arg => parse_node_get_sub_ptr (cmd%pn, 2) if (associated (pn_arg)) then select case (char (parse_node_get_rule_key (pn_arg))) case ("show_arg") cmd%pn_opt => parse_node_get_next_ptr (pn_arg) case default cmd%pn_opt => pn_arg pn_arg => null () end select end if call cmd%compile_options (global) if (associated (pn_arg)) then n_args = parse_node_get_n_sub (pn_arg) allocate (cmd%name (n_args)) pn_var => parse_node_get_sub_ptr (pn_arg) i = 0 do while (associated (pn_var)) i = i + 1 select case (char (parse_node_get_rule_key (pn_var))) case ("model", "library", "beams", "iterations", & "cuts", "weight", "int", "real", "complex", & "scale", "factorization_scale", "renormalization_scale", & "selection", "reweight", "analysis", "pdg", & "stable", "unstable", "polarized", "unpolarized", & "results", "expect", "intrinsic", "string", "logical") cmd%name(i) = parse_node_get_key (pn_var) case ("result_var") pn_prefix => parse_node_get_sub_ptr (pn_var) pn_name => parse_node_get_next_ptr (pn_prefix) if (associated (pn_name)) then cmd%name(i) = parse_node_get_key (pn_prefix) & // "(" // parse_node_get_string (pn_name) // ")" else cmd%name(i) = parse_node_get_key (pn_prefix) end if case ("log_var", "string_var", "alias_var") pn_prefix => parse_node_get_sub_ptr (pn_var) pn_name => parse_node_get_next_ptr (pn_prefix) key = parse_node_get_key (pn_prefix) if (associated (pn_name)) then select case (char (parse_node_get_rule_key (pn_name))) case ("var_name") select case (char (key)) case ("?", "$") ! $ sign cmd%name(i) = key // parse_node_get_string (pn_name) case ("alias") cmd%name(i) = parse_node_get_string (pn_name) end select case default call parse_node_mismatch & ("var_name", pn_name) end select else cmd%name(i) = key end if case default cmd%name(i) = parse_node_get_string (pn_var) end select !!! restriction imposed by current lack of implementation select case (char (parse_node_get_rule_key (pn_var))) case ("results") case default call msg_fatal ("export: object (type) '" & // char (parse_node_get_rule_key (pn_var)) & // "' not supported yet") end select pn_var => parse_node_get_next_ptr (pn_var) end do else allocate (cmd%name (0)) end if end subroutine cmd_export_compile @ %def cmd_export_compile @ Execute. Scan the list of objects to export. <>= procedure :: execute => cmd_export_execute <>= subroutine cmd_export_execute (cmd, global) class(cmd_export_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global call global%append_exports (cmd%name) end subroutine cmd_export_execute @ %def cmd_export_execute @ \subsubsection{Quit command execution} The code is the return code of the whole program if it is terminated by this command. <>= type, extends (command_t) :: cmd_quit_t private logical :: has_code = .false. type(parse_node_t), pointer :: pn_code_expr => null () contains <> end type cmd_quit_t @ %def cmd_quit_t @ Output. <>= procedure :: write => cmd_quit_write <>= subroutine cmd_quit_write (cmd, unit, indent) class(cmd_quit_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A,L1)") "quit: has_code = ", cmd%has_code end subroutine cmd_quit_write @ %def cmd_quit_write @ Compile: allocate a [[quit]] object which serves as a placeholder. <>= procedure :: compile => cmd_quit_compile <>= subroutine cmd_quit_compile (cmd, global) class(cmd_quit_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_arg pn_arg => parse_node_get_sub_ptr (cmd%pn, 2) if (associated (pn_arg)) then cmd%pn_code_expr => parse_node_get_sub_ptr (pn_arg) cmd%has_code = .true. end if end subroutine cmd_quit_compile @ %def cmd_quit_compile @ Execute: The quit command does not execute anything, it just stops command execution. This is achieved by setting quit flag and quit code in the global variable list. However, the return code, if present, is an expression which has to be evaluated. <>= procedure :: execute => cmd_quit_execute <>= subroutine cmd_quit_execute (cmd, global) class(cmd_quit_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list logical :: is_known var_list => global%get_var_list_ptr () if (cmd%has_code) then global%quit_code = eval_int (cmd%pn_code_expr, var_list, & is_known=is_known) if (.not. is_known) then call msg_error ("Undefined return code of quit/exit command") end if end if global%quit = .true. end subroutine cmd_quit_execute @ %def cmd_quit_execute @ \subsection{The command list} The command list holds a list of commands and relevant global data. <>= public :: command_list_t <>= type :: command_list_t ! not private anymore as required by the whizard-c-interface class(command_t), pointer :: first => null () class(command_t), pointer :: last => null () contains <> end type command_list_t @ %def command_list_t @ Output. <>= procedure :: write => command_list_write <>= recursive subroutine command_list_write (cmd_list, unit, indent) class(command_list_t), intent(in) :: cmd_list integer, intent(in), optional :: unit, indent class(command_t), pointer :: cmd cmd => cmd_list%first do while (associated (cmd)) call cmd%write (unit, indent) cmd => cmd%next end do end subroutine command_list_write @ %def command_list_write @ Append a new command to the list and free the original pointer. <>= procedure :: append => command_list_append <>= subroutine command_list_append (cmd_list, command) class(command_list_t), intent(inout) :: cmd_list class(command_t), intent(inout), pointer :: command if (associated (cmd_list%last)) then cmd_list%last%next => command else cmd_list%first => command end if cmd_list%last => command command => null () end subroutine command_list_append @ %def command_list_append @ Finalize. <>= procedure :: final => command_list_final <>= recursive subroutine command_list_final (cmd_list) class(command_list_t), intent(inout) :: cmd_list class(command_t), pointer :: command do while (associated (cmd_list%first)) command => cmd_list%first cmd_list%first => cmd_list%first%next call command%final () deallocate (command) end do cmd_list%last => null () end subroutine command_list_final @ %def command_list_final @ \subsection{Compiling the parse tree} Transform a parse tree into a command list. Initialization is assumed to be done. After each command, we set a breakpoint. <>= procedure :: compile => command_list_compile <>= recursive subroutine command_list_compile (cmd_list, pn, global) class(command_list_t), intent(inout), target :: cmd_list type(parse_node_t), intent(in), target :: pn type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_cmd class(command_t), pointer :: command integer :: i pn_cmd => parse_node_get_sub_ptr (pn) do i = 1, parse_node_get_n_sub (pn) call dispatch_command (command, pn_cmd) call command%compile (global) call cmd_list%append (command) call terminate_now_if_signal () pn_cmd => parse_node_get_next_ptr (pn_cmd) end do end subroutine command_list_compile @ %def command_list_compile @ \subsection{Executing the command list} Before executing a command we should execute its options (if any). After that, reset the options, i.e., remove temporary effects from the global state. Also here, after each command we set a breakpoint. <>= procedure :: execute => command_list_execute <>= recursive subroutine command_list_execute (cmd_list, global) class(command_list_t), intent(in) :: cmd_list type(rt_data_t), intent(inout), target :: global class(command_t), pointer :: command command => cmd_list%first COMMAND_COND: do while (associated (command)) call command%execute_options (global) call command%execute (global) call command%reset_options (global) call terminate_now_if_signal () if (global%quit) exit COMMAND_COND command => command%next end do COMMAND_COND end subroutine command_list_execute @ %def command_list_execute @ \subsection{Command list syntax} <>= public :: syntax_cmd_list <>= type(syntax_t), target, save :: syntax_cmd_list @ %def syntax_cmd_list <>= public :: syntax_cmd_list_init <>= subroutine syntax_cmd_list_init () type(ifile_t) :: ifile call define_cmd_list_syntax (ifile) call syntax_init (syntax_cmd_list, ifile) call ifile_final (ifile) end subroutine syntax_cmd_list_init @ %def syntax_cmd_list_init <>= public :: syntax_cmd_list_final <>= subroutine syntax_cmd_list_final () call syntax_final (syntax_cmd_list) end subroutine syntax_cmd_list_final @ %def syntax_cmd_list_final <>= public :: syntax_cmd_list_write <>= subroutine syntax_cmd_list_write (unit) integer, intent(in), optional :: unit call syntax_write (syntax_cmd_list, unit) end subroutine syntax_cmd_list_write @ %def syntax_cmd_list_write <>= subroutine define_cmd_list_syntax (ifile) type(ifile_t), intent(inout) :: ifile call ifile_append (ifile, "SEQ command_list = command*") call ifile_append (ifile, "ALT command = " & // "cmd_model | cmd_library | cmd_iterations | cmd_sample_format | " & // "cmd_var | cmd_slha | " & // "cmd_show | cmd_clear | " & // "cmd_expect | " & // "cmd_cuts | cmd_scale | cmd_fac_scale | cmd_ren_scale | " & // "cmd_weight | cmd_selection | cmd_reweight | " & // "cmd_beams | cmd_beams_pol_density | cmd_beams_pol_fraction | " & // "cmd_beams_momentum | cmd_beams_theta | cmd_beams_phi | " & // "cmd_integrate | " & // "cmd_observable | cmd_histogram | cmd_plot | cmd_graph | " & // "cmd_record | " & // "cmd_analysis | cmd_alt_setup | " & // "cmd_unstable | cmd_stable | cmd_simulate | cmd_rescan | " & // "cmd_process | cmd_compile | cmd_exec | " & // "cmd_scan | cmd_if | cmd_include | cmd_quit | " & // "cmd_export | " & // "cmd_polarized | cmd_unpolarized | " & // "cmd_open_out | cmd_close_out | cmd_printf | " & // "cmd_write_analysis | cmd_compile_analysis | cmd_nlo | cmd_components") call ifile_append (ifile, "GRO options = '{' local_command_list '}'") call ifile_append (ifile, "SEQ local_command_list = local_command*") call ifile_append (ifile, "ALT local_command = " & // "cmd_model | cmd_library | cmd_iterations | cmd_sample_format | " & // "cmd_var | cmd_slha | " & // "cmd_show | " & // "cmd_expect | " & // "cmd_cuts | cmd_scale | cmd_fac_scale | cmd_ren_scale | " & // "cmd_weight | cmd_selection | cmd_reweight | " & // "cmd_beams | cmd_beams_pol_density | cmd_beams_pol_fraction | " & // "cmd_beams_momentum | cmd_beams_theta | cmd_beams_phi | " & // "cmd_observable | cmd_histogram | cmd_plot | cmd_graph | " & // "cmd_clear | cmd_record | " & // "cmd_analysis | cmd_alt_setup | " & // "cmd_open_out | cmd_close_out | cmd_printf | " & // "cmd_write_analysis | cmd_compile_analysis | cmd_nlo | cmd_components") call ifile_append (ifile, "SEQ cmd_model = model '=' model_name model_arg?") call ifile_append (ifile, "KEY model") call ifile_append (ifile, "ALT model_name = model_id | string_literal") call ifile_append (ifile, "IDE model_id") call ifile_append (ifile, "ARG model_arg = ( model_scheme? )") call ifile_append (ifile, "ALT model_scheme = " & // "ufo_spec | scheme_id | string_literal") call ifile_append (ifile, "SEQ ufo_spec = ufo ufo_arg?") call ifile_append (ifile, "KEY ufo") call ifile_append (ifile, "ARG ufo_arg = ( string_literal )") call ifile_append (ifile, "IDE scheme_id") call ifile_append (ifile, "SEQ cmd_library = library '=' lib_name") call ifile_append (ifile, "KEY library") call ifile_append (ifile, "ALT lib_name = lib_id | string_literal") call ifile_append (ifile, "IDE lib_id") call ifile_append (ifile, "ALT cmd_var = " & // "cmd_log_decl | cmd_log | " & // "cmd_int | cmd_real | cmd_complex | cmd_num | " & // "cmd_string_decl | cmd_string | cmd_alias | " & // "cmd_result") call ifile_append (ifile, "SEQ cmd_log_decl = logical cmd_log") call ifile_append (ifile, "SEQ cmd_log = '?' var_name '=' lexpr") call ifile_append (ifile, "SEQ cmd_int = int var_name '=' expr") call ifile_append (ifile, "SEQ cmd_real = real var_name '=' expr") call ifile_append (ifile, "SEQ cmd_complex = complex var_name '=' expr") call ifile_append (ifile, "SEQ cmd_num = var_name '=' expr") call ifile_append (ifile, "SEQ cmd_string_decl = string cmd_string") call ifile_append (ifile, "SEQ cmd_string = " & // "'$' var_name '=' sexpr") ! $ call ifile_append (ifile, "SEQ cmd_alias = alias var_name '=' cexpr") call ifile_append (ifile, "SEQ cmd_result = result '=' expr") call ifile_append (ifile, "SEQ cmd_slha = slha_action slha_arg options?") call ifile_append (ifile, "ALT slha_action = " & // "read_slha | write_slha") call ifile_append (ifile, "KEY read_slha") call ifile_append (ifile, "KEY write_slha") call ifile_append (ifile, "ARG slha_arg = ( string_literal )") call ifile_append (ifile, "SEQ cmd_show = show show_arg options?") call ifile_append (ifile, "KEY show") call ifile_append (ifile, "ARG show_arg = ( showable* )") call ifile_append (ifile, "ALT showable = " & // "model | library | beams | iterations | " & // "cuts | weight | logical | string | pdg | " & // "scale | factorization_scale | renormalization_scale | " & // "selection | reweight | analysis | " & // "stable | unstable | polarized | unpolarized | " & // "expect | intrinsic | int | real | complex | " & // "alias_var | string | results | result_var | " & // "log_var | string_var | var_name") call ifile_append (ifile, "KEY results") call ifile_append (ifile, "KEY intrinsic") call ifile_append (ifile, "SEQ alias_var = alias var_name") call ifile_append (ifile, "SEQ result_var = result_key result_arg?") call ifile_append (ifile, "SEQ log_var = '?' var_name") call ifile_append (ifile, "SEQ string_var = '$' var_name") ! $ call ifile_append (ifile, "SEQ cmd_clear = clear clear_arg options?") call ifile_append (ifile, "KEY clear") call ifile_append (ifile, "ARG clear_arg = ( clearable* )") call ifile_append (ifile, "ALT clearable = " & // "beams | iterations | " & // "cuts | weight | " & // "scale | factorization_scale | renormalization_scale | " & // "selection | reweight | analysis | " & // "unstable | polarized | " & // "expect | " & // "log_var | string_var | var_name") call ifile_append (ifile, "SEQ cmd_expect = expect expect_arg options?") call ifile_append (ifile, "KEY expect") call ifile_append (ifile, "ARG expect_arg = ( lexpr )") call ifile_append (ifile, "SEQ cmd_cuts = cuts '=' lexpr") call ifile_append (ifile, "SEQ cmd_scale = scale '=' expr") call ifile_append (ifile, "SEQ cmd_fac_scale = " & // "factorization_scale '=' expr") call ifile_append (ifile, "SEQ cmd_ren_scale = " & // "renormalization_scale '=' expr") call ifile_append (ifile, "SEQ cmd_weight = weight '=' expr") call ifile_append (ifile, "SEQ cmd_selection = selection '=' lexpr") call ifile_append (ifile, "SEQ cmd_reweight = reweight '=' expr") call ifile_append (ifile, "KEY cuts") call ifile_append (ifile, "KEY scale") call ifile_append (ifile, "KEY factorization_scale") call ifile_append (ifile, "KEY renormalization_scale") call ifile_append (ifile, "KEY weight") call ifile_append (ifile, "KEY selection") call ifile_append (ifile, "KEY reweight") call ifile_append (ifile, "SEQ cmd_process = process process_id '=' " & // "process_prt '=>' prt_state_list options?") call ifile_append (ifile, "KEY process") call ifile_append (ifile, "KEY '=>'") call ifile_append (ifile, "LIS process_prt = cexpr+") call ifile_append (ifile, "LIS prt_state_list = prt_state_sum+") call ifile_append (ifile, "SEQ prt_state_sum = " & // "prt_state prt_state_addition*") call ifile_append (ifile, "SEQ prt_state_addition = '+' prt_state") call ifile_append (ifile, "ALT prt_state = grouped_prt_state_list | cexpr") call ifile_append (ifile, "GRO grouped_prt_state_list = " & // "( prt_state_list )") call ifile_append (ifile, "SEQ cmd_compile = compile_cmd options?") call ifile_append (ifile, "SEQ compile_cmd = compile_clause compile_arg?") call ifile_append (ifile, "SEQ compile_clause = compile exec_name_spec?") call ifile_append (ifile, "KEY compile") call ifile_append (ifile, "SEQ exec_name_spec = as exec_name") call ifile_append (ifile, "KEY as") call ifile_append (ifile, "ALT exec_name = exec_id | string_literal") call ifile_append (ifile, "IDE exec_id") call ifile_append (ifile, "ARG compile_arg = ( lib_name* )") call ifile_append (ifile, "SEQ cmd_exec = exec exec_arg") call ifile_append (ifile, "KEY exec") call ifile_append (ifile, "ARG exec_arg = ( sexpr )") call ifile_append (ifile, "SEQ cmd_beams = beams '=' beam_def") call ifile_append (ifile, "KEY beams") call ifile_append (ifile, "SEQ beam_def = beam_spec strfun_seq*") call ifile_append (ifile, "SEQ beam_spec = beam_list") call ifile_append (ifile, "LIS beam_list = cexpr, cexpr?") call ifile_append (ifile, "SEQ cmd_beams_pol_density = " & // "beams_pol_density '=' beams_pol_spec") call ifile_append (ifile, "KEY beams_pol_density") call ifile_append (ifile, "LIS beams_pol_spec = smatrix, smatrix?") call ifile_append (ifile, "SEQ smatrix = '@' smatrix_arg") ! call ifile_append (ifile, "KEY '@'") !!! Key already exists call ifile_append (ifile, "ARG smatrix_arg = ( sentry* )") call ifile_append (ifile, "SEQ sentry = expr extra_sentry*") call ifile_append (ifile, "SEQ extra_sentry = ':' expr") call ifile_append (ifile, "SEQ cmd_beams_pol_fraction = " & // "beams_pol_fraction '=' beams_par_spec") call ifile_append (ifile, "KEY beams_pol_fraction") call ifile_append (ifile, "SEQ cmd_beams_momentum = " & // "beams_momentum '=' beams_par_spec") call ifile_append (ifile, "KEY beams_momentum") call ifile_append (ifile, "SEQ cmd_beams_theta = " & // "beams_theta '=' beams_par_spec") call ifile_append (ifile, "KEY beams_theta") call ifile_append (ifile, "SEQ cmd_beams_phi = " & // "beams_phi '=' beams_par_spec") call ifile_append (ifile, "KEY beams_phi") call ifile_append (ifile, "LIS beams_par_spec = expr, expr?") call ifile_append (ifile, "SEQ strfun_seq = '=>' strfun_pair") call ifile_append (ifile, "LIS strfun_pair = strfun_def, strfun_def?") call ifile_append (ifile, "SEQ strfun_def = strfun_id") call ifile_append (ifile, "ALT strfun_id = " & // "none | lhapdf | lhapdf_photon | pdf_builtin | pdf_builtin_photon | " & // "isr | epa | ewa | circe1 | circe2 | energy_scan | " & // "gaussian | beam_events") call ifile_append (ifile, "KEY none") call ifile_append (ifile, "KEY lhapdf") call ifile_append (ifile, "KEY lhapdf_photon") call ifile_append (ifile, "KEY pdf_builtin") call ifile_append (ifile, "KEY pdf_builtin_photon") call ifile_append (ifile, "KEY isr") call ifile_append (ifile, "KEY epa") call ifile_append (ifile, "KEY ewa") call ifile_append (ifile, "KEY circe1") call ifile_append (ifile, "KEY circe2") call ifile_append (ifile, "KEY energy_scan") call ifile_append (ifile, "KEY gaussian") call ifile_append (ifile, "KEY beam_events") call ifile_append (ifile, "SEQ cmd_integrate = " & // "integrate proc_arg options?") call ifile_append (ifile, "KEY integrate") call ifile_append (ifile, "ARG proc_arg = ( proc_id* )") call ifile_append (ifile, "IDE proc_id") call ifile_append (ifile, "SEQ cmd_iterations = " & // "iterations '=' iterations_list") call ifile_append (ifile, "KEY iterations") call ifile_append (ifile, "LIS iterations_list = iterations_spec+") call ifile_append (ifile, "ALT iterations_spec = it_spec") call ifile_append (ifile, "SEQ it_spec = expr calls_spec adapt_spec?") call ifile_append (ifile, "SEQ calls_spec = ':' expr") call ifile_append (ifile, "SEQ adapt_spec = ':' sexpr") call ifile_append (ifile, "SEQ cmd_components = " & // "active '=' component_list") call ifile_append (ifile, "KEY active") call ifile_append (ifile, "LIS component_list = sexpr+") call ifile_append (ifile, "SEQ cmd_sample_format = " & // "sample_format '=' event_format_list") call ifile_append (ifile, "KEY sample_format") call ifile_append (ifile, "LIS event_format_list = event_format+") call ifile_append (ifile, "IDE event_format") call ifile_append (ifile, "SEQ cmd_observable = " & // "observable analysis_tag options?") call ifile_append (ifile, "KEY observable") call ifile_append (ifile, "SEQ cmd_histogram = " & // "histogram analysis_tag histogram_arg " & // "options?") call ifile_append (ifile, "KEY histogram") call ifile_append (ifile, "ARG histogram_arg = (expr, expr, expr?)") call ifile_append (ifile, "SEQ cmd_plot = plot analysis_tag options?") call ifile_append (ifile, "KEY plot") call ifile_append (ifile, "SEQ cmd_graph = graph graph_term '=' graph_def") call ifile_append (ifile, "KEY graph") call ifile_append (ifile, "SEQ graph_term = analysis_tag options?") call ifile_append (ifile, "SEQ graph_def = graph_term graph_append*") call ifile_append (ifile, "SEQ graph_append = '&' graph_term") call ifile_append (ifile, "SEQ cmd_analysis = analysis '=' lexpr") call ifile_append (ifile, "KEY analysis") call ifile_append (ifile, "SEQ cmd_alt_setup = " & // "alt_setup '=' option_list_expr") call ifile_append (ifile, "KEY alt_setup") call ifile_append (ifile, "ALT option_list_expr = " & // "grouped_option_list | option_list") call ifile_append (ifile, "GRO grouped_option_list = ( option_list_expr )") call ifile_append (ifile, "LIS option_list = options+") call ifile_append (ifile, "SEQ cmd_open_out = open_out open_arg options?") call ifile_append (ifile, "SEQ cmd_close_out = close_out open_arg options?") call ifile_append (ifile, "KEY open_out") call ifile_append (ifile, "KEY close_out") call ifile_append (ifile, "ARG open_arg = (sexpr)") call ifile_append (ifile, "SEQ cmd_printf = printf_cmd options?") call ifile_append (ifile, "SEQ printf_cmd = printf_clause sprintf_args?") call ifile_append (ifile, "SEQ printf_clause = printf sexpr") call ifile_append (ifile, "KEY printf") call ifile_append (ifile, "SEQ cmd_record = record_cmd") call ifile_append (ifile, "SEQ cmd_unstable = " & // "unstable cexpr unstable_arg options?") call ifile_append (ifile, "KEY unstable") call ifile_append (ifile, "ARG unstable_arg = ( proc_id* )") call ifile_append (ifile, "SEQ cmd_stable = stable stable_list options?") call ifile_append (ifile, "KEY stable") call ifile_append (ifile, "LIS stable_list = cexpr+") call ifile_append (ifile, "KEY polarized") call ifile_append (ifile, "SEQ cmd_polarized = polarized polarized_list options?") call ifile_append (ifile, "LIS polarized_list = cexpr+") call ifile_append (ifile, "KEY unpolarized") call ifile_append (ifile, "SEQ cmd_unpolarized = unpolarized unpolarized_list options?") call ifile_append (ifile, "LIS unpolarized_list = cexpr+") call ifile_append (ifile, "SEQ cmd_simulate = " & // "simulate proc_arg options?") call ifile_append (ifile, "KEY simulate") call ifile_append (ifile, "SEQ cmd_rescan = " & // "rescan sexpr proc_arg options?") call ifile_append (ifile, "KEY rescan") call ifile_append (ifile, "SEQ cmd_scan = scan scan_var scan_body?") call ifile_append (ifile, "KEY scan") call ifile_append (ifile, "ALT scan_var = " & // "scan_log_decl | scan_log | " & // "scan_int | scan_real | scan_complex | scan_num | " & // "scan_string_decl | scan_string | scan_alias | " & // "scan_cuts | scan_weight | " & // "scan_scale | scan_ren_scale | scan_fac_scale | " & // "scan_selection | scan_reweight | scan_analysis | " & // "scan_model | scan_library") call ifile_append (ifile, "SEQ scan_log_decl = logical scan_log") call ifile_append (ifile, "SEQ scan_log = '?' var_name '=' scan_log_arg") call ifile_append (ifile, "ARG scan_log_arg = ( lexpr* )") call ifile_append (ifile, "SEQ scan_int = int var_name '=' scan_num_arg") call ifile_append (ifile, "SEQ scan_real = real var_name '=' scan_num_arg") call ifile_append (ifile, "SEQ scan_complex = " & // "complex var_name '=' scan_num_arg") call ifile_append (ifile, "SEQ scan_num = var_name '=' scan_num_arg") call ifile_append (ifile, "ARG scan_num_arg = ( range* )") call ifile_append (ifile, "ALT range = grouped_range | range_expr") call ifile_append (ifile, "GRO grouped_range = ( range_expr )") call ifile_append (ifile, "SEQ range_expr = expr range_spec?") call ifile_append (ifile, "SEQ range_spec = '=>' expr step_spec?") call ifile_append (ifile, "SEQ step_spec = step_op expr") call ifile_append (ifile, "ALT step_op = " & // "'/+' | '/-' | '/*' | '//' | '/+/' | '/*/'") call ifile_append (ifile, "KEY '/+'") call ifile_append (ifile, "KEY '/-'") call ifile_append (ifile, "KEY '/*'") call ifile_append (ifile, "KEY '//'") call ifile_append (ifile, "KEY '/+/'") call ifile_append (ifile, "KEY '/*/'") call ifile_append (ifile, "SEQ scan_string_decl = string scan_string") call ifile_append (ifile, "SEQ scan_string = " & // "'$' var_name '=' scan_string_arg") call ifile_append (ifile, "ARG scan_string_arg = ( sexpr* )") call ifile_append (ifile, "SEQ scan_alias = " & // "alias var_name '=' scan_alias_arg") call ifile_append (ifile, "ARG scan_alias_arg = ( cexpr* )") call ifile_append (ifile, "SEQ scan_cuts = cuts '=' scan_lexpr_arg") call ifile_append (ifile, "ARG scan_lexpr_arg = ( lexpr* )") call ifile_append (ifile, "SEQ scan_scale = scale '=' scan_expr_arg") call ifile_append (ifile, "ARG scan_expr_arg = ( expr* )") call ifile_append (ifile, "SEQ scan_fac_scale = " & // "factorization_scale '=' scan_expr_arg") call ifile_append (ifile, "SEQ scan_ren_scale = " & // "renormalization_scale '=' scan_expr_arg") call ifile_append (ifile, "SEQ scan_weight = weight '=' scan_expr_arg") call ifile_append (ifile, "SEQ scan_selection = selection '=' scan_lexpr_arg") call ifile_append (ifile, "SEQ scan_reweight = reweight '=' scan_expr_arg") call ifile_append (ifile, "SEQ scan_analysis = analysis '=' scan_lexpr_arg") call ifile_append (ifile, "SEQ scan_model = model '=' scan_model_arg") call ifile_append (ifile, "ARG scan_model_arg = ( model_name* )") call ifile_append (ifile, "SEQ scan_library = library '=' scan_library_arg") call ifile_append (ifile, "ARG scan_library_arg = ( lib_name* )") call ifile_append (ifile, "GRO scan_body = '{' command_list '}'") call ifile_append (ifile, "SEQ cmd_if = " & // "if lexpr then command_list elsif_clauses else_clause endif") call ifile_append (ifile, "SEQ elsif_clauses = cmd_elsif*") call ifile_append (ifile, "SEQ cmd_elsif = elsif lexpr then command_list") call ifile_append (ifile, "SEQ else_clause = cmd_else?") call ifile_append (ifile, "SEQ cmd_else = else command_list") call ifile_append (ifile, "SEQ cmd_include = include include_arg") call ifile_append (ifile, "KEY include") call ifile_append (ifile, "ARG include_arg = ( string_literal )") call ifile_append (ifile, "SEQ cmd_quit = quit_cmd quit_arg?") call ifile_append (ifile, "ALT quit_cmd = quit | exit") call ifile_append (ifile, "KEY quit") call ifile_append (ifile, "KEY exit") call ifile_append (ifile, "ARG quit_arg = ( expr )") call ifile_append (ifile, "SEQ cmd_export = export show_arg options?") call ifile_append (ifile, "KEY export") call ifile_append (ifile, "SEQ cmd_write_analysis = " & // "write_analysis_clause options?") call ifile_append (ifile, "SEQ cmd_compile_analysis = " & // "compile_analysis_clause options?") call ifile_append (ifile, "SEQ write_analysis_clause = " & // "write_analysis write_analysis_arg?") call ifile_append (ifile, "SEQ compile_analysis_clause = " & // "compile_analysis write_analysis_arg?") call ifile_append (ifile, "KEY write_analysis") call ifile_append (ifile, "KEY compile_analysis") call ifile_append (ifile, "ARG write_analysis_arg = ( analysis_tag* )") call ifile_append (ifile, "SEQ cmd_nlo = " & // "nlo_calculation '=' nlo_calculation_list") call ifile_append (ifile, "KEY nlo_calculation") call ifile_append (ifile, "LIS nlo_calculation_list = nlo_comp+") call ifile_append (ifile, "ALT nlo_comp = " // & "full | born | real | virtual | dglap | subtraction | " // & "mismatch | GKS") call ifile_append (ifile, "KEY full") call ifile_append (ifile, "KEY born") call ifile_append (ifile, "KEY virtual") call ifile_append (ifile, "KEY dglap") call ifile_append (ifile, "KEY subtraction") call ifile_append (ifile, "KEY mismatch") call ifile_append (ifile, "KEY GKS") call define_expr_syntax (ifile, particles=.true., analysis=.true.) end subroutine define_cmd_list_syntax @ %def define_cmd_list_syntax <>= public :: lexer_init_cmd_list <>= subroutine lexer_init_cmd_list (lexer, parent_lexer) type(lexer_t), intent(out) :: lexer type(lexer_t), intent(in), optional, target :: parent_lexer call lexer_init (lexer, & comment_chars = "#!", & quote_chars = '"', & quote_match = '"', & single_chars = "()[]{},;:&%?$@", & special_class = [ "+-*/^", "<>=~ " ] , & keyword_list = syntax_get_keyword_list_ptr (syntax_cmd_list), & parent = parent_lexer) end subroutine lexer_init_cmd_list @ %def lexer_init_cmd_list @ \subsection{Unit Tests} Test module, followed by the corresponding implementation module. <<[[commands_ut.f90]]>>= <> module commands_ut use unit_tests use system_dependencies, only: MPOST_AVAILABLE use commands_uti <> <> contains <> end module commands_ut @ %def commands_ut @ <<[[commands_uti.f90]]>>= <> module commands_uti <> use kinds, only: i64 <> use io_units use ifiles use parser use interactions, only: reset_interaction_counter use prclib_stacks use analysis use variables, only: var_list_t use models use slha_interface use rt_data use event_base, only: generic_event_t, event_callback_t use commands <> <> <> contains <> <> end module commands_uti @ %def commands_uti @ API: driver for the unit tests below. <>= public :: commands_test <>= subroutine commands_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine commands_test @ %def commands_test @ \subsubsection{Prepare Sindarin code} This routine parses an internal file, prints the parse tree, and returns a parse node to the root. We use the routine in the tests below. <>= public :: parse_ifile <>= subroutine parse_ifile (ifile, pn_root, u) use ifiles use lexers use parser use commands type(ifile_t), intent(in) :: ifile type(parse_node_t), pointer, intent(out) :: pn_root integer, intent(in), optional :: u type(stream_t), target :: stream type(lexer_t), target :: lexer type(parse_tree_t) :: parse_tree call lexer_init_cmd_list (lexer) call stream_init (stream, ifile) call lexer_assign_stream (lexer, stream) call parse_tree_init (parse_tree, syntax_cmd_list, lexer) if (present (u)) call parse_tree_write (parse_tree, u) pn_root => parse_tree%get_root_ptr () call stream_final (stream) call lexer_final (lexer) end subroutine parse_ifile @ %def parse_ifile @ \subsubsection{Empty command list} Compile and execute an empty command list. Should do nothing but test the integrity of the workflow. <>= call test (commands_1, "commands_1", & "empty command list", & u, results) <>= public :: commands_1 <>= subroutine commands_1 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_1" write (u, "(A)") "* Purpose: compile and execute empty command list" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () write (u, "(A)") "* Parse empty file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" if (associated (pn_root)) then call command_list%compile (pn_root, global) end if write (u, "(A)") write (u, "(A)") "* Execute command list" call global%activate () call command_list%execute (global) call global%deactivate () write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call syntax_cmd_list_final () call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_1" end subroutine commands_1 @ %def commands_1 @ \subsubsection{Read model} Execute a [[model]] assignment. <>= call test (commands_2, "commands_2", & "model", & u, results) <>= public :: commands_2 <>= subroutine commands_2 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_2" write (u, "(A)") "* Purpose: set model" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call syntax_model_file_init () call global%global_init () write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'model = "Test"') call ifile_write (ifile, u) write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_2" end subroutine commands_2 @ %def commands_2 @ \subsubsection{Declare Process} Read a model, then declare a process. The process library is allocated explicitly. For the process definition, We take the default ([[omega]]) method. Since we do not compile, \oMega\ is not actually called. <>= call test (commands_3, "commands_3", & "process declaration", & u, results) <>= public :: commands_3 <>= subroutine commands_3 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root type(prclib_entry_t), pointer :: lib write (u, "(A)") "* Test output: commands_3" write (u, "(A)") "* Purpose: define process" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call syntax_model_file_init () call global%global_init () call global%var_list%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) allocate (lib) call lib%init (var_str ("lib_cmd3")) call global%add_prclib (lib) write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'model = "Test"') call ifile_append (ifile, 'process t3 = s, s => s, s') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) call global%prclib_stack%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_3" end subroutine commands_3 @ %def commands_3 @ \subsubsection{Compile Process} Read a model, then declare a process and compile the library. The process library is allocated explicitly. For the process definition, We take the default ([[unit_test]]) method. There is no external code, so compilation of the library is merely a formal status change. <>= call test (commands_4, "commands_4", & "compilation", & u, results) <>= public :: commands_4 <>= subroutine commands_4 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root type(prclib_entry_t), pointer :: lib write (u, "(A)") "* Test output: commands_4" write (u, "(A)") "* Purpose: define process and compile library" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call syntax_model_file_init () call global%global_init () call global%var_list%set_string (var_str ("$method"), & var_str ("unit_test"), is_known=.true.) allocate (lib) call lib%init (var_str ("lib_cmd4")) call global%add_prclib (lib) write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'model = "Test"') call ifile_append (ifile, 'process t4 = s, s => s, s') call ifile_append (ifile, 'compile ("lib_cmd4")') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) call global%prclib_stack%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_4" end subroutine commands_4 @ %def commands_4 @ \subsubsection{Integrate Process} Read a model, then declare a process, compile the library, and integrate over phase space. We take the default ([[unit_test]]) method and use the simplest methods of phase-space parameterization and integration. <>= call test (commands_5, "commands_5", & "integration", & u, results) <>= public :: commands_5 <>= subroutine commands_5 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root type(prclib_entry_t), pointer :: lib write (u, "(A)") "* Test output: commands_5" write (u, "(A)") "* Purpose: define process, iterations, and integrate" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call syntax_model_file_init () call global%global_init () call global%var_list%set_string (var_str ("$method"), & var_str ("unit_test"), is_known=.true.) call global%var_list%set_string (var_str ("$phs_method"), & var_str ("single"), is_known=.true.) call global%var_list%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known=.true.) call global%var_list%set_log (var_str ("?vis_history"),& .false., is_known=.true.) call global%var_list%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%var_list%set_real (var_str ("sqrts"), & 1000._default, is_known=.true.) call global%var_list%set_int (var_str ("seed"), 0, is_known=.true.) allocate (lib) call lib%init (var_str ("lib_cmd5")) call global%add_prclib (lib) write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'model = "Test"') call ifile_append (ifile, 'process t5 = s, s => s, s') call ifile_append (ifile, 'compile') call ifile_append (ifile, 'iterations = 1:1000') call ifile_append (ifile, 'integrate (t5)') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call reset_interaction_counter () call command_list%execute (global) call global%it_list%write (u) write (u, "(A)") call global%process_stack%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_5" end subroutine commands_5 @ %def commands_5 @ \subsubsection{Variables} Set intrinsic and user-defined variables. <>= call test (commands_6, "commands_6", & "variables", & u, results) <>= public :: commands_6 <>= subroutine commands_6 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_6" write (u, "(A)") "* Purpose: define and set variables" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () call global%write_vars (u, [ & var_str ("$run_id"), & var_str ("?unweighted"), & var_str ("sqrts")]) write (u, "(A)") write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, '$run_id = "run1"') call ifile_append (ifile, '?unweighted = false') call ifile_append (ifile, 'sqrts = 1000') call ifile_append (ifile, 'int j = 10') call ifile_append (ifile, 'real x = 1000.') call ifile_append (ifile, 'complex z = 5') call ifile_append (ifile, 'string $text = "abcd"') call ifile_append (ifile, 'logical ?flag = true') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) call global%write_vars (u, [ & var_str ("$run_id"), & var_str ("?unweighted"), & var_str ("sqrts"), & var_str ("j"), & var_str ("x"), & var_str ("z"), & var_str ("$text"), & var_str ("?flag")]) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call syntax_cmd_list_final () call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_6" end subroutine commands_6 @ %def commands_6 @ \subsubsection{Process library} Open process libraries explicitly. <>= call test (commands_7, "commands_7", & "process library", & u, results) <>= public :: commands_7 <>= subroutine commands_7 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_7" write (u, "(A)") "* Purpose: declare process libraries" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () call global%var_list%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) global%os_data%fc = "Fortran-compiler" global%os_data%fcflags = "Fortran-flags" global%os_data%fclibs = "Fortran-libs" write (u, "(A)") write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'library = "lib_cmd7_1"') call ifile_append (ifile, 'library = "lib_cmd7_2"') call ifile_append (ifile, 'library = "lib_cmd7_1"') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) call global%write_libraries (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call syntax_cmd_list_final () call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_7" end subroutine commands_7 @ %def commands_7 @ \subsubsection{Generate events} Read a model, then declare a process, compile the library, and generate weighted events. We take the default ([[unit_test]]) method and use the simplest methods of phase-space parameterization and integration. <>= call test (commands_8, "commands_8", & "event generation", & u, results) <>= public :: commands_8 <>= subroutine commands_8 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root type(prclib_entry_t), pointer :: lib write (u, "(A)") "* Test output: commands_8" write (u, "(A)") "* Purpose: define process, integrate, generate events" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call syntax_model_file_init () call global%global_init () call global%init_fallback_model & (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl")) call global%var_list%set_string (var_str ("$method"), & var_str ("unit_test"), is_known=.true.) call global%var_list%set_string (var_str ("$phs_method"), & var_str ("single"), is_known=.true.) call global%var_list%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known=.true.) call global%var_list%set_log (var_str ("?vis_history"),& .false., is_known=.true.) call global%var_list%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%var_list%set_real (var_str ("sqrts"), & 1000._default, is_known=.true.) allocate (lib) call lib%init (var_str ("lib_cmd8")) call global%add_prclib (lib) write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'model = "Test"') call ifile_append (ifile, 'process commands_8_p = s, s => s, s') call ifile_append (ifile, 'compile') call ifile_append (ifile, 'iterations = 1:1000') call ifile_append (ifile, 'integrate (commands_8_p)') call ifile_append (ifile, '?unweighted = false') call ifile_append (ifile, 'n_events = 3') call ifile_append (ifile, '?read_raw = false') call ifile_append (ifile, 'simulate (commands_8_p)') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" call command_list%execute (global) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_8" end subroutine commands_8 @ %def commands_8 @ \subsubsection{Define cuts} Declare a cut expression. <>= call test (commands_9, "commands_9", & "cuts", & u, results) <>= public :: commands_9 <>= subroutine commands_9 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root type(string_t), dimension(0) :: no_vars write (u, "(A)") "* Test output: commands_9" write (u, "(A)") "* Purpose: define cuts" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'cuts = all Pt > 0 [particle]') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) call global%write (u, vars = no_vars) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_9" end subroutine commands_9 @ %def commands_9 @ \subsubsection{Beams} Define beam setup. <>= call test (commands_10, "commands_10", & "beams", & u, results) <>= public :: commands_10 <>= subroutine commands_10 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_10" write (u, "(A)") "* Purpose: define beams" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call syntax_model_file_init () call global%global_init () write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'model = QCD') call ifile_append (ifile, 'sqrts = 1000') call ifile_append (ifile, 'beams = p, p') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) call global%write_beams (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_10" end subroutine commands_10 @ %def commands_10 @ \subsubsection{Structure functions} Define beam setup with structure functions <>= call test (commands_11, "commands_11", & "structure functions", & u, results) <>= public :: commands_11 <>= subroutine commands_11 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_11" write (u, "(A)") "* Purpose: define beams with structure functions" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call syntax_model_file_init () call global%global_init () write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'model = QCD') call ifile_append (ifile, 'sqrts = 1100') call ifile_append (ifile, 'beams = p, p => lhapdf => pdf_builtin, isr') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) call global%write_beams (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_11" end subroutine commands_11 @ %def commands_11 @ \subsubsection{Rescan events} Read a model, then declare a process, compile the library, and generate weighted events. We take the default ([[unit_test]]) method and use the simplest methods of phase-space parameterization and integration. Then, rescan the generated event sample. <>= call test (commands_12, "commands_12", & "event rescanning", & u, results) <>= public :: commands_12 <>= subroutine commands_12 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root type(prclib_entry_t), pointer :: lib write (u, "(A)") "* Test output: commands_12" write (u, "(A)") "* Purpose: generate events and rescan" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call syntax_model_file_init () call global%global_init () call global%var_list%append_log (& var_str ("?rebuild_phase_space"), .false., & intrinsic=.true.) call global%var_list%append_log (& var_str ("?rebuild_grids"), .false., & intrinsic=.true.) call global%init_fallback_model & (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl")) call global%var_list%set_string (var_str ("$method"), & var_str ("unit_test"), is_known=.true.) call global%var_list%set_string (var_str ("$phs_method"), & var_str ("single"), is_known=.true.) call global%var_list%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known=.true.) call global%var_list%set_log (var_str ("?vis_history"),& .false., is_known=.true.) call global%var_list%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%var_list%set_real (var_str ("sqrts"), & 1000._default, is_known=.true.) allocate (lib) call lib%init (var_str ("lib_cmd12")) call global%add_prclib (lib) write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'model = "Test"') call ifile_append (ifile, 'process commands_12_p = s, s => s, s') call ifile_append (ifile, 'compile') call ifile_append (ifile, 'iterations = 1:1000') call ifile_append (ifile, 'integrate (commands_12_p)') call ifile_append (ifile, '?unweighted = false') call ifile_append (ifile, 'n_events = 3') call ifile_append (ifile, '?read_raw = false') call ifile_append (ifile, 'simulate (commands_12_p)') call ifile_append (ifile, '?write_raw = false') call ifile_append (ifile, 'rescan "commands_12_p" (commands_12_p)') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" call command_list%execute (global) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_12" end subroutine commands_12 @ %def commands_12 @ \subsubsection{Event Files} Set output formats for event files. <>= call test (commands_13, "commands_13", & "event output formats", & u, results) <>= public :: commands_13 <>= subroutine commands_13 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root type(prclib_entry_t), pointer :: lib logical :: exist write (u, "(A)") "* Test output: commands_13" write (u, "(A)") "* Purpose: generate events and rescan" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call syntax_model_file_init () call global%global_init () call global%init_fallback_model & (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl")) call global%var_list%set_string (var_str ("$method"), & var_str ("unit_test"), is_known=.true.) call global%var_list%set_string (var_str ("$phs_method"), & var_str ("single"), is_known=.true.) call global%var_list%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known=.true.) call global%var_list%set_real (var_str ("sqrts"), & 1000._default, is_known=.true.) call global%var_list%set_log (var_str ("?vis_history"),& .false., is_known=.true.) call global%var_list%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) allocate (lib) call lib%init (var_str ("lib_cmd13")) call global%add_prclib (lib) write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'model = "Test"') call ifile_append (ifile, 'process commands_13_p = s, s => s, s') call ifile_append (ifile, 'compile') call ifile_append (ifile, 'iterations = 1:1000') call ifile_append (ifile, 'integrate (commands_13_p)') call ifile_append (ifile, '?unweighted = false') call ifile_append (ifile, 'n_events = 1') call ifile_append (ifile, '?read_raw = false') call ifile_append (ifile, 'sample_format = weight_stream') call ifile_append (ifile, 'simulate (commands_13_p)') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" call command_list%execute (global) write (u, "(A)") write (u, "(A)") "* Verify output files" write (u, "(A)") inquire (file = "commands_13_p.evx", exist = exist) if (exist) write (u, "(1x,A)") "raw" inquire (file = "commands_13_p.weights.dat", exist = exist) if (exist) write (u, "(1x,A)") "weight_stream" write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_13" end subroutine commands_13 @ %def commands_13 @ \subsubsection{Compile Empty Libraries} (This is a regression test:) Declare two empty libraries and compile them. <>= call test (commands_14, "commands_14", & "empty libraries", & u, results) <>= public :: commands_14 <>= subroutine commands_14 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_14" write (u, "(A)") "* Purpose: define and compile empty libraries" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_model_file_init () call syntax_cmd_list_init () call global%global_init () write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'model = "Test"') call ifile_append (ifile, 'library = "lib1"') call ifile_append (ifile, 'library = "lib2"') call ifile_append (ifile, 'compile ()') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) call global%prclib_stack%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_14" end subroutine commands_14 @ %def commands_14 @ \subsubsection{Compile Process} Read a model, then declare a process and compile the library. The process library is allocated explicitly. For the process definition, We take the default ([[unit_test]]) method. There is no external code, so compilation of the library is merely a formal status change. <>= call test (commands_15, "commands_15", & "compilation", & u, results) <>= public :: commands_15 <>= subroutine commands_15 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root type(prclib_entry_t), pointer :: lib write (u, "(A)") "* Test output: commands_15" write (u, "(A)") "* Purpose: define process and compile library" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call syntax_model_file_init () call global%global_init () call global%var_list%set_string (var_str ("$method"), & var_str ("unit_test"), is_known=.true.) call global%var_list%set_string (var_str ("$phs_method"), & var_str ("single"), is_known=.true.) call global%var_list%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known=.true.) call global%var_list%set_real (var_str ("sqrts"), & 1000._default, is_known=.true.) call global%var_list%set_log (var_str ("?vis_history"),& .false., is_known=.true.) call global%var_list%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) allocate (lib) call lib%init (var_str ("lib_cmd15")) call global%add_prclib (lib) write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'model = "Test"') call ifile_append (ifile, 'process t15 = s, s => s, s') call ifile_append (ifile, 'iterations = 1:1000') call ifile_append (ifile, 'integrate (t15)') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) call global%prclib_stack%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_15" end subroutine commands_15 @ %def commands_15 @ \subsubsection{Observable} Declare an observable, fill it and display. <>= call test (commands_16, "commands_16", & "observables", & u, results) <>= public :: commands_16 <>= subroutine commands_16 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_16" write (u, "(A)") "* Purpose: declare an observable" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, '$obs_label = "foo"') call ifile_append (ifile, '$obs_unit = "cm"') call ifile_append (ifile, '$title = "Observable foo"') call ifile_append (ifile, '$description = "This is observable foo"') call ifile_append (ifile, 'observable foo') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) write (u, "(A)") "* Record two data items" write (u, "(A)") call analysis_record_data (var_str ("foo"), 1._default) call analysis_record_data (var_str ("foo"), 3._default) write (u, "(A)") "* Display analysis store" write (u, "(A)") call analysis_write (u, verbose=.true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call analysis_final () call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_16" end subroutine commands_16 @ %def commands_16 @ \subsubsection{Histogram} Declare a histogram, fill it and display. <>= call test (commands_17, "commands_17", & "histograms", & u, results) <>= public :: commands_17 <>= subroutine commands_17 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root type(string_t), dimension(3) :: name integer :: i write (u, "(A)") "* Test output: commands_17" write (u, "(A)") "* Purpose: declare histograms" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, '$obs_label = "foo"') call ifile_append (ifile, '$obs_unit = "cm"') call ifile_append (ifile, '$title = "Histogram foo"') call ifile_append (ifile, '$description = "This is histogram foo"') call ifile_append (ifile, 'histogram foo (0,5,1)') call ifile_append (ifile, '$title = "Histogram bar"') call ifile_append (ifile, '$description = "This is histogram bar"') call ifile_append (ifile, 'n_bins = 2') call ifile_append (ifile, 'histogram bar (0,5)') call ifile_append (ifile, '$title = "Histogram gee"') call ifile_append (ifile, '$description = "This is histogram gee"') call ifile_append (ifile, '?normalize_bins = true') call ifile_append (ifile, 'histogram gee (0,5)') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) write (u, "(A)") "* Record two data items" write (u, "(A)") name(1) = "foo" name(2) = "bar" name(3) = "gee" do i = 1, 3 call analysis_record_data (name(i), 0.1_default, & weight = 0.25_default) call analysis_record_data (name(i), 3.1_default) call analysis_record_data (name(i), 4.1_default, & excess = 0.5_default) call analysis_record_data (name(i), 7.1_default) end do write (u, "(A)") "* Display analysis store" write (u, "(A)") call analysis_write (u, verbose=.true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call analysis_final () call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_17" end subroutine commands_17 @ %def commands_17 @ \subsubsection{Plot} Declare a plot, fill it and display contents. <>= call test (commands_18, "commands_18", & "plots", & u, results) <>= public :: commands_18 <>= subroutine commands_18 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_18" write (u, "(A)") "* Purpose: declare a plot" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, '$obs_label = "foo"') call ifile_append (ifile, '$obs_unit = "cm"') call ifile_append (ifile, '$title = "Plot foo"') call ifile_append (ifile, '$description = "This is plot foo"') call ifile_append (ifile, '$x_label = "x axis"') call ifile_append (ifile, '$y_label = "y axis"') call ifile_append (ifile, '?x_log = false') call ifile_append (ifile, '?y_log = true') call ifile_append (ifile, 'x_min = -1') call ifile_append (ifile, 'x_max = 1') call ifile_append (ifile, 'y_min = 0.1') call ifile_append (ifile, 'y_max = 1000') call ifile_append (ifile, 'plot foo') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) write (u, "(A)") "* Record two data items" write (u, "(A)") call analysis_record_data (var_str ("foo"), 0._default, 20._default, & xerr = 0.25_default) call analysis_record_data (var_str ("foo"), 0.5_default, 0.2_default, & yerr = 0.07_default) call analysis_record_data (var_str ("foo"), 3._default, 2._default) write (u, "(A)") "* Display analysis store" write (u, "(A)") call analysis_write (u, verbose=.true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call analysis_final () call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_18" end subroutine commands_18 @ %def commands_18 @ \subsubsection{Graph} Combine two (empty) plots to a graph. <>= call test (commands_19, "commands_19", & "graphs", & u, results) <>= public :: commands_19 <>= subroutine commands_19 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_19" write (u, "(A)") "* Purpose: combine two plots to a graph" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'plot a') call ifile_append (ifile, 'plot b') call ifile_append (ifile, '$title = "Graph foo"') call ifile_append (ifile, '$description = "This is graph foo"') call ifile_append (ifile, 'graph foo = a & b') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) write (u, "(A)") "* Display analysis object" write (u, "(A)") call analysis_write (var_str ("foo"), u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call analysis_final () call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_19" end subroutine commands_19 @ %def commands_19 @ \subsubsection{Record Data} Record data in previously allocated analysis objects. <>= call test (commands_20, "commands_20", & "record data", & u, results) <>= public :: commands_20 <>= subroutine commands_20 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_20" write (u, "(A)") "* Purpose: record data" write (u, "(A)") write (u, "(A)") "* Initialization: create observable, histogram, plot" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () call analysis_init_observable (var_str ("o")) call analysis_init_histogram (var_str ("h"), 0._default, 1._default, 3, & normalize_bins = .false.) call analysis_init_plot (var_str ("p")) write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'record o (1.234)') call ifile_append (ifile, 'record h (0.5)') call ifile_append (ifile, 'record p (1, 2)') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) write (u, "(A)") "* Display analysis object" write (u, "(A)") call analysis_write (u, verbose = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call analysis_final () call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_20" end subroutine commands_20 @ %def commands_20 @ \subsubsection{Analysis} Declare an analysis expression and use it to fill an observable during event generation. <>= call test (commands_21, "commands_21", & "analysis expression", & u, results) <>= public :: commands_21 <>= subroutine commands_21 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root type(prclib_entry_t), pointer :: lib write (u, "(A)") "* Test output: commands_21" write (u, "(A)") "* Purpose: create and use analysis expression" write (u, "(A)") write (u, "(A)") "* Initialization: create observable" write (u, "(A)") call syntax_cmd_list_init () call syntax_model_file_init () call global%global_init () call global%init_fallback_model & (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl")) call global%var_list%set_string (var_str ("$method"), & var_str ("unit_test"), is_known=.true.) call global%var_list%set_string (var_str ("$phs_method"), & var_str ("single"), is_known=.true.) call global%var_list%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known=.true.) call global%var_list%set_log (var_str ("?vis_history"),& .false., is_known=.true.) call global%var_list%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%var_list%set_real (var_str ("sqrts"), & 1000._default, is_known=.true.) allocate (lib) call lib%init (var_str ("lib_cmd8")) call global%add_prclib (lib) call analysis_init_observable (var_str ("m")) write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'model = "Test"') call ifile_append (ifile, 'process commands_21_p = s, s => s, s') call ifile_append (ifile, 'compile') call ifile_append (ifile, 'iterations = 1:100') call ifile_append (ifile, 'integrate (commands_21_p)') call ifile_append (ifile, '?unweighted = true') call ifile_append (ifile, 'n_events = 3') call ifile_append (ifile, '?read_raw = false') call ifile_append (ifile, 'observable m') call ifile_append (ifile, 'analysis = record m (eval M [s])') call ifile_append (ifile, 'simulate (commands_21_p)') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) write (u, "(A)") "* Display analysis object" write (u, "(A)") call analysis_write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call analysis_final () call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_21" end subroutine commands_21 @ %def commands_21 @ \subsubsection{Write Analysis} Write accumulated analysis data to file. <>= call test (commands_22, "commands_22", & "write analysis", & u, results) <>= public :: commands_22 <>= subroutine commands_22 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root integer :: u_file, iostat logical :: exist character(80) :: buffer write (u, "(A)") "* Test output: commands_22" write (u, "(A)") "* Purpose: write analysis data" write (u, "(A)") write (u, "(A)") "* Initialization: create observable" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () call analysis_init_observable (var_str ("m")) call analysis_record_data (var_str ("m"), 125._default) write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, '$out_file = "commands_22.dat"') call ifile_append (ifile, 'write_analysis') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) write (u, "(A)") "* Display analysis data" write (u, "(A)") inquire (file = "commands_22.dat", exist = exist) if (.not. exist) then write (u, "(A)") "ERROR: File commands_22.dat not found" return end if u_file = free_unit () open (u_file, file = "commands_22.dat", & action = "read", status = "old") do read (u_file, "(A)", iostat = iostat) buffer if (iostat /= 0) exit write (u, "(A)") trim (buffer) end do close (u_file) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call analysis_final () call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_22" end subroutine commands_22 @ %def commands_22 @ \subsubsection{Compile Analysis} Write accumulated analysis data to file and compile. <>= if (MPOST_AVAILABLE) then call test (commands_23, "commands_23", & "compile analysis", & u, results) end if <>= public :: commands_23 <>= subroutine commands_23 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root integer :: u_file, iostat character(256) :: buffer logical :: exist type(graph_options_t) :: graph_options write (u, "(A)") "* Test output: commands_23" write (u, "(A)") "* Purpose: write and compile analysis data" write (u, "(A)") write (u, "(A)") "* Initialization: create and fill histogram" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () call graph_options%init () call graph_options%set (title = var_str ("Histogram for test: commands 23"), & description = var_str ("This is a test."), & width_mm = 125, height_mm = 85) call analysis_init_histogram (var_str ("h"), & 0._default, 10._default, 2._default, .false., & graph_options = graph_options) call analysis_record_data (var_str ("h"), 1._default) call analysis_record_data (var_str ("h"), 1._default) call analysis_record_data (var_str ("h"), 1._default) call analysis_record_data (var_str ("h"), 1._default) call analysis_record_data (var_str ("h"), 3._default) call analysis_record_data (var_str ("h"), 3._default) call analysis_record_data (var_str ("h"), 3._default) call analysis_record_data (var_str ("h"), 5._default) call analysis_record_data (var_str ("h"), 7._default) call analysis_record_data (var_str ("h"), 7._default) call analysis_record_data (var_str ("h"), 7._default) call analysis_record_data (var_str ("h"), 7._default) call analysis_record_data (var_str ("h"), 9._default) call analysis_record_data (var_str ("h"), 9._default) call analysis_record_data (var_str ("h"), 9._default) call analysis_record_data (var_str ("h"), 9._default) call analysis_record_data (var_str ("h"), 9._default) call analysis_record_data (var_str ("h"), 9._default) call analysis_record_data (var_str ("h"), 9._default) write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, '$out_file = "commands_23.dat"') call ifile_append (ifile, 'compile_analysis') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Delete Postscript output" write (u, "(A)") inquire (file = "commands_23.ps", exist = exist) if (exist) then u_file = free_unit () open (u_file, file = "commands_23.ps", action = "write", status = "old") close (u_file, status = "delete") end if inquire (file = "commands_23.ps", exist = exist) write (u, "(1x,A,L1)") "Postcript output exists = ", exist write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) write (u, "(A)") "* TeX file" write (u, "(A)") inquire (file = "commands_23.tex", exist = exist) if (.not. exist) then write (u, "(A)") "ERROR: File commands_23.tex not found" return end if u_file = free_unit () open (u_file, file = "commands_23.tex", & action = "read", status = "old") do read (u_file, "(A)", iostat = iostat) buffer if (iostat /= 0) exit write (u, "(A)") trim (buffer) end do close (u_file) write (u, *) inquire (file = "commands_23.ps", exist = exist) write (u, "(1x,A,L1)") "Postcript output exists = ", exist write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call analysis_final () call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_23" end subroutine commands_23 @ %def commands_23 @ \subsubsection{Histogram} Declare a histogram, fill it and display. <>= call test (commands_24, "commands_24", & "drawing options", & u, results) <>= public :: commands_24 <>= subroutine commands_24 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_24" write (u, "(A)") "* Purpose: check graph and drawing options" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, '$title = "Title"') call ifile_append (ifile, '$description = "Description"') call ifile_append (ifile, '$x_label = "X Label"') call ifile_append (ifile, '$y_label = "Y Label"') call ifile_append (ifile, 'graph_width_mm = 111') call ifile_append (ifile, 'graph_height_mm = 222') call ifile_append (ifile, 'x_min = -11') call ifile_append (ifile, 'x_max = 22') call ifile_append (ifile, 'y_min = -33') call ifile_append (ifile, 'y_max = 44') call ifile_append (ifile, '$gmlcode_bg = "GML Code BG"') call ifile_append (ifile, '$gmlcode_fg = "GML Code FG"') call ifile_append (ifile, '$fill_options = "Fill Options"') call ifile_append (ifile, '$draw_options = "Draw Options"') call ifile_append (ifile, '$err_options = "Error Options"') call ifile_append (ifile, '$symbol = "Symbol"') call ifile_append (ifile, 'histogram foo (0,1)') call ifile_append (ifile, 'plot bar') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) write (u, "(A)") "* Display analysis store" write (u, "(A)") call analysis_write (u, verbose=.true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call analysis_final () call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_24" end subroutine commands_24 @ %def commands_24 @ \subsubsection{Local Environment} Declare a local environment. <>= call test (commands_25, "commands_25", & "local process environment", & u, results) <>= public :: commands_25 <>= subroutine commands_25 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_25" write (u, "(A)") "* Purpose: declare local environment for process" write (u, "(A)") call syntax_model_file_init () call syntax_cmd_list_init () call global%global_init () call global%var_list%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'library = "commands_25_lib"') call ifile_append (ifile, 'model = "Test"') call ifile_append (ifile, 'process commands_25_p1 = g, g => g, g & &{ model = "QCD" }') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) call global%write_libraries (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_25" end subroutine commands_25 @ %def commands_25 @ \subsubsection{Alternative Setups} Declare a list of alternative setups. <>= call test (commands_26, "commands_26", & "alternative setups", & u, results) <>= public :: commands_26 <>= subroutine commands_26 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_26" write (u, "(A)") "* Purpose: declare alternative setups for simulation" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'int i = 0') call ifile_append (ifile, 'alt_setup = ({ i = 1 }, { i = 2 })') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) call global%write_expr (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_26" end subroutine commands_26 @ %def commands_26 @ \subsubsection{Unstable Particle} Define decay processes and declare a particle as unstable. Also check the commands stable, polarized, unpolarized. <>= call test (commands_27, "commands_27", & "unstable and polarized particles", & u, results) <>= public :: commands_27 <>= subroutine commands_27 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root type(prclib_entry_t), pointer :: lib write (u, "(A)") "* Test output: commands_27" write (u, "(A)") "* Purpose: modify particle properties" write (u, "(A)") call syntax_cmd_list_init () call syntax_model_file_init () call global%global_init () call global%var_list%set_string (var_str ("$method"), & var_str ("unit_test"), is_known=.true.) call global%var_list%set_string (var_str ("$phs_method"), & var_str ("single"), is_known=.true.) call global%var_list%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known=.true.) call global%var_list%set_log (var_str ("?vis_history"),& .false., is_known=.true.) call global%var_list%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) allocate (lib) call lib%init (var_str ("commands_27_lib")) call global%add_prclib (lib) write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'model = "Test"') call ifile_append (ifile, 'ff = 0.4') call ifile_append (ifile, 'process d1 = s => f, fbar') call ifile_append (ifile, 'unstable s (d1)') call ifile_append (ifile, 'polarized f, fbar') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) write (u, "(A)") "* Show model" write (u, "(A)") call global%model%write (u) write (u, "(A)") write (u, "(A)") "* Extra Input" write (u, "(A)") call ifile_final (ifile) call ifile_append (ifile, '?diagonal_decay = true') call ifile_append (ifile, 'unstable s (d1)') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%final () call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) write (u, "(A)") "* Show model" write (u, "(A)") call global%model%write (u) write (u, "(A)") write (u, "(A)") "* Extra Input" write (u, "(A)") call ifile_final (ifile) call ifile_append (ifile, '?isotropic_decay = true') call ifile_append (ifile, 'unstable s (d1)') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%final () call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) write (u, "(A)") "* Show model" write (u, "(A)") call global%model%write (u) write (u, "(A)") write (u, "(A)") "* Extra Input" write (u, "(A)") call ifile_final (ifile) call ifile_append (ifile, 'stable s') call ifile_append (ifile, 'unpolarized f') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%final () call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) write (u, "(A)") "* Show model" write (u, "(A)") call global%model%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_model_file_init () call syntax_cmd_list_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_27" end subroutine commands_27 @ %def commands_27 @ \subsubsection{Quit the program} Quit the program. <>= call test (commands_28, "commands_28", & "quit", & u, results) <>= public :: commands_28 <>= subroutine commands_28 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root1, pn_root2 type(string_t), dimension(0) :: no_vars write (u, "(A)") "* Test output: commands_28" write (u, "(A)") "* Purpose: quit the program" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () write (u, "(A)") "* Input file: quit without code" write (u, "(A)") call ifile_append (ifile, 'quit') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root1, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root1, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) call global%write (u, vars = no_vars) write (u, "(A)") write (u, "(A)") "* Input file: quit with code" write (u, "(A)") call ifile_final (ifile) call command_list%final () call ifile_append (ifile, 'quit ( 3 + 4 )') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root2, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root2, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) call global%write (u, vars = no_vars) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_28" end subroutine commands_28 @ %def commands_28 @ \subsubsection{SLHA interface} Testing commands steering the SLHA interface. <>= call test (commands_29, "commands_29", & "SLHA interface", & u, results) <>= public :: commands_29 <>= subroutine commands_29 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(var_list_t), pointer :: model_vars type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_29" write (u, "(A)") "* Purpose: test SLHA interface" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call syntax_model_file_init () call syntax_slha_init () call global%global_init () write (u, "(A)") "* Model MSSM, read SLHA file" write (u, "(A)") call ifile_append (ifile, 'model = "MSSM"') call ifile_append (ifile, '?slha_read_decays = true') call ifile_append (ifile, 'read_slha ("sps1ap_decays.slha")') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Model MSSM, default values:" write (u, "(A)") call global%model%write (u, verbose = .false., & show_vertices = .false., show_particles = .false.) write (u, "(A)") write (u, "(A)") "* Selected global variables" write (u, "(A)") model_vars => global%model%get_var_list_ptr () call model_vars%write_var (var_str ("mch1"), u) call model_vars%write_var (var_str ("wch1"), u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) write (u, "(A)") "* Model MSSM, values from SLHA file" write (u, "(A)") call global%model%write (u, verbose = .false., & show_vertices = .false., show_particles = .false.) write (u, "(A)") write (u, "(A)") "* Selected global variables" write (u, "(A)") model_vars => global%model%get_var_list_ptr () call model_vars%write_var (var_str ("mch1"), u) call model_vars%write_var (var_str ("wch1"), u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_slha_final () call syntax_model_file_final () call syntax_cmd_list_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_29" end subroutine commands_29 @ %def commands_29 @ \subsubsection{Expressions for scales} Declare a scale, factorization scale or factorization scale expression. <>= call test (commands_30, "commands_30", & "scales", & u, results) <>= public :: commands_30 <>= subroutine commands_30 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_30" write (u, "(A)") "* Purpose: define scales" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'scale = 200 GeV') call ifile_append (ifile, & 'factorization_scale = eval Pt [particle]') call ifile_append (ifile, & 'renormalization_scale = eval E [particle]') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) call global%write_expr (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_30" end subroutine commands_30 @ %def commands_30 @ \subsubsection{Weight and reweight expressions} Declare an expression for event weights and reweighting. <>= call test (commands_31, "commands_31", & "event weights/reweighting", & u, results) <>= public :: commands_31 <>= subroutine commands_31 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_31" write (u, "(A)") "* Purpose: define weight/reweight" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'weight = eval Pz [particle]') call ifile_append (ifile, 'reweight = eval M2 [particle]') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) call global%write_expr (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_31" end subroutine commands_31 @ %def commands_31 @ \subsubsection{Selecting events} Declare an expression for selecting events in an analysis. <>= call test (commands_32, "commands_32", & "event selection", & u, results) <>= public :: commands_32 <>= subroutine commands_32 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_32" write (u, "(A)") "* Purpose: define selection" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'selection = any PDG == 13 [particle]') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) call global%write_expr (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_32" end subroutine commands_32 @ %def commands_32 @ \subsubsection{Executing shell commands} Execute a shell command. <>= call test (commands_33, "commands_33", & "execute shell command", & u, results) <>= public :: commands_33 <>= subroutine commands_33 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root integer :: u_file, iostat character(3) :: buffer write (u, "(A)") "* Test output: commands_33" write (u, "(A)") "* Purpose: execute shell command" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'exec ("echo foo >> bar")') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) u_file = free_unit () open (u_file, file = "bar", & action = "read", status = "old") do read (u_file, "(A)", iostat = iostat) buffer if (iostat /= 0) exit end do write (u, "(A,A)") "should be 'foo': ", trim (buffer) close (u_file) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_33" end subroutine commands_33 @ %def commands_33 @ \subsubsection{Callback} Instead of an explicit write, use the callback feature to write the analysis file during event generation. We generate 4 events and arrange that the callback is executed while writing the 3rd event. <>= call test (commands_34, "commands_34", & "analysis via callback", & u, results) <>= public :: commands_34 <>= subroutine commands_34 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root type(prclib_entry_t), pointer :: lib type(event_callback_34_t) :: event_callback write (u, "(A)") "* Test output: commands_34" write (u, "(A)") "* Purpose: write analysis data" write (u, "(A)") write (u, "(A)") "* Initialization: create observable" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () call syntax_model_file_init () call global%global_init () call global%init_fallback_model & (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl")) call global%var_list%set_string (var_str ("$method"), & var_str ("unit_test"), is_known=.true.) call global%var_list%set_string (var_str ("$phs_method"), & var_str ("single"), is_known=.true.) call global%var_list%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known=.true.) call global%var_list%set_real (var_str ("sqrts"), & 1000._default, is_known=.true.) call global%var_list%set_log (var_str ("?vis_history"),& .false., is_known=.true.) call global%var_list%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%var_list%set_int (var_str ("seed"), 0, is_known=.true.) allocate (lib) call lib%init (var_str ("lib_cmd34")) call global%add_prclib (lib) write (u, "(A)") "* Prepare callback for writing analysis to I/O unit" write (u, "(A)") event_callback%u = u call global%set_event_callback (event_callback) write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'model = "Test"') call ifile_append (ifile, 'process commands_34_p = s, s => s, s') call ifile_append (ifile, 'compile') call ifile_append (ifile, 'iterations = 1:1000') call ifile_append (ifile, 'integrate (commands_34_p)') call ifile_append (ifile, 'observable sq') call ifile_append (ifile, 'analysis = record sq (sqrts)') call ifile_append (ifile, 'n_events = 4') call ifile_append (ifile, 'event_callback_interval = 3') call ifile_append (ifile, 'simulate (commands_34_p)') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call analysis_final () call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_34" end subroutine commands_34 @ %def commands_34 @ For this test, we invent a callback object which simply writes the analysis file, using the standard call for this. Here we rely on the fact that the analysis data are stored as a global entity, otherwise we would have to access them via the event object. <>= type, extends (event_callback_t) :: event_callback_34_t private integer :: u = 0 contains procedure :: write => event_callback_34_write procedure :: proc => event_callback_34 end type event_callback_34_t @ %def event_callback_t @ The output routine is unused. The actual callback should write the analysis data to the output unit that we have injected into the callback object. <>= subroutine event_callback_34_write (event_callback, unit) class(event_callback_34_t), intent(in) :: event_callback integer, intent(in), optional :: unit end subroutine event_callback_34_write subroutine event_callback_34 (event_callback, i, event) class(event_callback_34_t), intent(in) :: event_callback integer(i64), intent(in) :: i class(generic_event_t), intent(in) :: event call analysis_write (event_callback%u) end subroutine event_callback_34 @ %def event_callback_34_write @ %def event_callback_34 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Toplevel module WHIZARD} <<[[whizard.f90]]>>= <> module whizard use io_units <> use system_defs, only: VERSION_STRING use system_defs, only: EOF, BACKSLASH use diagnostics use os_interface use ifiles use lexers use parser use eval_trees use models use phs_forests use prclib_stacks use slha_interface use blha_config use rt_data use commands <> <> <> <> save contains <> end module whizard @ %def whizard @ \subsection{Options} Here we introduce a wrapper that holds various user options, so they can transparently be passed from the main program to the [[whizard]] object. Most parameters are used for initializing the [[global]] state. <>= public :: whizard_options_t <>= type :: whizard_options_t type(string_t) :: job_id type(string_t), dimension(:), allocatable :: pack_args type(string_t), dimension(:), allocatable :: unpack_args type(string_t) :: preload_model type(string_t) :: default_lib type(string_t) :: preload_libraries logical :: rebuild_library = .false. logical :: recompile_library = .false. logical :: rebuild_phs = .false. logical :: rebuild_grids = .false. logical :: rebuild_events = .false. end type whizard_options_t @ %def whizard_options_t @ \subsection{Parse tree stack} We collect all parse trees that we generate in the [[whizard]] object. To this end, we create a stack of parse trees. They must not be finalized before the [[global]] object is finalized, because items such as a cut definition may contain references to the parse tree from which they were generated. <>= type, extends (parse_tree_t) :: pt_entry_t type(pt_entry_t), pointer :: previous => null () end type pt_entry_t @ %def pt_entry_t @ This is the stack. Since we always prepend, we just need the [[last]] pointer. <>= type :: pt_stack_t type(pt_entry_t), pointer :: last => null () contains <> end type pt_stack_t @ %def pt_stack_t @ The finalizer is called at the very end. <>= procedure :: final => pt_stack_final <>= subroutine pt_stack_final (pt_stack) class(pt_stack_t), intent(inout) :: pt_stack type(pt_entry_t), pointer :: current do while (associated (pt_stack%last)) current => pt_stack%last pt_stack%last => current%previous call parse_tree_final (current%parse_tree_t) deallocate (current) end do end subroutine pt_stack_final @ %def pt_stack_final @ Create and push a new entry, keeping the previous ones. <>= procedure :: push => pt_stack_push <>= subroutine pt_stack_push (pt_stack, parse_tree) class(pt_stack_t), intent(inout) :: pt_stack type(parse_tree_t), intent(out), pointer :: parse_tree type(pt_entry_t), pointer :: current allocate (current) parse_tree => current%parse_tree_t current%previous => pt_stack%last pt_stack%last => current end subroutine pt_stack_push @ %def pt_stack_push @ \subsection{The [[whizard]] object} An object of type [[whizard_t]] is the top-level wrapper for a \whizard\ instance. The object holds various default settings and the current state of the generator, the [[global]] object of type [[rt_data_t]]. This object contains, for instance, the list of variables and the process libraries. Since components of the [[global]] subobject are frequently used as targets, the [[whizard]] object should also consistently carry the [[target]] attribute. The various self-tests do no not use this object. They initialize only specific subsets of the system, according to their needs. Note: we intend to allow several concurrent instances. In the current implementation, there are still a few obstacles to this: the model library and the syntax tables are global variables, and the error handling uses global state. This should be improved. <>= public :: whizard_t <>= type :: whizard_t type(whizard_options_t) :: options type(rt_data_t) :: global type(pt_stack_t) :: pt_stack contains <> end type whizard_t @ %def whizard_t @ \subsection{Initialization and finalization} <>= procedure :: init => whizard_init <>= subroutine whizard_init (whizard, options, paths, logfile) class(whizard_t), intent(out), target :: whizard type(whizard_options_t), intent(in) :: options type(paths_t), intent(in), optional :: paths type(string_t), intent(in), optional :: logfile call init_syntax_tables () whizard%options = options call whizard%global%global_init (paths, logfile) call whizard%init_job_id () call whizard%init_rebuild_flags () call whizard%unpack_files () call whizard%preload_model () call whizard%preload_library () call whizard%global%init_fallback_model & (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl")) end subroutine whizard_init @ %def whizard_init @ Apart from the global data which have been initialized above, the process and model lists need to be finalized. <>= procedure :: final => whizard_final <>= subroutine whizard_final (whizard) class(whizard_t), intent(inout), target :: whizard call whizard%global%final () call whizard%pt_stack%final () call whizard%pack_files () call final_syntax_tables () end subroutine whizard_final @ %def whizard_final @ Set the job ID, if nonempty. If the ID string is empty, the value remains undefined. <>= procedure :: init_job_id => whizard_init_job_id <>= subroutine whizard_init_job_id (whizard) class(whizard_t), intent(inout), target :: whizard associate (var_list => whizard%global%var_list, options => whizard%options) if (options%job_id /= "") then call var_list%set_string (var_str ("$job_id"), & options%job_id, is_known=.true.) end if end associate end subroutine whizard_init_job_id @ %def whizard_init_job_id @ Set the rebuild flags. They can be specified on the command line and set the initial value for the associated logical variables. <>= procedure :: init_rebuild_flags => whizard_init_rebuild_flags <>= subroutine whizard_init_rebuild_flags (whizard) class(whizard_t), intent(inout), target :: whizard associate (var_list => whizard%global%var_list, options => whizard%options) call var_list%append_log (var_str ("?rebuild_library"), & options%rebuild_library, intrinsic=.true.) call var_list%append_log (var_str ("?recompile_library"), & options%recompile_library, intrinsic=.true.) call var_list%append_log (var_str ("?rebuild_phase_space"), & options%rebuild_phs, intrinsic=.true.) call var_list%append_log (var_str ("?rebuild_grids"), & options%rebuild_grids, intrinsic=.true.) call var_list%append_log (var_str ("?rebuild_events"), & options%rebuild_events, intrinsic=.true.) end associate end subroutine whizard_init_rebuild_flags @ %def whizard_init_rebuild_flags @ Pack/unpack files in the working directory, if requested. <>= procedure :: pack_files => whizard_pack_files procedure :: unpack_files => whizard_unpack_files <>= subroutine whizard_pack_files (whizard) class(whizard_t), intent(in), target :: whizard logical :: exist integer :: i type(string_t) :: file if (allocated (whizard%options%pack_args)) then do i = 1, size (whizard%options%pack_args) file = whizard%options%pack_args(i) call msg_message ("Packing file/dir '" // char (file) // "'") exist = os_file_exist (file) .or. os_dir_exist (file) if (exist) then call os_pack_file (whizard%options%pack_args(i), & whizard%global%os_data) else call msg_error ("File/dir '" // char (file) // "' not found") end if end do end if end subroutine whizard_pack_files subroutine whizard_unpack_files (whizard) class(whizard_t), intent(in), target :: whizard logical :: exist integer :: i type(string_t) :: file if (allocated (whizard%options%unpack_args)) then do i = 1, size (whizard%options%unpack_args) file = whizard%options%unpack_args(i) call msg_message ("Unpacking file '" // char (file) // "'") exist = os_file_exist (file) if (exist) then call os_unpack_file (whizard%options%unpack_args(i), & whizard%global%os_data) else call msg_error ("File '" // char (file) // "' not found") end if end do end if end subroutine whizard_unpack_files @ %def whizard_pack_files @ %def whizard_unpack_files @ This procedure preloads a model, if a model name is given. <>= procedure :: preload_model => whizard_preload_model <>= subroutine whizard_preload_model (whizard) class(whizard_t), intent(inout), target :: whizard type(string_t) :: model_name model_name = whizard%options%preload_model if (model_name /= "") then call whizard%global%read_model (model_name, whizard%global%preload_model) whizard%global%model => whizard%global%preload_model if (associated (whizard%global%model)) then call whizard%global%model%link_var_list (whizard%global%var_list) call whizard%global%var_list%set_string (var_str ("$model_name"), & model_name, is_known = .true.) call msg_message ("Preloaded model: " & // char (model_name)) else call msg_fatal ("Preloading model " // char (model_name) & // " failed") end if else call msg_message ("No model preloaded") end if end subroutine whizard_preload_model @ %def whizard_preload_model @ This procedure preloads a library, if a library name is given. Note: This version just opens a new library with that name. It does not load (yet) an existing library on file, as previous \whizard\ versions would do. <>= procedure :: preload_library => whizard_preload_library <>= subroutine whizard_preload_library (whizard) class(whizard_t), intent(inout), target :: whizard type(string_t) :: library_name, libs type(string_t), dimension(:), allocatable :: libname_static type(prclib_entry_t), pointer :: lib_entry integer :: i call get_prclib_static (libname_static) do i = 1, size (libname_static) allocate (lib_entry) call lib_entry%init_static (libname_static(i)) call whizard%global%add_prclib (lib_entry) end do libs = adjustl (whizard%options%preload_libraries) if (libs == "" .and. whizard%options%default_lib /= "") then allocate (lib_entry) call lib_entry%init (whizard%options%default_lib) call whizard%global%add_prclib (lib_entry) call msg_message ("Preloaded library: " // & char (whizard%options%default_lib)) end if SCAN_LIBS: do while (libs /= "") call split (libs, library_name, " ") if (library_name /= "") then allocate (lib_entry) call lib_entry%init (library_name) call whizard%global%add_prclib (lib_entry) call msg_message ("Preloaded library: " // char (library_name)) end if end do SCAN_LIBS end subroutine whizard_preload_library @ %def whizard_preload_library @ \subsection{Initialization and finalization: syntax tables} Initialize/finalize the syntax tables used by WHIZARD. These are effectively singleton objects. We introduce a module variable that tracks the initialization status. Without syntax tables, essentially nothing will work. Any initializer has to call this. <>= logical :: syntax_tables_exist = .false. @ %def syntax_tables_exist @ <>= public :: init_syntax_tables public :: final_syntax_tables <>= subroutine init_syntax_tables () if (.not. syntax_tables_exist) then call syntax_model_file_init () call syntax_phs_forest_init () call syntax_pexpr_init () call syntax_slha_init () call syntax_cmd_list_init () syntax_tables_exist = .true. end if end subroutine init_syntax_tables subroutine final_syntax_tables () if (syntax_tables_exist) then call syntax_model_file_final () call syntax_phs_forest_final () call syntax_pexpr_final () call syntax_slha_final () call syntax_cmd_list_final () syntax_tables_exist = .false. end if end subroutine final_syntax_tables @ %def init_syntax_tables @ %def final_syntax_tables @ Write the syntax tables to external files. <>= public :: write_syntax_tables <>= subroutine write_syntax_tables () integer :: unit character(*), parameter :: file_model = "whizard.model_file.syntax" character(*), parameter :: file_phs = "whizard.phase_space_file.syntax" character(*), parameter :: file_pexpr = "whizard.prt_expressions.syntax" character(*), parameter :: file_slha = "whizard.slha.syntax" character(*), parameter :: file_sindarin = "whizard.sindarin.syntax" if (.not. syntax_tables_exist) call init_syntax_tables () unit = free_unit () print *, "Writing file '" // file_model // "'" open (unit=unit, file=file_model, status="replace", action="write") write (unit, "(A)") VERSION_STRING write (unit, "(A)") "Syntax definition file: " // file_model call syntax_model_file_write (unit) close (unit) print *, "Writing file '" // file_phs // "'" open (unit=unit, file=file_phs, status="replace", action="write") write (unit, "(A)") VERSION_STRING write (unit, "(A)") "Syntax definition file: " // file_phs call syntax_phs_forest_write (unit) close (unit) print *, "Writing file '" // file_pexpr // "'" open (unit=unit, file=file_pexpr, status="replace", action="write") write (unit, "(A)") VERSION_STRING write (unit, "(A)") "Syntax definition file: " // file_pexpr call syntax_pexpr_write (unit) close (unit) print *, "Writing file '" // file_slha // "'" open (unit=unit, file=file_slha, status="replace", action="write") write (unit, "(A)") VERSION_STRING write (unit, "(A)") "Syntax definition file: " // file_slha call syntax_slha_write (unit) close (unit) print *, "Writing file '" // file_sindarin // "'" open (unit=unit, file=file_sindarin, status="replace", action="write") write (unit, "(A)") VERSION_STRING write (unit, "(A)") "Syntax definition file: " // file_sindarin call syntax_cmd_list_write (unit) close (unit) end subroutine write_syntax_tables @ %def write_syntax_tables @ \subsection{Execute command lists} Process commands given on the command line, stored as an [[ifile]]. The whole input is read, compiled and executed as a whole. <>= procedure :: process_ifile => whizard_process_ifile <>= subroutine whizard_process_ifile (whizard, ifile, quit, quit_code) class(whizard_t), intent(inout), target :: whizard type(ifile_t), intent(in) :: ifile logical, intent(out) :: quit integer, intent(out) :: quit_code type(lexer_t), target :: lexer type(stream_t), target :: stream call msg_message ("Reading commands given on the command line") call lexer_init_cmd_list (lexer) call stream_init (stream, ifile) call whizard%process_stream (stream, lexer, quit, quit_code) call stream_final (stream) call lexer_final (lexer) end subroutine whizard_process_ifile @ %def whizard_process_ifile @ Process standard input as a command list. The whole input is read, compiled and executed as a whole. <>= procedure :: process_stdin => whizard_process_stdin <>= subroutine whizard_process_stdin (whizard, quit, quit_code) class(whizard_t), intent(inout), target :: whizard logical, intent(out) :: quit integer, intent(out) :: quit_code type(lexer_t), target :: lexer type(stream_t), target :: stream call msg_message ("Reading commands from standard input") call lexer_init_cmd_list (lexer) call stream_init (stream, 5) call whizard%process_stream (stream, lexer, quit, quit_code) call stream_final (stream) call lexer_final (lexer) end subroutine whizard_process_stdin @ %def whizard_process_stdin @ Process a file as a command list. <>= procedure :: process_file => whizard_process_file <>= subroutine whizard_process_file (whizard, file, quit, quit_code) class(whizard_t), intent(inout), target :: whizard type(string_t), intent(in) :: file logical, intent(out) :: quit integer, intent(out) :: quit_code type(lexer_t), target :: lexer type(stream_t), target :: stream logical :: exist call msg_message ("Reading commands from file '" // char (file) // "'") inquire (file=char(file), exist=exist) if (exist) then call lexer_init_cmd_list (lexer) call stream_init (stream, char (file)) call whizard%process_stream (stream, lexer, quit, quit_code) call stream_final (stream) call lexer_final (lexer) else call msg_error ("File '" // char (file) // "' not found") end if end subroutine whizard_process_file @ %def whizard_process_file @ <>= procedure :: process_stream => whizard_process_stream <>= subroutine whizard_process_stream (whizard, stream, lexer, quit, quit_code) class(whizard_t), intent(inout), target :: whizard type(stream_t), intent(inout), target :: stream type(lexer_t), intent(inout), target :: lexer logical, intent(out) :: quit integer, intent(out) :: quit_code type(parse_tree_t), pointer :: parse_tree type(command_list_t), target :: command_list call lexer_assign_stream (lexer, stream) call whizard%pt_stack%push (parse_tree) call parse_tree_init (parse_tree, syntax_cmd_list, lexer) if (associated (parse_tree%get_root_ptr ())) then whizard%global%lexer => lexer call command_list%compile (parse_tree%get_root_ptr (), & whizard%global) end if call whizard%global%activate () call command_list%execute (whizard%global) call command_list%final () quit = whizard%global%quit quit_code = whizard%global%quit_code end subroutine whizard_process_stream @ %def whizard_process_stream @ \subsection{The WHIZARD shell} This procedure implements interactive mode. One line is processed at a time. <>= procedure :: shell => whizard_shell <>= subroutine whizard_shell (whizard, quit_code) class(whizard_t), intent(inout), target :: whizard integer, intent(out) :: quit_code type(lexer_t), target :: lexer type(stream_t), target :: stream type(string_t) :: prompt1 type(string_t) :: prompt2 type(string_t) :: input type(string_t) :: extra integer :: last integer :: iostat logical :: mask_tmp logical :: quit call msg_message ("Launching interactive shell") call lexer_init_cmd_list (lexer) prompt1 = "whish? " prompt2 = " > " COMMAND_LOOP: do call put (6, prompt1) call get (5, input, iostat=iostat) if (iostat > 0 .or. iostat == EOF) exit COMMAND_LOOP CONTINUE_INPUT: do last = len_trim (input) if (extract (input, last, last) /= BACKSLASH) exit CONTINUE_INPUT call put (6, prompt2) call get (5, extra, iostat=iostat) if (iostat > 0) exit COMMAND_LOOP input = replace (input, last, extra) end do CONTINUE_INPUT call stream_init (stream, input) mask_tmp = mask_fatal_errors mask_fatal_errors = .true. call whizard%process_stream (stream, lexer, quit, quit_code) msg_count = 0 mask_fatal_errors = mask_tmp call stream_final (stream) if (quit) exit COMMAND_LOOP end do COMMAND_LOOP print * call lexer_final (lexer) end subroutine whizard_shell @ %def whizard_shell @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Query Feature Support} This module accesses the various optional features (modules) that WHIZARD can support and repors on their availability. <<[[features.f90]]>>= module features use string_utils, only: lower_case use system_dependencies, only: WHIZARD_VERSION <> <> <> contains <> end module features @ %def features @ \subsection{Output} <>= public :: print_features <>= subroutine print_features () print "(A)", "WHIZARD " // WHIZARD_VERSION print "(A)", "Build configuration:" <> print "(A)", "Optional features available in this build:" <> end subroutine print_features @ %def print_features @ \subsection{Query function} <>= subroutine check (feature, recognized, result, help) character(*), intent(in) :: feature logical, intent(out) :: recognized character(*), intent(out) :: result, help recognized = .true. result = "no" select case (lower_case (trim (feature))) <> case default recognized = .false. end select end subroutine check @ %def check @ Print this result: <>= subroutine print_check (feature) character(*), intent(in) :: feature character(16) :: f logical :: recognized character(10) :: result character(48) :: help call check (feature, recognized, result, help) if (.not. recognized) then result = "unknown" help = "" end if f = feature print "(2x,A,1x,A,'(',A,')')", f, result, trim (help) end subroutine print_check @ %def print_check @ \subsection{Basic configuration} <>= call print_check ("precision") <>= use kinds, only: default <>= case ("precision") write (result, "(I0)") precision (1._default) help = "significant decimals of real/complex numbers" @ \subsection{Optional features case by case} <>= call print_check ("OpenMP") <>= use system_dependencies, only: openmp_is_active <>= case ("openmp") if (openmp_is_active ()) then result = "yes" end if help = "OpenMP parallel execution" @ <>= call print_check ("GoSam") <>= use system_dependencies, only: GOSAM_AVAILABLE <>= case ("gosam") if (GOSAM_AVAILABLE) then result = "yes" end if help = "external NLO matrix element provider" @ <>= call print_check ("OpenLoops") <>= use system_dependencies, only: OPENLOOPS_AVAILABLE <>= case ("openloops") if (OPENLOOPS_AVAILABLE) then result = "yes" end if help = "external NLO matrix element provider" @ <>= call print_check ("Recola") <>= use system_dependencies, only: RECOLA_AVAILABLE <>= case ("recola") if (RECOLA_AVAILABLE) then result = "yes" end if help = "external NLO matrix element provider" @ <>= call print_check ("LHAPDF") <>= use system_dependencies, only: LHAPDF5_AVAILABLE use system_dependencies, only: LHAPDF6_AVAILABLE <>= case ("lhapdf") if (LHAPDF5_AVAILABLE) then result = "v5" else if (LHAPDF6_AVAILABLE) then result = "v6" end if help = "PDF library" @ <>= call print_check ("HOPPET") <>= use system_dependencies, only: HOPPET_AVAILABLE <>= case ("hoppet") if (HOPPET_AVAILABLE) then result = "yes" end if help = "PDF evolution package" @ <>= call print_check ("fastjet") <>= use jets, only: fastjet_available <>= case ("fastjet") if (fastjet_available ()) then result = "yes" end if help = "jet-clustering package" @ <>= call print_check ("Pythia6") <>= use system_dependencies, only: PYTHIA6_AVAILABLE <>= case ("pythia6") if (PYTHIA6_AVAILABLE) then result = "yes" end if help = "direct access for shower/hadronization" @ <>= call print_check ("Pythia8") <>= use system_dependencies, only: PYTHIA8_AVAILABLE <>= case ("pythia8") if (PYTHIA8_AVAILABLE) then result = "yes" end if help = "direct access for shower/hadronization" @ <>= call print_check ("StdHEP") <>= case ("stdhep") result = "yes" help = "event I/O format" @ <>= call print_check ("HepMC") <>= use hepmc_interface, only: hepmc_is_available <>= case ("hepmc") if (hepmc_is_available ()) then result = "yes" end if help = "event I/O format" @ <>= call print_check ("LCIO") <>= use lcio_interface, only: lcio_is_available <>= case ("lcio") if (lcio_is_available ()) then result = "yes" end if help = "event I/O format" @ <>= call print_check ("MetaPost") <>= use system_dependencies, only: EVENT_ANALYSIS <>= case ("metapost") result = EVENT_ANALYSIS help = "graphical event analysis via LaTeX/MetaPost" @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Index: trunk/src/transforms/transforms.nw =================================================================== --- trunk/src/transforms/transforms.nw (revision 8782) +++ trunk/src/transforms/transforms.nw (revision 8783) @@ -1,14495 +1,14495 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD event transforms and event API %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Event Implementation} \includemodulegraph{transforms} With a process object and the associated methods at hand, we can generate events for elementary processes and, by subsequent transformation, for complete physical processes. We have the following modules: \begin{description} \item[event\_transforms] Abstract base type for transforming a physical process with process instance and included evaluators, etc., into a new object. The following modules extend this base type. \item[resonance\_insertion] Insert a resonance history into an event record, based on kinematical and matrix-element information. \item[recoil\_kinematics] Common kinematics routines for the ISR and EPA handlers. \item[isr\_photon\_handler] Transform collinear kinematics, as it results from applying ISR radiation, to non-collinear kinematics with a reasonable transverse-momentum distribution of the radiated photons, and also of the recoiling partonic event. \item[epa\_beam\_handler] For photon-initiated processes where the effective photon approximation is used in integration, to add in beam-particle recoil. Analogous to the ISR handler. \item[decays] Combine the elementary process with elementary decay processes and thus transform the elementary event into a decayed event, still at the parton level. \item[showers] Create QED/QCD showers out of the partons that are emitted by elementary processes. This should be interleaved with showering of radiated particles (structure functions) and multiple interactions. \item[hadrons] (not implemented yet) Apply hadronization to the partonic events, interleaved with hadron decays. (The current setup relies on hadronizing partonic events externally.) \item[tau\_decays] (not implemented yet) Let $\tau$ leptons decay taking full spin correlations into account. \item[evt\_nlo] Handler for fixed-order NLO events. \item[events] Combine all pieces to generate full events. \item[eio\_raw] Raw I/O for complete events. \end{description} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Abstract Event Transforms} <<[[event_transforms.f90]]>>= <> module event_transforms <> <> use io_units use format_utils, only: write_separator use diagnostics use model_data use interactions use particles use subevents use rng_base use quantum_numbers, only: quantum_numbers_t use process, only: process_t use instances, only: process_instance_t use process_stacks <> <> <> <> contains <> end module event_transforms @ %def event_transforms @ \subsection{Abstract base type} Essentially, all methods are abstract, but some get minimal base versions. We know that there will be a random-number generator at top level, and that we will relate to an elementary process. The model is stored separately. It may contain modified settings that differ from the model instance stored in the process object. Each event transform contains a particle set that it can fill for further use. There is a flag that indicates this. We will collect event transforms in a list, therefore we include [[previous]] and [[next]] pointers. <>= public :: evt_t <>= type, abstract :: evt_t type(process_t), pointer :: process => null () type(process_instance_t), pointer :: process_instance => null () class(model_data_t), pointer :: model => null () class(rng_t), allocatable :: rng integer :: rejection_count = 0 logical :: particle_set_exists = .false. type(particle_set_t) :: particle_set class(evt_t), pointer :: previous => null () class(evt_t), pointer :: next => null () logical :: only_weighted_events = .false. contains <> end type evt_t @ %def evt_t @ Finalizer. In any case, we finalize the r.n.g. The process instance is a pointer and should not be finalized here. <>= procedure :: final => evt_final procedure :: base_final => evt_final <>= subroutine evt_final (evt) class(evt_t), intent(inout) :: evt if (allocated (evt%rng)) call evt%rng%final () if (evt%particle_set_exists) & call evt%particle_set%final () end subroutine evt_final @ %def evt_final @ Print out the type of the [[evt]]. <>= procedure (evt_write_name), deferred :: write_name <>= abstract interface subroutine evt_write_name (evt, unit) import class(evt_t), intent(in) :: evt integer, intent(in), optional :: unit end subroutine evt_write_name end interface @ %def evt_write_name @ <>= procedure (evt_write), deferred :: write <>= abstract interface subroutine evt_write (evt, unit, verbose, more_verbose, testflag) import class(evt_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, more_verbose, testflag end subroutine evt_write end interface @ %def evt_write @ Output. We can print r.n.g. info. <>= procedure :: base_write => evt_base_write <>= subroutine evt_base_write (evt, unit, testflag, show_set) class(evt_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: testflag, show_set integer :: u logical :: show u = given_output_unit (unit) show = .true.; if (present (show_set)) show = show_set if (associated (evt%process)) then write (u, "(3x,A,A,A)") "Associated process: '", & char (evt%process%get_id ()), "'" end if if (allocated (evt%rng)) then call evt%rng%write (u, 1) write (u, "(3x,A,I0)") "Number of tries = ", evt%rejection_count end if if (show) then if (evt%particle_set_exists) then call write_separator (u) call evt%particle_set%write (u, testflag = testflag) end if end if end subroutine evt_base_write @ %def evt_base_write @ Connect the transform with a process instance (and thus with the associated process). Use this to allocate the master random-number generator. This is not an initializer; we may initialize the transform by implementation-specific methods. <>= procedure :: connect => evt_connect procedure :: base_connect => evt_connect <>= subroutine evt_connect (evt, process_instance, model, process_stack) class(evt_t), intent(inout), target :: evt type(process_instance_t), intent(in), target :: process_instance class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack evt%process => process_instance%process evt%process_instance => process_instance evt%model => model call evt%process%make_rng (evt%rng) end subroutine evt_connect @ %def evt_connect @ Reset internal state. <>= procedure :: reset => evt_reset procedure :: base_reset => evt_reset <>= subroutine evt_reset (evt) class(evt_t), intent(inout) :: evt evt%rejection_count = 0 call evt%particle_set%final () evt%particle_set_exists = .false. end subroutine evt_reset @ %def evt_reset @ Prepare for a new event: reset internal state, if necessary. We provide MCI and term index of the parent process. <>= procedure (evt_prepare_new_event), deferred :: prepare_new_event <>= interface subroutine evt_prepare_new_event (evt, i_mci, i_term) import class(evt_t), intent(inout) :: evt integer, intent(in) :: i_mci, i_term end subroutine evt_prepare_new_event end interface @ %def evt_prepare_new_event @ Generate a weighted event, using a valid initiator event in the process instance, and the random-number generator. The returned event probability should be a number between zero and one that we can use for rejection. <>= procedure (evt_generate_weighted), deferred :: generate_weighted <>= abstract interface subroutine evt_generate_weighted (evt, probability) import class(evt_t), intent(inout) :: evt real(default), intent(inout) :: probability end subroutine evt_generate_weighted end interface @ %def evt_generate_weighted @ The unweighted event generation routine is actually implemented. It uses the random-number generator for simple rejection. Of course, the implementation may override this and implement a different way of generating an unweighted event. <>= procedure :: generate_unweighted => evt_generate_unweighted procedure :: base_generate_unweighted => evt_generate_unweighted <>= subroutine evt_generate_unweighted (evt) class(evt_t), intent(inout) :: evt real(default) :: p, x evt%rejection_count = 0 REJECTION: do evt%rejection_count = evt%rejection_count + 1 call evt%generate_weighted (p) if (signal_is_pending ()) return call evt%rng%generate (x) if (x < p) exit REJECTION end do REJECTION end subroutine evt_generate_unweighted @ %def evt_generate_unweighted @ Make a particle set. This should take the most recent evaluator (or whatever stores the event), factorize the density matrix if necessary, and store as a particle set. If applicable, the factorization should make use of the [[factorization_mode]] and [[keep_correlations]] settings. The values [[r]], if set, should control the factorization in more detail, e.g., bypassing the random-number generator. <>= procedure (evt_make_particle_set), deferred :: make_particle_set <>= interface subroutine evt_make_particle_set & (evt, factorization_mode, keep_correlations, r) import class(evt_t), intent(inout) :: evt integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r end subroutine evt_make_particle_set end interface @ %def evt_make_particle_set @ Copy an existing particle set into the event record. This bypasses all methods to evaluate the internal state, but may be sufficient for further processing. <>= procedure :: set_particle_set => evt_set_particle_set <>= subroutine evt_set_particle_set (evt, particle_set, i_mci, i_term) class(evt_t), intent(inout) :: evt type(particle_set_t), intent(in) :: particle_set integer, intent(in) :: i_term, i_mci call evt%prepare_new_event (i_mci, i_term) evt%particle_set = particle_set evt%particle_set_exists = .true. end subroutine evt_set_particle_set @ %def evt_set_particle_set @ This procedure can help in the previous task, if the particles are available in the form of an interaction object. We need two interactions, one with color summed over, the [[int_matrix]], and one with the probability distributed among flows, the [[int_flows]]. We use the two values from the random number generator saved in [[r]] for factorizing the state. For testing purposes, we can provide those numbers explicitly. The optional [[qn_select]] allows to limit the number of quantum numbers to choose from when factorizing. If only a single set of quantum numbers is given, it effectively dictates the quantum numbers chosen for the event. <>= procedure :: factorize_interactions => evt_factorize_interactions <>= subroutine evt_factorize_interactions & (evt, int_matrix, int_flows, factorization_mode, & keep_correlations, r, qn_select) class(evt_t), intent(inout) :: evt type(interaction_t), intent(in), target :: int_matrix, int_flows integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_select real(default), dimension(2) :: x if (present (r)) then if (size (r) == 2) then x = r else call msg_bug ("event factorization: size of r array must be 2") end if else call evt%rng%generate (x) end if call evt%particle_set%init (evt%particle_set_exists, & int_matrix, int_flows, factorization_mode, x, & keep_correlations, keep_virtual=.true., qn_select = qn_select) evt%particle_set_exists = .true. end subroutine evt_factorize_interactions @ %def evt_factorize_interactions @ <>= public :: make_factorized_particle_set <>= subroutine make_factorized_particle_set (evt, factorization_mode, & keep_correlations, r, ii_term, qn_select) class(evt_t), intent(inout) :: evt integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r integer, intent(in), optional :: ii_term type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_select integer :: i_term type(interaction_t), pointer :: int_matrix, int_flows if (evt%process_instance%is_complete_event ()) then if (present (ii_term)) then i_term = ii_term else i_term = evt%process_instance%select_i_term () end if int_matrix => evt%process_instance%get_matrix_int_ptr (i_term) int_flows => evt%process_instance%get_flows_int_ptr (i_term) call evt%factorize_interactions (int_matrix, int_flows, & factorization_mode, keep_correlations, r, qn_select) call evt%tag_incoming () else call msg_bug ("Event factorization: event is incomplete") end if end subroutine make_factorized_particle_set @ %def make_factorized_particle_set @ Mark the incoming particles as incoming in the particle set. This is necessary because in the interaction objects they are usually marked as virtual. In the inquiry functions we set the term index to one; the indices of beams and incoming particles should be identical for all process terms. We use the initial elementary process for obtaining the indices. Thus, we implicitly assume that the beam and incoming indices stay the same across event transforms. If this is not true for a transform (say, MPI), it should override this method. <>= procedure :: tag_incoming => evt_tag_incoming <>= subroutine evt_tag_incoming (evt) class(evt_t), intent(inout) :: evt integer :: i_term, n_in integer, dimension(:), allocatable :: beam_index, in_index n_in = evt%process%get_n_in () i_term = 1 allocate (beam_index (n_in)) call evt%process_instance%get_beam_index (i_term, beam_index) call evt%particle_set%reset_status (beam_index, PRT_BEAM) allocate (in_index (n_in)) call evt%process_instance%get_in_index (i_term, in_index) call evt%particle_set%reset_status (in_index, PRT_INCOMING) end subroutine evt_tag_incoming @ %def evt_tag_incoming @ \subsection{Implementation: Trivial transform} This transform contains just a pointer to process and process instance. The [[generate]] methods do nothing. <>= public :: evt_trivial_t <>= type, extends (evt_t) :: evt_trivial_t contains <> end type evt_trivial_t @ %def evt_trivial_t @ <>= procedure :: write_name => evt_trivial_write_name <>= subroutine evt_trivial_write_name (evt, unit) class(evt_trivial_t), intent(in) :: evt integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Event transform: trivial (hard process)" end subroutine evt_trivial_write_name @ %def evt_trivial_write_name @ The finalizer is trivial. Some output: <>= procedure :: write => evt_trivial_write <>= subroutine evt_trivial_write (evt, unit, verbose, more_verbose, testflag) class(evt_trivial_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, more_verbose, testflag integer :: u u = given_output_unit (unit) call write_separator (u, 2) call evt%write_name (u) call write_separator (u) call evt%base_write (u, testflag = testflag) !!! More readable but wider output; in line with evt_resonance_write ! if (verbose .and. evt%particle_set_exists) then ! call evt%particle_set%write & ! (u, summary = .true., compressed = .true., testflag = testflag) ! call write_separator (u) ! end if end subroutine evt_trivial_write @ %def evt_trivial_write @ Nothing to do here: <>= procedure :: prepare_new_event => evt_trivial_prepare_new_event <>= subroutine evt_trivial_prepare_new_event (evt, i_mci, i_term) class(evt_trivial_t), intent(inout) :: evt integer, intent(in) :: i_mci, i_term call evt%reset () end subroutine evt_trivial_prepare_new_event @ %def evt_trivial_prepare_new_event @ The weighted generator is, surprisingly, trivial. <>= procedure :: generate_weighted => evt_trivial_generate_weighted <>= subroutine evt_trivial_generate_weighted (evt, probability) class(evt_trivial_t), intent(inout) :: evt real(default), intent(inout) :: probability probability = 1 end subroutine evt_trivial_generate_weighted @ %def evt_trivial_generate_weighted @ This routine makes a particle set, using the associated process instance as-is. Note that it is a potential risk to tolerate a non-existent particle set at this point. We should remove it once the flavors are determined correctly in all cases. It is currently neccessary if we are keeping failed events [[?keep_failed_events = .true.]]. For these events, we do not compute the matrix elements, so the factorization fails trying to determine the quantum numbers. Additionally, it is necessary for the trivial event transformation preceeding the event transformations required for POWHEG matching. <>= procedure :: make_particle_set => evt_trivial_make_particle_set <>= subroutine evt_trivial_make_particle_set & (evt, factorization_mode, keep_correlations, r) class(evt_trivial_t), intent(inout) :: evt integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r call make_factorized_particle_set (evt, factorization_mode, & keep_correlations, r) evt%particle_set_exists = .true. end subroutine evt_trivial_make_particle_set @ %def event_trivial_make_particle_set @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[event_transforms_ut.f90]]>>= <> module event_transforms_ut use unit_tests use event_transforms_uti <> <> contains <> end module event_transforms_ut @ %def event_transforms_ut @ <<[[event_transforms_uti.f90]]>>= <> module event_transforms_uti <> <> use format_utils, only: write_separator use os_interface use sm_qcd use models use state_matrices, only: FM_IGNORE_HELICITY use interactions, only: reset_interaction_counter use process_libraries use rng_base use mci_base use mci_midpoint use phs_base use phs_single use prc_core use prc_test, only: prc_test_create_library use process, only: process_t use instances, only: process_instance_t use event_transforms use rng_base_ut, only: rng_test_factory_t <> <> contains <> <> end module event_transforms_uti @ %def event_transforms_uti @ API: driver for the unit tests below. <>= public :: event_transforms_test <>= subroutine event_transforms_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine event_transforms_test @ %def event_transforms_test @ \subsubsection{Test trivial event transform} The trivial transform, as an instance of the abstract transform, does nothing but to trigger event generation for an elementary process. <>= call test (event_transforms_1, "event_transforms_1", & "trivial event transform", & u, results) <>= public :: event_transforms_1 <>= subroutine event_transforms_1 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_t), target :: model type(process_library_t), target :: lib type(string_t) :: libname, procname1 class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts type(process_t), allocatable, target :: process type(process_instance_t), allocatable, target :: process_instance class(evt_t), allocatable :: evt integer :: factorization_mode logical :: keep_correlations write (u, "(A)") "* Test output: event_transforms_1" write (u, "(A)") "* Purpose: handle trivial transform" write (u, "(A)") write (u, "(A)") "* Initialize environment and parent process" write (u, "(A)") call os_data%init () libname = "event_transforms_1_lib" procname1 = "event_transforms_1_p" call prc_test_create_library (libname, lib, & scattering = .true., procname1 = procname1) call reset_interaction_counter () call model%init_test () allocate (process) call process%init (procname1, lib, os_data, model) call process%setup_test_cores () allocate (phs_single_config_t :: phs_config_template) call process%init_components (phs_config_template) sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_test_midpoint) call process%setup_terms () allocate (process_instance) call process_instance%init (process) call process_instance%integrate (1, n_it=1, n_calls=100) call process%final_integration (1) call process_instance%final () deallocate (process_instance) allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data () call process_instance%init_simulation (1) write (u, "(A)") "* Initialize trivial event transform" write (u, "(A)") allocate (evt_trivial_t :: evt) call evt%connect (process_instance, process%get_model_ptr ()) write (u, "(A)") "* Generate event and subsequent transform" write (u, "(A)") call process_instance%generate_unweighted_event (1) call process_instance%evaluate_event_data () call evt%prepare_new_event (1, 1) call evt%generate_unweighted () call write_separator (u, 2) call evt%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Obtain particle set" write (u, "(A)") factorization_mode = FM_IGNORE_HELICITY keep_correlations = .false. call evt%make_particle_set (factorization_mode, keep_correlations) call write_separator (u, 2) call evt%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Cleanup" call evt%final () call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Test output end: event_transforms_1" end subroutine event_transforms_1 @ %def event_transforms_1 @ MCI record prepared for midpoint integrator. <>= subroutine dispatch_mci_test_midpoint (mci, var_list, process_id, is_nlo) use variables, only: var_list_t class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo allocate (mci_midpoint_t :: mci) end subroutine dispatch_mci_test_midpoint @ %def dispatch_mci_test_midpoint @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Hadronization interface} <<[[hadrons.f90]]>>= <> module hadrons <> <> <> use constants use diagnostics use event_transforms use format_utils, only: write_separator use helicities use hep_common use io_units use lorentz use model_data use models use numeric_utils, only: vanishes use particles use physics_defs use process, only: process_t use instances, only: process_instance_t use process_stacks use pythia8 use rng_base, only: rng_t use shower_base use shower_pythia6 use sm_qcd use subevents use variables use whizard_lha <> <> <> <> <> contains <> end module hadrons @ %def hadrons @ \subsection{Hadronization implementations} <>= public :: HADRONS_UNDEFINED, HADRONS_WHIZARD, HADRONS_PYTHIA6, HADRONS_PYTHIA8 <>= integer, parameter :: HADRONS_UNDEFINED = 0 integer, parameter :: HADRONS_WHIZARD = 1 integer, parameter :: HADRONS_PYTHIA6 = 2 integer, parameter :: HADRONS_PYTHIA8 = 3 @ %def HADRONS_UNDEFINED HADRONS_WHIZARD HADRONS_PYTHIA6 HADRONS_PYTHIA8 @ A dictionary <>= public :: hadrons_method <>= interface hadrons_method module procedure hadrons_method_of_string module procedure hadrons_method_to_string end interface <>= elemental function hadrons_method_of_string (string) result (i) integer :: i type(string_t), intent(in) :: string select case (char(string)) case ("WHIZARD") i = HADRONS_WHIZARD case ("PYTHIA6") i = HADRONS_PYTHIA6 case ("PYTHIA8") i = HADRONS_PYTHIA8 case default i = HADRONS_UNDEFINED end select end function hadrons_method_of_string elemental function hadrons_method_to_string (i) result (string) type(string_t) :: string integer, intent(in) :: i select case (i) case (HADRONS_WHIZARD) string = "WHIZARD" case (HADRONS_PYTHIA6) string = "PYTHIA6" case (HADRONS_PYTHIA8) string = "PYTHIA8" case default string = "UNDEFINED" end select end function hadrons_method_to_string @ %def hadrons_method @ \subsection{Hadronization settings} These are the general settings and parameters for the different shower methods. <>= public :: hadron_settings_t <>= type :: hadron_settings_t logical :: active = .false. integer :: method = HADRONS_UNDEFINED real(default) :: enhanced_fraction = 0 real(default) :: enhanced_width = 0 contains <> end type hadron_settings_t @ %def hadron_settings_t @ Read in the hadronization settings. <>= procedure :: init => hadron_settings_init <>= subroutine hadron_settings_init (hadron_settings, var_list) class(hadron_settings_t), intent(out) :: hadron_settings type(var_list_t), intent(in) :: var_list hadron_settings%active = & var_list%get_lval (var_str ("?hadronization_active")) hadron_settings%method = hadrons_method_of_string ( & var_list%get_sval (var_str ("$hadronization_method"))) hadron_settings%enhanced_fraction = & var_list%get_rval (var_str ("hadron_enhanced_fraction")) hadron_settings%enhanced_width = & var_list%get_rval (var_str ("hadron_enhanced_width")) end subroutine hadron_settings_init @ %def hadron_settings_init @ <>= procedure :: write => hadron_settings_write <>= subroutine hadron_settings_write (settings, unit) class(hadron_settings_t), intent(in) :: settings integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "Hadronization settings:" call write_separator (u) write (u, "(1x,A)") "Master switches:" write (u, "(3x,A,1x,L1)") & "active = ", settings%active write (u, "(1x,A)") "General settings:" if (settings%active) then write (u, "(3x,A)") & "hadron_method = " // & char (hadrons_method_to_string (settings%method)) else write (u, "(3x,A)") " [Hadronization off]" end if write (u, "(1x,A)") "pT generation parameters" write (u, "(3x,A,1x,ES19.12)") & "enhanced_fraction = ", settings%enhanced_fraction write (u, "(3x,A,1x,ES19.12)") & "enhanced_width = ", settings%enhanced_width end subroutine hadron_settings_write @ %def hadron_settings_write @ \subsection{Abstract Hadronization Type} The [[model]] is the fallback model including all hadrons <>= type, abstract :: hadrons_t class(rng_t), allocatable :: rng type(shower_settings_t) :: shower_settings type(hadron_settings_t) :: hadron_settings type(model_t), pointer :: model => null() contains <> end type hadrons_t @ %def hadrons_t @ <>= procedure (hadrons_init), deferred :: init <>= abstract interface subroutine hadrons_init & (hadrons, shower_settings, hadron_settings, model_hadrons) import class(hadrons_t), intent(out) :: hadrons type(shower_settings_t), intent(in) :: shower_settings type(hadron_settings_t), intent(in) :: hadron_settings type(model_t), target, intent(in) :: model_hadrons end subroutine hadrons_init end interface @ %def hadrons_init @ <>= procedure (hadrons_hadronize), deferred :: hadronize <>= abstract interface subroutine hadrons_hadronize (hadrons, particle_set, valid) import class(hadrons_t), intent(inout) :: hadrons type(particle_set_t), intent(in) :: particle_set logical, intent(out) :: valid end subroutine hadrons_hadronize end interface @ %def hadrons_hadronize @ <>= procedure (hadrons_make_particle_set), deferred :: make_particle_set <>= abstract interface subroutine hadrons_make_particle_set (hadrons, particle_set, & model, valid) import class(hadrons_t), intent(in) :: hadrons type(particle_set_t), intent(inout) :: particle_set class(model_data_t), intent(in), target :: model logical, intent(out) :: valid end subroutine hadrons_make_particle_set end interface @ %def hadrons_make_particle_set @ <>= procedure :: import_rng => hadrons_import_rng <>= pure subroutine hadrons_import_rng (hadrons, rng) class(hadrons_t), intent(inout) :: hadrons class(rng_t), intent(inout), allocatable :: rng call move_alloc (from = rng, to = hadrons%rng) end subroutine hadrons_import_rng @ %def hadrons_import_rng @ \subsection{[[WHIZARD]] Hadronization Type} Hadronization can be (incompletely) performed through \whizard's internal routine. <>= public :: hadrons_hadrons_t <>= type, extends (hadrons_t) :: hadrons_hadrons_t contains <> end type hadrons_hadrons_t @ %def hadrons_hadrons_t @ <>= procedure :: init => hadrons_hadrons_init <>= subroutine hadrons_hadrons_init & (hadrons, shower_settings, hadron_settings, model_hadrons) class(hadrons_hadrons_t), intent(out) :: hadrons type(shower_settings_t), intent(in) :: shower_settings type(hadron_settings_t), intent(in) :: hadron_settings type(model_t), intent(in), target :: model_hadrons hadrons%model => model_hadrons hadrons%shower_settings = shower_settings hadrons%hadron_settings = hadron_settings call msg_message & ("Hadronization: WHIZARD model for hadronization and decays") end subroutine hadrons_hadrons_init @ %def hadrons_hadrons_init @ <>= procedure :: hadronize => hadrons_hadrons_hadronize <>= subroutine hadrons_hadrons_hadronize (hadrons, particle_set, valid) class(hadrons_hadrons_t), intent(inout) :: hadrons type(particle_set_t), intent(in) :: particle_set logical, intent(out) :: valid integer, dimension(:), allocatable :: cols, acols, octs integer :: n if (signal_is_pending ()) return if (debug_on) call msg_debug (D_TRANSFORMS, "hadrons_hadrons_hadronize") call particle_set%write (6, compressed=.true.) n = particle_set%get_n_tot () allocate (cols (n), acols (n), octs (n)) call extract_color_systems (particle_set, cols, acols, octs) print *, "size(cols) = ", size (cols) if (size(cols) > 0) then print *, "cols = ", cols end if print *, "size(acols) = ", size(acols) if (size(acols) > 0) then print *, "acols = ", acols end if print *, "size(octs) = ", size(octs) if (size (octs) > 0) then print *, "octs = ", octs end if !!! if all arrays are empty, i.e. zero particles found, nothing to do end subroutine hadrons_hadrons_hadronize @ %def hadrons_hadrons_hadronize @ This type contains a flavor selector for the creation of hadrons, including parameters for the special handling of baryons. <>= public :: had_flav_t <>= type had_flav_t end type had_flav_t @ %def had_flav_t @ This is the type for the ends of Lund strings. <>= public :: lund_end <>= type lund_end logical :: from_pos integer :: i_end integer :: i_max integer :: id_had integer :: i_pos_old integer :: i_neg_old integer :: i_pos_new integer :: i_neg_new real(default) :: px_old real(default) :: py_old real(default) :: px_new real(default) :: py_new real(default) :: px_had real(default) :: py_had real(default) :: m_had real(default) :: mT2_had real(default) :: z_had real(default) :: gamma_old real(default) :: gamma_new real(default) :: x_pos_old real(default) :: x_pos_new real(default) :: x_pos_had real(default) :: x_neg_old real(default) :: x_neg_new real(default) :: x_neg_had type(had_flav_t) :: old_flav type(had_flav_t) :: new_flav type(vector4_t) :: p_had type(vector4_t) :: p_pre end type lund_end @ %def lund_end @ Generator for transverse momentum for the fragmentation. <>= public :: lund_pt_t <>= type lund_pt_t real(default) :: sigma_min real(default) :: sigma_q real(default) :: enhanced_frac real(default) :: enhanced_width real(default) :: sigma_to_had class(rng_t), allocatable :: rng contains <> end type lund_pt_t @ %def lund_pt <>= procedure :: init => lund_pt_init <>= subroutine lund_pt_init (lund_pt, settings) class (lund_pt_t), intent(out) :: lund_pt type(hadron_settings_t), intent(in) :: settings end subroutine lund_pt_init @ %def lund_pt_init @ <>= procedure :: make_particle_set => hadrons_hadrons_make_particle_set <>= subroutine hadrons_hadrons_make_particle_set & (hadrons, particle_set, model, valid) class(hadrons_hadrons_t), intent(in) :: hadrons type(particle_set_t), intent(inout) :: particle_set class(model_data_t), intent(in), target :: model logical, intent(out) :: valid if (signal_is_pending ()) return valid = .false. if (valid) then else call msg_fatal ("WHIZARD hadronization not yet implemented") end if end subroutine hadrons_hadrons_make_particle_set @ %def hadrons_hadrons_make_particle_set @ <>= subroutine extract_color_systems (p_set, cols, acols, octs) type(particle_set_t), intent(in) :: p_set integer, dimension(:), allocatable, intent(out) :: cols, acols, octs logical, dimension(:), allocatable :: mask integer :: i, n, n_cols, n_acols, n_octs n = p_set%get_n_tot () allocate (mask (n)) do i = 1, n mask(i) = p_set%prt(i)%col%get_col () /= 0 .and. & p_set%prt(i)%col%get_acl () == 0 .and. & p_set%prt(i)%get_status () == PRT_OUTGOING end do n_cols = count (mask) allocate (cols (n_cols)) cols = p_set%get_indices (mask) do i = 1, n mask(i) = p_set%prt(i)%col%get_col () == 0 .and. & p_set%prt(i)%col%get_acl () /= 0 .and. & p_set%prt(i)%get_status () == PRT_OUTGOING end do n_acols = count (mask) allocate (acols (n_acols)) acols = p_set%get_indices (mask) do i = 1, n mask(i) = p_set%prt(i)%col%get_col () /= 0 .and. & p_set%prt(i)%col%get_acl () /= 0 .and. & p_set%prt(i)%get_status () == PRT_OUTGOING end do n_octs = count (mask) allocate (octs (n_octs)) octs = p_set%get_indices (mask) end subroutine extract_color_systems @ %def extract_color_systems @ \subsection{[[PYTHIA6]] Hadronization Type} Hadronization via [[PYTHIA6]] is at another option for hadronization within \whizard. <>= public :: hadrons_pythia6_t <>= type, extends (hadrons_t) :: hadrons_pythia6_t contains <> end type hadrons_pythia6_t @ %def hadrons_pythia6_t <>= procedure :: init => hadrons_pythia6_init <>= subroutine hadrons_pythia6_init & (hadrons, shower_settings, hadron_settings, model_hadrons) class(hadrons_pythia6_t), intent(out) :: hadrons type(shower_settings_t), intent(in) :: shower_settings type(hadron_settings_t), intent(in) :: hadron_settings type(model_t), intent(in), target :: model_hadrons logical :: pygive_not_set_by_shower hadrons%model => model_hadrons hadrons%shower_settings = shower_settings hadrons%hadron_settings = hadron_settings pygive_not_set_by_shower = .not. (shower_settings%method == PS_PYTHIA6 & .and. (shower_settings%isr_active .or. shower_settings%fsr_active)) if (pygive_not_set_by_shower) then call pythia6_set_verbose (shower_settings%verbose) call pythia6_set_config (shower_settings%pythia6_pygive) end if call msg_message & ("Hadronization: Using PYTHIA6 interface for hadronization and decays") end subroutine hadrons_pythia6_init @ %def hadrons_pythia6_init @ Assume that the event record is still in the PYTHIA COMMON BLOCKS transferred there by the WHIZARD or PYTHIA6 shower routines. <>= procedure :: hadronize => hadrons_pythia6_hadronize <>= subroutine hadrons_pythia6_hadronize (hadrons, particle_set, valid) class(hadrons_pythia6_t), intent(inout) :: hadrons type(particle_set_t), intent(in) :: particle_set logical, intent(out) :: valid integer :: N, NPAD, K real(double) :: P, V common /PYJETS/ N, NPAD, K(4000,5), P(4000,5), V(4000,5) save /PYJETS/ if (signal_is_pending ()) return if (debug_on) call msg_debug (D_TRANSFORMS, "hadrons_pythia6_hadronize") call pygive ("MSTP(111)=1") !!! Switch on hadronization and decays call pygive ("MSTJ(1)=1") !!! String fragmentation call pygive ("MSTJ(21)=2") !!! String fragmentation keeping resonance momentum call pygive ("MSTJ(28)=0") !!! Switch off tau decays if (debug_active (D_TRANSFORMS)) then call msg_debug (D_TRANSFORMS, "N", N) call pylist(2) print *, ' line 7 : ', k(7,1:5), p(7,1:5) end if call pyedit (12) call pythia6_set_last_treated_line (N) call pyexec () call pyedit (12) valid = .true. end subroutine hadrons_pythia6_hadronize @ %def hadrons_pythia6_hadronize @ <>= procedure :: make_particle_set => hadrons_pythia6_make_particle_set <>= subroutine hadrons_pythia6_make_particle_set & (hadrons, particle_set, model, valid) class(hadrons_pythia6_t), intent(in) :: hadrons type(particle_set_t), intent(inout) :: particle_set class(model_data_t), intent(in), target :: model logical, intent(out) :: valid if (signal_is_pending ()) return valid = pythia6_handle_errors () if (valid) then call pythia6_combine_with_particle_set & (particle_set, model, hadrons%model, hadrons%shower_settings) end if end subroutine hadrons_pythia6_make_particle_set @ %def hadrons_pythia6_make_particle_set @ \subsection{[[PYTHIA8]] Hadronization} @ <>= public :: hadrons_pythia8_t <>= type, extends (hadrons_t) :: hadrons_pythia8_t type(pythia8_t) :: pythia type(whizard_lha_t) :: lhaup logical :: user_process_set = .false. logical :: pythia_initialized = .false., & lhaup_initialized = .false. contains <> end type hadrons_pythia8_t @ %def hadrons_pythia8_t @ <>= procedure :: init => hadrons_pythia8_init <>= subroutine hadrons_pythia8_init & (hadrons, shower_settings, hadron_settings, model_hadrons) class(hadrons_pythia8_t), intent(out) :: hadrons type(shower_settings_t), intent(in) :: shower_settings type(hadron_settings_t), intent(in) :: hadron_settings type(model_t), intent(in), target :: model_hadrons hadrons%model => model_hadrons hadrons%shower_settings = shower_settings hadrons%hadron_settings = hadron_settings call msg_message & ("Hadronization: Using PYTHIA8 interface for hadronization and decays.") ! TODO sbrass which verbose? call hadrons%pythia%init (verbose = shower_settings%verbose) call hadrons%lhaup%init () end subroutine hadrons_pythia8_init @ %def hadrons_pythia8_init @ Transfer hadron settings to [[PYTHIA8]]. <>= procedure, private :: transfer_settings => hadrons_pythia8_transfer_settings <>= subroutine hadrons_pythia8_transfer_settings (hadrons) class(hadrons_pythia8_t), intent(inout), target :: hadrons real(default) :: r if (debug_on) call msg_debug (D_TRANSFORMS, "hadrons_pythia8_transfer_settings") if (debug_on) call msg_debug2 (D_TRANSFORMS, "pythia_initialized", hadrons%pythia_initialized) if (hadrons%pythia_initialized) return call hadrons%pythia%import_rng (hadrons%rng) call hadrons%pythia%parse_and_set_config (hadrons%shower_settings%pythia8_config) if (len (hadrons%shower_settings%pythia8_config_file) > 0) & call hadrons%pythia%read_file (hadrons%shower_settings%pythia8_config_file) call hadrons%pythia%read_string (var_str ("Beams:frameType = 5")) call hadrons%pythia%read_string (var_str ("ProcessLevel:all = off")) if (.not. hadrons%shower_settings%verbose) then call hadrons%pythia%read_string (var_str ("Print:quiet = on")) end if call hadrons%pythia%set_lhaup_ptr (hadrons%lhaup) call hadrons%pythia%init_pythia () hadrons%pythia_initialized = .true. end subroutine hadrons_pythia8_transfer_settings @ %def hadrons_pythia8_transfer_settings @ Set user process for the LHA interface. <>= procedure, private :: set_user_process => hadrons_pythia8_set_user_process <>= subroutine hadrons_pythia8_set_user_process (hadrons, pset) class(hadrons_pythia8_t), intent(inout) :: hadrons type(particle_set_t), intent(in) :: pset integer, dimension(2) :: beam_pdg real(default), dimension(2) :: beam_energy integer, parameter :: process_id = 0, n_processes = 0 if (debug_on) call msg_debug (D_TRANSFORMS, "hadrons_pythia8_set_user_process") beam_pdg = [pset%prt(1)%get_pdg (), pset%prt(2)%get_pdg ()] beam_energy = [energy(pset%prt(1)%p), energy(pset%prt(2)%p)] call hadrons%lhaup%set_init (beam_pdg, beam_energy, & n_processes, unweighted = .false., negative_weights = .false.) call hadrons%lhaup%set_process_parameters (process_id = process_id, & cross_section = one, error = one) end subroutine hadrons_pythia8_set_user_process @ %def hadrons_pythia8_set_user_process @ Import particle set. <>= procedure, private :: import_particle_set => hadrons_pythia8_import_particle_set <>= subroutine hadrons_pythia8_import_particle_set (hadrons, particle_set) class(hadrons_pythia8_t), target, intent(inout) :: hadrons type(particle_set_t), intent(in) :: particle_set type(particle_set_t) :: pset_reduced integer, parameter :: PROCESS_ID = 1 if (debug_on) call msg_debug (D_TRANSFORMS, "hadrons_pythia8_import_particle_set") if (.not. hadrons%user_process_set) then call hadrons%set_user_process (particle_set) hadrons%user_process_set = .true. end if call hadrons%lhaup%set_event_process (process_id = PROCESS_ID, scale = -one, & alpha_qcd = -one, alpha_qed = -one, weight = -one) call hadrons%lhaup%set_event (process_id = PROCESS_ID, particle_set = particle_set, & polarization = .true.) if (debug_active (D_TRANSFORMS)) then call hadrons%lhaup%list_init () end if end subroutine hadrons_pythia8_import_particle_set @ %def hadrons_pythia8_import_particle_set @ <>= procedure :: hadronize => hadrons_pythia8_hadronize <>= subroutine hadrons_pythia8_hadronize (hadrons, particle_set, valid) class(hadrons_pythia8_t), intent(inout) :: hadrons type(particle_set_t), intent(in) :: particle_set logical, intent(out) :: valid if (signal_is_pending ()) return call hadrons%import_particle_set (particle_set) if (.not. hadrons%pythia_initialized) & call hadrons%transfer_settings () call hadrons%pythia%next (valid) if (debug_active (D_TRANSFORMS)) then call hadrons%pythia%list_event () call particle_set%write (summary=.true., compressed=.true.) end if end subroutine hadrons_pythia8_hadronize @ %def hadrons_pythia8_hadronize @ <>= procedure :: make_particle_set => hadrons_pythia8_make_particle_set <>= subroutine hadrons_pythia8_make_particle_set & (hadrons, particle_set, model, valid) class(hadrons_pythia8_t), intent(in) :: hadrons type(particle_set_t), intent(inout) :: particle_set class(model_data_t), intent(in), target :: model logical, intent(out) :: valid type(particle_t), dimension(:), allocatable :: beam if (debug_on) call msg_debug (D_TRANSFORMS, "hadrons_pythia8_make_particle_set") if (signal_is_pending ()) return associate (settings => hadrons%shower_settings) if (debug_active (D_TRANSFORMS)) then call msg_debug (D_TRANSFORMS, 'Combine PYTHIA8 with particle set') call msg_debug (D_TRANSFORMS, 'Particle set before replacing') call particle_set%write (summary=.true., compressed=.true.) call hadrons%pythia%list_event () call msg_debug (D_TRANSFORMS, string = "settings%hadron_collision", & value = settings%hadron_collision) end if call hadrons%pythia%get_hadron_particles (& model, hadrons%model, particle_set, & helicity = PRT_DEFINITE_HELICITY) end associate if (debug_active (D_TRANSFORMS)) then print *, 'Particle set after replacing' call particle_set%write (summary=.true., compressed=.true.) end if valid = .true. end subroutine hadrons_pythia8_make_particle_set @ %def hadrons_pythia8_make_particle_set @ \subsection{Hadronization Event Transform} This is the type for the hadronization event transform. It does not depend on the specific hadronization implementation of [[hadrons_t]]. <>= public :: evt_hadrons_t <>= type, extends (evt_t) :: evt_hadrons_t class(hadrons_t), allocatable :: hadrons type(model_t), pointer :: model_hadrons => null() type(qcd_t) :: qcd logical :: is_first_event contains <> end type evt_hadrons_t @ %def evt_hadrons_t @ Initialize the parameters. The [[model_hadrons]] is supposed to be the SM variant that contains all hadrons that may be generated in the shower. <>= procedure :: init => evt_hadrons_init <>= subroutine evt_hadrons_init (evt, model_hadrons) class(evt_hadrons_t), intent(out) :: evt type(model_t), intent(in), target :: model_hadrons evt%model_hadrons => model_hadrons evt%is_first_event = .true. end subroutine evt_hadrons_init @ %def evt_hadrons_init @ <>= procedure :: write_name => evt_hadrons_write_name <>= subroutine evt_hadrons_write_name (evt, unit) class(evt_hadrons_t), intent(in) :: evt integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Event transform: hadronization" end subroutine evt_hadrons_write_name @ %def evt_hadrons_write_name @ Output. <>= procedure :: write => evt_hadrons_write <>= subroutine evt_hadrons_write (evt, unit, verbose, more_verbose, testflag) class(evt_hadrons_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, more_verbose, testflag integer :: u u = given_output_unit (unit) call write_separator (u, 2) call evt%write_name (u) call write_separator (u) call evt%base_write (u, testflag = testflag, show_set = .false.) if (evt%particle_set_exists) & call evt%particle_set%write & (u, summary = .true., compressed = .true., testflag = testflag) call write_separator (u) call evt%hadrons%shower_settings%write (u) call write_separator (u) call evt%hadrons%hadron_settings%write (u) end subroutine evt_hadrons_write @ %def evt_hadrons_write @ <>= procedure :: first_event => evt_hadrons_first_event <>= subroutine evt_hadrons_first_event (evt) class(evt_hadrons_t), intent(inout) :: evt if (debug_on) call msg_debug (D_TRANSFORMS, "evt_hadrons_first_event") associate (settings => evt%hadrons%shower_settings) settings%hadron_collision = .false. !!! !!! !!! Workaround for PGF90 16.1 !!! if (all (evt%particle_set%prt(1:2)%flv%get_pdg_abs () <= 39)) then if (evt%particle_set%prt(1)%flv%get_pdg_abs () <= 39 .and. & evt%particle_set%prt(2)%flv%get_pdg_abs () <= 39) then settings%hadron_collision = .false. !!! else if (all (evt%particle_set%prt(1:2)%flv%get_pdg_abs () >= 100)) then else if (evt%particle_set%prt(1)%flv%get_pdg_abs () >= 100 .and. & evt%particle_set%prt(2)%flv%get_pdg_abs () >= 100) then settings%hadron_collision = .true. else call msg_fatal ("evt_hadrons didn't recognize beams setup") end if if (debug_on) call msg_debug (D_TRANSFORMS, "hadron_collision", settings%hadron_collision) if (.not. (settings%isr_active .or. settings%fsr_active)) then call msg_fatal ("Hadronization without shower is not supported") end if end associate evt%is_first_event = .false. end subroutine evt_hadrons_first_event @ %def evt_hadrons_first_event @ Here we take the particle set from the previous event transform and apply the hadronization. The result is stored in the [[evt%hadrons]] object. We always return a probability of unity as we don't have the analytic weight of the hadronization. Invalid events have to be discarded by the caller which is why we mark the particle set as invalid. <>= procedure :: generate_weighted => evt_hadrons_generate_weighted <>= subroutine evt_hadrons_generate_weighted (evt, probability) class(evt_hadrons_t), intent(inout) :: evt real(default), intent(inout) :: probability logical :: valid if (signal_is_pending ()) return evt%particle_set = evt%previous%particle_set if (evt%is_first_event) then call evt%first_event () end if call evt%hadrons%hadronize (evt%particle_set, valid) probability = 1 evt%particle_set_exists = valid end subroutine evt_hadrons_generate_weighted @ %def evt_hadrons_generate_weighted @ The factorization parameters are irrelevant. <>= procedure :: make_particle_set => evt_hadrons_make_particle_set <>= subroutine evt_hadrons_make_particle_set & (evt, factorization_mode, keep_correlations, r) class(evt_hadrons_t), intent(inout) :: evt integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r logical :: valid call evt%hadrons%make_particle_set (evt%particle_set, evt%model, valid) evt%particle_set_exists = evt%particle_set_exists .and. valid end subroutine evt_hadrons_make_particle_set @ %def event_hadrons_make_particle_set @ Connect the process with the hadrons object. <>= procedure :: connect => evt_hadrons_connect <>= subroutine evt_hadrons_connect & (evt, process_instance, model, process_stack) class(evt_hadrons_t), intent(inout), target :: evt type(process_instance_t), intent(in), target :: process_instance class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack call evt%base_connect (process_instance, model, process_stack) call evt%make_rng (evt%process) end subroutine evt_hadrons_connect @ %def evt_hadrons_connect @ Create RNG instances, spawned by the process object. <>= procedure :: make_rng => evt_hadrons_make_rng <>= subroutine evt_hadrons_make_rng (evt, process) class(evt_hadrons_t), intent(inout) :: evt type(process_t), intent(inout) :: process class(rng_t), allocatable :: rng call process%make_rng (rng) call evt%hadrons%import_rng (rng) end subroutine evt_hadrons_make_rng @ %def evt_hadrons_make_rng @ <>= procedure :: prepare_new_event => evt_hadrons_prepare_new_event <>= subroutine evt_hadrons_prepare_new_event (evt, i_mci, i_term) class(evt_hadrons_t), intent(inout) :: evt integer, intent(in) :: i_mci, i_term call evt%reset () end subroutine evt_hadrons_prepare_new_event @ %def evt_hadrons_prepare_new_event @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Resonance Insertion} <<[[resonance_insertion.f90]]>>= <> module resonance_insertion <> <> use io_units use format_utils, only: write_separator use format_defs, only: FMT_12 use rng_base, only: rng_t use selectors, only: selector_t use sm_qcd use model_data use interactions, only: interaction_t use particles, only: particle_t, particle_set_t use subevents, only: PRT_RESONANT use models use resonances, only: resonance_history_set_t use resonances, only: resonance_tree_t use instances, only: process_instance_ptr_t use event_transforms <> <> <> contains <> end module resonance_insertion @ %def resonance_insertion @ \subsection{Resonance-Insertion Event Transform} This is the type for the event transform that applies resonance insertion. The resonance history set describe the resonance histories that we may consider. There is a process library with process objects that correspond to the resonance histories. Library creation, compilation etc.\ is done outside the scope of this module. <>= public :: evt_resonance_t <>= type, extends (evt_t) :: evt_resonance_t type(resonance_history_set_t), dimension(:), allocatable :: res_history_set integer, dimension(:), allocatable :: index_offset integer :: selected_component = 0 type(string_t) :: libname type(string_t), dimension(:), allocatable :: proc_id real(default) :: on_shell_limit = 0 real(default) :: on_shell_turnoff = 0 real(default) :: background_factor = 1 logical :: selector_active = .false. type(selector_t) :: selector integer :: selected_history = 0 type(process_instance_ptr_t), dimension(:), allocatable :: instance contains <> end type evt_resonance_t @ %def evt_resonance_t <>= procedure :: write_name => evt_resonance_write_name <>= subroutine evt_resonance_write_name (evt, unit) class(evt_resonance_t), intent(in) :: evt integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Event transform: resonance insertion" end subroutine evt_resonance_write_name @ %def evt_resonance_write_name @ Output. <>= procedure :: write => evt_resonance_write <>= subroutine evt_resonance_write (evt, unit, verbose, more_verbose, testflag) class(evt_resonance_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, more_verbose, testflag integer :: u, i u = given_output_unit (unit) call write_separator (u, 2) call evt%write_name (u) call write_separator (u, 2) write (u, "(1x,A,A,A)") "Process library = '", char (evt%libname), "'" if (allocated (evt%res_history_set)) then do i = 1, size (evt%res_history_set) if (i == evt%selected_component) then write (u, "(1x,A,I0,A)") "Component #", i, ": *" else write (u, "(1x,A,I0,A)") "Component #", i, ":" end if call evt%res_history_set(i)%write (u, indent=1) end do end if call write_separator (u) if (allocated (evt%instance)) then write (u, "(1x,A)") "Subprocess instances: allocated" else write (u, "(1x,A)") "Subprocess instances: not allocated" end if if (evt%particle_set_exists) then if (evt%selected_history > 0) then write (u, "(1x,A,I0)") "Selected: resonance history #", & evt%selected_history else write (u, "(1x,A)") "Selected: no resonance history" end if else write (u, "(1x,A)") "Selected: [none]" end if write (u, "(1x,A,1x," // FMT_12 // ")") & "On-shell limit =", evt%on_shell_limit write (u, "(1x,A,1x," // FMT_12 // ")") & "On-shell turnoff =", evt%on_shell_turnoff write (u, "(1x,A,1x," // FMT_12 // ")") & "Background factor =", evt%background_factor call write_separator (u) if (evt%selector_active) then write (u, "(2x)", advance="no") call evt%selector%write (u, testflag=testflag) call write_separator (u) end if call evt%base_write (u, testflag = testflag, show_set = .false.) call write_separator (u) if (evt%particle_set_exists) then call evt%particle_set%write & (u, summary = .true., compressed = .true., testflag = testflag) call write_separator (u) end if end subroutine evt_resonance_write @ %def evt_resonance_write @ \subsection{Set contained data} Insert the resonance data, in form of a pre-generated resonance history set. Accumulate the number of histories for each set, to initialize an array of index offsets for lookup. <>= procedure :: set_resonance_data => evt_resonance_set_resonance_data <>= subroutine evt_resonance_set_resonance_data (evt, res_history_set) class(evt_resonance_t), intent(inout) :: evt type(resonance_history_set_t), dimension(:), intent(in) :: res_history_set integer :: i evt%res_history_set = res_history_set allocate (evt%index_offset (size (evt%res_history_set)), source = 0) do i = 2, size (evt%res_history_set) evt%index_offset(i) = & evt%index_offset(i-1) + evt%res_history_set(i-1)%get_n_history () end do end subroutine evt_resonance_set_resonance_data @ %def evt_resonance_set_resonance_data @ Set the library that contains the resonant subprocesses. <>= procedure :: set_library => evt_resonance_set_library <>= subroutine evt_resonance_set_library (evt, libname) class(evt_resonance_t), intent(inout) :: evt type(string_t), intent(in) :: libname evt%libname = libname end subroutine evt_resonance_set_library @ %def evt_resonance_set_library @ Assign pointers to subprocess instances. Once a subprocess has been selected, the instance is used for generating the particle set with valid quantum-number assignments, ready for resonance insertion. <>= procedure :: set_subprocess_instances & => evt_resonance_set_subprocess_instances <>= subroutine evt_resonance_set_subprocess_instances (evt, instance) class(evt_resonance_t), intent(inout) :: evt type(process_instance_ptr_t), dimension(:), intent(in) :: instance evt%instance = instance end subroutine evt_resonance_set_subprocess_instances @ %def evt_resonance_set_subprocess_instances @ Set the on-shell limit, the relative distance from a resonance that is still considered to be on-shell. The probability for being considered on-shell can be reduced by the turnoff parameter below. For details, see the [[resonances]] module. <>= procedure :: set_on_shell_limit => evt_resonance_set_on_shell_limit <>= subroutine evt_resonance_set_on_shell_limit (evt, on_shell_limit) class(evt_resonance_t), intent(inout) :: evt real(default), intent(in) :: on_shell_limit evt%on_shell_limit = on_shell_limit end subroutine evt_resonance_set_on_shell_limit @ %def evt_resonance_set_on_shell_limit @ Set the Gaussian on-shell turnoff parameter, the width of the weighting factor for the resonance squared matrix element. If the resonance is off shell, this factor reduces the weight of the matrix element in the selector, such that the probability for considered resonant is reduced. The factor is applied only if the offshellness is less than the [[on_shell_limit]] above. For details, see the [[resonances]] module. <>= procedure :: set_on_shell_turnoff => evt_resonance_set_on_shell_turnoff <>= subroutine evt_resonance_set_on_shell_turnoff (evt, on_shell_turnoff) class(evt_resonance_t), intent(inout) :: evt real(default), intent(in) :: on_shell_turnoff evt%on_shell_turnoff = on_shell_turnoff end subroutine evt_resonance_set_on_shell_turnoff @ %def evt_resonance_set_on_shell_turnoff @ Reweight (suppress) the background contribution if there is a resonance history that applies. The event will be registered as background if there is no applicable resonance history, or if the background configuration has been selected based on (reweighted) squared matrix elements. <>= procedure :: set_background_factor => evt_resonance_set_background_factor <>= subroutine evt_resonance_set_background_factor (evt, background_factor) class(evt_resonance_t), intent(inout) :: evt real(default), intent(in) :: background_factor evt%background_factor = background_factor end subroutine evt_resonance_set_background_factor @ %def evt_resonance_set_background_factor @ \subsection{Selector} Manually import a random-number generator object. This should be done only for testing purposes. The standard procedure is to [[connect]] a process to an event transform; this will create an appropriate [[rng]] from the RNG factory in the process object. <>= procedure :: import_rng => evt_resonance_import_rng <>= subroutine evt_resonance_import_rng (evt, rng) class(evt_resonance_t), intent(inout) :: evt class(rng_t), allocatable, intent(inout) :: rng call move_alloc (from = rng, to = evt%rng) end subroutine evt_resonance_import_rng @ %def evt_resonance_import_rng @ We use a standard selector object to choose from the available resonance histories. If the selector is inactive, we do not insert resonances. <>= procedure :: write_selector => evt_resonance_write_selector <>= subroutine evt_resonance_write_selector (evt, unit, testflag) class(evt_resonance_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (evt%selector_active) then call evt%selector%write (u, testflag) else write (u, "(1x,A)") "Selector: [inactive]" end if end subroutine evt_resonance_write_selector @ %def evt_resonance_write_selector @ The selector is initialized with relative weights of histories which need not be normalized. Channels with weight zero are ignored. The [[offset]] will normally be $-1$, so we count from zero, and zero is a valid result from the selector. Selecting the zero entry implies no resonance insertion. However, this behavior is not hard-coded here (without offset, no resonance is not possible as a result). <>= procedure :: init_selector => evt_resonance_init_selector <>= subroutine evt_resonance_init_selector (evt, weight, offset) class(evt_resonance_t), intent(inout) :: evt real(default), dimension(:), intent(in) :: weight integer, intent(in), optional :: offset if (any (weight > 0)) then call evt%selector%init (weight, offset = offset) evt%selector_active = .true. else evt%selector_active = .false. end if end subroutine evt_resonance_init_selector @ %def evt_resonance_init_selector @ Return all selector weights, for inspection. Note that the index counts from zero. <>= procedure :: get_selector_weights => evt_resonance_get_selector_weights <>= subroutine evt_resonance_get_selector_weights (evt, weight) class(evt_resonance_t), intent(in) :: evt real(default), dimension(0:), intent(out) :: weight integer :: i do i = 0, ubound (weight,1) weight(i) = evt%selector%get_weight (i) end do end subroutine evt_resonance_get_selector_weights @ %def evt_resonance_get_selector_weights @ \subsection{Runtime calculations} Use the associated master process instance and the subprocess instances to distribute the current momentum set, then compute the squared matrix elements weights for all subprocesses. NOTE: Procedures in this subsection are not covered by unit tests in this module, but by unit tests of the [[restricted_subprocesses]] module. Fill the particle set, so the momentum configuration can be used by the subprocess instances. The standard workflow is to copy from the previous particle set. <>= procedure :: fill_momenta => evt_resonance_fill_momenta <>= subroutine evt_resonance_fill_momenta (evt) class(evt_resonance_t), intent(inout) :: evt integer :: i, n if (associated (evt%previous)) then evt%particle_set = evt%previous%particle_set else if (associated (evt%process_instance)) then ! this branch only for unit test call evt%process_instance%get_trace & (evt%particle_set, i_term=1, n_incoming=evt%process%get_n_in ()) end if end subroutine evt_resonance_fill_momenta @ %def evt_resonance_fill_momenta @ Return the indices of those subprocesses which can be considered on-shell. The result depends on the stored particle set (outgoing momenta) and on the on-shell limit value. The index [[evt%selected_component]] identifies the particular history set that corresponds to the given process component. Recall that process components may have different external particles, so they have distinct history sets. <>= procedure :: determine_on_shell_histories & => evt_resonance_determine_on_shell_histories <>= subroutine evt_resonance_determine_on_shell_histories & (evt, index_array) class(evt_resonance_t), intent(in) :: evt integer, dimension(:), allocatable, intent(out) :: index_array integer :: i i = evt%selected_component call evt%res_history_set(i)%determine_on_shell_histories & (evt%particle_set%get_outgoing_momenta (), & evt%on_shell_limit, & index_array) end subroutine evt_resonance_determine_on_shell_histories @ %def evt_resonance_determine_on_shell_histories @ Evaluate selected subprocesses. (In actual operation, the ones that have been tagged as on-shell.) We assume that the MCI, term, and channel indices for the subprocesses can all be set to 1. <>= procedure :: evaluate_subprocess => evt_resonance_evaluate_subprocess <>= subroutine evt_resonance_evaluate_subprocess (evt, index_array) class(evt_resonance_t), intent(inout) :: evt integer, dimension(:), intent(in) :: index_array integer :: k, i if (allocated (evt%instance)) then do k = 1, size (index_array) i = index_array(k) associate (instance => evt%instance(i)%p) call instance%choose_mci (1) call instance%set_trace (evt%particle_set, 1, check_match=.false.) call instance%recover (channel = 1, i_term = 1, & update_sqme = .true., recover_phs = .false.) end associate end do end if end subroutine evt_resonance_evaluate_subprocess @ %def evt_resonance_evaluate_subprocess @ Return the current squared matrix-element value of the master process, and of the selected resonant subprocesses, respectively. <>= procedure :: get_master_sqme => evt_resonance_get_master_sqme procedure :: get_subprocess_sqme => evt_resonance_get_subprocess_sqme <>= function evt_resonance_get_master_sqme (evt) result (sqme) class(evt_resonance_t), intent(in) :: evt real(default) :: sqme sqme = evt%process_instance%get_sqme () end function evt_resonance_get_master_sqme subroutine evt_resonance_get_subprocess_sqme (evt, sqme, index_array) class(evt_resonance_t), intent(in) :: evt real(default), dimension(:), intent(out) :: sqme integer, dimension(:), intent(in), optional :: index_array integer :: k, i if (present (index_array)) then sqme = 0 do k = 1, size (index_array) call get_sqme (index_array(k)) end do else do i = 1, size (evt%instance) call get_sqme (i) end do end if contains subroutine get_sqme (i) integer, intent(in) :: i associate (instance => evt%instance(i)%p) sqme(i) = instance%get_sqme () end associate end subroutine get_sqme end subroutine evt_resonance_get_subprocess_sqme @ %def evt_resonance_get_master_sqme @ %def evt_resonance_get_subprocess_sqme @ Apply a turnoff factor for off-shell kinematics to the [[sqme]] values. The [[sqme]] array indices are offset from the resonance history set entries. <>= procedure :: apply_turnoff_factor => evt_resonance_apply_turnoff_factor <>= subroutine evt_resonance_apply_turnoff_factor (evt, sqme, index_array) class(evt_resonance_t), intent(in) :: evt real(default), dimension(:), intent(inout) :: sqme integer, dimension(:), intent(in) :: index_array integer :: k, i_res, i_prc do k = 1, size (index_array) i_res = evt%selected_component i_prc = index_array(k) + evt%index_offset(i_res) sqme(i_prc) = sqme(i_prc) & * evt%res_history_set(i_res)%evaluate_gaussian & & (evt%particle_set%get_outgoing_momenta (), & & evt%on_shell_turnoff, index_array(k)) end do end subroutine evt_resonance_apply_turnoff_factor @ %def evt_resonance_apply_turnoff_factor @ We use the calculations of resonant matrix elements to determine probabilities for all applicable resonance configurations. This method combines the steps implemented above. First, we determine the selected process component. TODO: the version below selects the first component which is found active. This make sense only for standard LO process components, where exactly one component corresponds to a MCI set. For the selected process component, we query the kinematics and determine the applicable resonance histories. We collect squared matrix elements for those resonance histories and compare them to the master-process squared matrix element. The result is the probability for each resonance history together with the probability for non-resonant background (zeroth entry). The latter is defined as the difference between the complete process result and the sum of the resonances, ignoring the possibility for interference. If the complete process result is actually undershooting the sum of resonances, we nevertheless count the background with positive probability. When looking up the subprocess sqme, we must add the [[index_offset]] to the resulting array, since the indices returned by the individual history set all count from one, while the subprocess instances that belong to process components are collected in one flat array. After determining matrix elements and background, we may reduce the weight of the matrix elements in the selector by applying a turnoff factor. The factor [[background_factor]] indicates whether to include the background contribution at all, as long as there is a nonvanishing resonance contribution. Note that instead of setting background to zero, we just multiply it by a very small number. This ensures that indices are assigned correctly, and that background will eventually be selected if smooth turnoff is chosen. <>= procedure :: compute_probabilities => evt_resonance_compute_probabilities <>= subroutine evt_resonance_compute_probabilities (evt) class(evt_resonance_t), intent(inout) :: evt integer, dimension(:), allocatable :: index_array real(default) :: sqme_master, sqme_sum, sqme_bg real(default), dimension(:), allocatable :: sqme_res integer :: n, ic if (.not. associated (evt%process_instance)) return n = size (evt%instance) call evt%select_component (0) FIND_ACTIVE_COMPONENT: do ic = 1, evt%process%get_n_components () if (evt%process%component_is_selected (ic)) then call evt%select_component (ic) exit FIND_ACTIVE_COMPONENT end if end do FIND_ACTIVE_COMPONENT if (evt%selected_component > 0) then call evt%determine_on_shell_histories (index_array) else allocate (index_array (0)) end if call evt%evaluate_subprocess & (index_array + evt%index_offset(evt%selected_component)) allocate (sqme_res (n), source = 0._default) call evt%get_subprocess_sqme & (sqme_res, index_array + evt%index_offset(evt%selected_component)) sqme_master = evt%get_master_sqme () sqme_sum = sum (sqme_res) sqme_bg = abs (sqme_master - sqme_sum) if (evt%on_shell_turnoff > 0) then call evt%apply_turnoff_factor (sqme_res, index_array) end if if (any (sqme_res > 0)) then sqme_bg = sqme_bg * evt%background_factor end if call evt%init_selector ([sqme_bg, sqme_res], offset = -1) end subroutine evt_resonance_compute_probabilities @ %def evt_resonance_compute_probabilities @ Set the selected component (unit tests). <>= procedure :: select_component => evt_resonance_select_component <>= subroutine evt_resonance_select_component (evt, i_component) class(evt_resonance_t), intent(inout) :: evt integer, intent(in) :: i_component evt%selected_component = i_component end subroutine evt_resonance_select_component @ %def evt_resonance_select_component @ \subsection{Sanity check} Check the color assignment, which may be wrong for the inserted resonances. Delegated to the particle-set component. Return offending particle indices and, optionally, particles as arrays. This is done in a unit test. The current algorithm, i.e., selecting the color assignment from the resonant-subprocess instance, should not generate invalid color assignments. <>= procedure :: find_prt_invalid_color => evt_resonance_find_prt_invalid_color <>= subroutine evt_resonance_find_prt_invalid_color (evt, index, prt) class(evt_resonance_t), intent(in) :: evt integer, dimension(:), allocatable, intent(out) :: index type(particle_t), dimension(:), allocatable, intent(out), optional :: prt if (evt%particle_set_exists) then call evt%particle_set%find_prt_invalid_color (index, prt) else allocate (prt (0)) end if end subroutine evt_resonance_find_prt_invalid_color @ %def evt_resonance_find_prt_invalid_color @ \subsection{API implementation} <>= procedure :: prepare_new_event => evt_resonance_prepare_new_event <>= subroutine evt_resonance_prepare_new_event (evt, i_mci, i_term) class(evt_resonance_t), intent(inout) :: evt integer, intent(in) :: i_mci, i_term call evt%reset () end subroutine evt_resonance_prepare_new_event @ %def evt_resonance_prepare_new_event @ Select one of the histories, based on the momentum array from the current particle set. Compute the probabilities for all resonant subprocesses and initialize the selector accordingly. Then select one resonance history, or none. <>= procedure :: generate_weighted => evt_resonance_generate_weighted <>= subroutine evt_resonance_generate_weighted (evt, probability) class(evt_resonance_t), intent(inout) :: evt real(default), intent(inout) :: probability call evt%fill_momenta () call evt%compute_probabilities () call evt%selector%generate (evt%rng, evt%selected_history) probability = 1 end subroutine evt_resonance_generate_weighted @ %def evt_resonance_generate_weighted @ Here take the current particle set and insert resonance intermediate states if applicable. The resonance history has already been chosen by the generator above. If no resonance history applies, just retain the particle set. If a resonance history applies, we factorize the exclusive interaction of the selected (resonance-process) process instance. With a temporary particle set [[prt_set]] as workspace, we the insert the resonances, reinstate parent-child relations and set colors and momenta for the resonances. The temporary is then copied back. Taking the event data from the resonant subprocess instead of the master process, guarantees that all flavor, helicity, and color assignments are valid for the selected resonance history. Note that the transform may thus choose a quantum-number combination that is different from the one chosen by the master process. The [[i_term]] value for the selected subprocess instance is always 1. We support only LO process. For those, the master process may have several terms (= components) that correspond to different external states. The subprocesses are distinct, each one corresponds to a definite master component, and by itself it consists of a single component/term. However, if the selector chooses resonance history \#0, i.e., no resonance, we just copy the particle set from the previous (i.e., trivial) event transform and ignore all subprocess data. <>= procedure :: make_particle_set => evt_resonance_make_particle_set <>= subroutine evt_resonance_make_particle_set & (evt, factorization_mode, keep_correlations, r) class(evt_resonance_t), intent(inout) :: evt integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r type(particle_set_t), target :: prt_set type(particle_t), dimension(:), allocatable :: prt integer :: n_beam, n_in, n_vir, n_res, n_out, i, i_res, i_term, i_tree type(interaction_t), pointer :: int_matrix, int_flows integer, dimension(:), allocatable :: map type(resonance_tree_t) :: res_tree if (associated (evt%previous)) then if (evt%previous%particle_set_exists) then if (evt%selected_history > 0) then if (allocated (evt%instance)) then associate (instance => evt%instance(evt%selected_history)%p) call instance%evaluate_event_data (weight = 1._default) i_term = 1 int_matrix => instance%get_matrix_int_ptr (i_term) int_flows => instance%get_flows_int_ptr (i_term) call evt%factorize_interactions (int_matrix, int_flows, & factorization_mode, keep_correlations, r) call evt%tag_incoming () end associate else ! this branch only for unit test evt%particle_set = evt%previous%particle_set end if i_tree = evt%selected_history & - evt%index_offset(evt%selected_component) call evt%res_history_set(evt%selected_component)%get_tree & (i_tree, res_tree) n_beam = evt%particle_set%get_n_beam () n_in = evt%particle_set%get_n_in () n_vir = evt%particle_set%get_n_vir () n_out = evt%particle_set%get_n_out () n_res = res_tree%get_n_resonances () allocate (map (n_beam + n_in + n_vir + n_out)) map(1:n_beam+n_in+n_vir) & = [(i, i = 1, n_beam+n_in+n_vir)] map(n_beam+n_in+n_vir+1:n_beam+n_in+n_vir+n_out) & = [(i + n_res, & & i = n_beam+n_in+n_vir+1, & & n_beam+n_in+n_vir+n_out)] call prt_set%transfer (evt%particle_set, n_res, map) do i = 1, n_res i_res = n_beam + n_in + n_vir + i call prt_set%insert (i_res, & PRT_RESONANT, & res_tree%get_flv (i), & res_tree%get_children (i, & & n_beam+n_in+n_vir, n_beam+n_in+n_vir+n_res)) end do do i = n_res, 1, -1 i_res = n_beam + n_in + n_vir + i call prt_set%recover_color (i_res) end do call prt_set%set_momentum & (map(:), evt%particle_set%get_momenta (), on_shell = .true.) do i = n_res, 1, -1 i_res = n_beam + n_in + n_vir + i call prt_set%recover_momentum (i_res) end do call evt%particle_set%final () evt%particle_set = prt_set call prt_set%final () evt%particle_set_exists = .true. else ! retain particle set, as copied from previous evt evt%particle_set_exists = .true. end if else evt%particle_set_exists = .false. end if else evt%particle_set_exists = .false. end if end subroutine evt_resonance_make_particle_set @ %def event_resonance_make_particle_set @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[resonance_insertion_ut.f90]]>>= <> module resonance_insertion_ut use unit_tests use resonance_insertion_uti <> <> contains <> end module resonance_insertion_ut @ %def resonance_insertion_ut @ <<[[resonance_insertion_uti.f90]]>>= <> module resonance_insertion_uti <> <> use format_utils, only: write_separator use os_interface use lorentz use rng_base, only: rng_t use flavors, only: flavor_t use colors, only: color_t use models, only: syntax_model_file_init, syntax_model_file_final use models, only: model_list_t, model_t use particles, only: particle_t, particle_set_t use resonances, only: resonance_info_t use resonances, only: resonance_history_t use resonances, only: resonance_history_set_t use event_transforms use resonance_insertion use rng_base_ut, only: rng_test_t <> <> contains <> end module resonance_insertion_uti @ %def resonance_insertion_uti @ API: driver for the unit tests below. <>= public :: resonance_insertion_test <>= subroutine resonance_insertion_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine resonance_insertion_test @ %def resonance_insertion_test @ \subsubsection{Test resonance insertion as event transform} Insert a resonance (W boson) into an event with momentum assignment. <>= call test (resonance_insertion_1, "resonance_insertion_1", & "simple resonance insertion", & u, results) <>= public :: resonance_insertion_1 <>= subroutine resonance_insertion_1 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(resonance_history_set_t), dimension(1) :: res_history_set type(evt_trivial_t), target :: evt_trivial type(evt_resonance_t), target :: evt_resonance type(flavor_t) :: fw type(color_t) :: col real(default) :: mw, ew, pw type(vector4_t), dimension(5) :: p class(rng_t), allocatable :: rng real(default) :: probability integer, dimension(:), allocatable :: i_invalid type(particle_t), dimension(:), allocatable :: prt_invalid integer :: i write (u, "(A)") "* Test output: resonance_insertion_1" write (u, "(A)") "* Purpose: apply simple resonance insertion" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) ! reset slightly in order to avoid a rounding ambiguity call model%set_real (var_str ("mW"), 80.418_default) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 0, n_in = 2, n_rem = 0, n_vir = 0, n_out = 3, & pdg = [1, -1, 1, -2, 24], model = model) call fw%init (24, model) mw = fw%get_mass () ew = 200._default pw = sqrt (ew**2 - mw**2) p(1) = vector4_moving (ew, ew, 3) p(2) = vector4_moving (ew,-ew, 3) p(3) = vector4_moving (ew/2, vector3_moving ([pw/2, mw/2, 0._default])) p(4) = vector4_moving (ew/2, vector3_moving ([pw/2,-mw/2, 0._default])) p(5) = vector4_moving (ew, vector3_moving ([-pw, 0._default, 0._default])) call pset%set_momentum (p, on_shell = .true.) call col%init_col_acl (1,0) call pset%set_color (1, col) call col%init_col_acl (0,1) call pset%set_color (2, col) call col%init_col_acl (2,0) call pset%set_color (3, col) call col%init_col_acl (0,2) call pset%set_color (4, col) call col%init_col_acl (0,0) call pset%set_color (5, col) write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Prepare resonance history set" write (u, "(A)") call res_history_set(1)%init () call res_info%init (3, -24, model, 2) call res_history%add_resonance (res_info) call res_history_set(1)%enter (res_history) call res_history%clear () call res_history_set(1)%freeze () write (u, "(A)") "* Initialize resonance insertion transform" write (u, "(A)") evt_trivial%next => evt_resonance evt_resonance%previous => evt_trivial allocate (rng_test_t :: rng) call evt_resonance%import_rng (rng) call evt_resonance%set_resonance_data (res_history_set) call evt_resonance%select_component (1) call evt_resonance%write (u) write (u, "(A)") write (u, "(A)") "* Fill resonance insertion transform" write (u, "(A)") call evt_resonance%prepare_new_event (1, 1) call evt_resonance%init_selector ([1._default]) call evt_resonance%generate_weighted (probability) call evt_resonance%make_particle_set (0, .false.) call evt_resonance%write (u) write (u, "(A)") write (u, "(A,1x,F8.5)") "Event probability =", probability write (u, "(A)") call evt_resonance%find_prt_invalid_color (i_invalid, prt_invalid) write (u, "(A)") "Particles with invalid color:" select case (size (prt_invalid)) case (0) write (u, "(2x,A)") "[none]" case default do i = 1, size (prt_invalid) write (u, "(1x,A,1x,I0)", advance="no") "Particle", i_invalid(i) call prt_invalid(i)%write (u) end do end select write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_resonance%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: resonance_insertion_1" end subroutine resonance_insertion_1 @ %def resonance_insertion_1 @ \subsubsection{Resonance insertion with color mismatch} Same as previous test (but no momenta); resonance insertion should fail because of color mismatch: W boson is color-neutral. <>= call test (resonance_insertion_2, "resonance_insertion_2", & "resonance color mismatch", & u, results) <>= public :: resonance_insertion_2 <>= subroutine resonance_insertion_2 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(resonance_history_set_t), dimension(1) :: res_history_set type(evt_trivial_t), target :: evt_trivial type(evt_resonance_t), target :: evt_resonance type(color_t) :: col class(rng_t), allocatable :: rng real(default) :: probability type(particle_t), dimension(:), allocatable :: prt_invalid integer, dimension(:), allocatable :: i_invalid integer :: i write (u, "(A)") "* Test output: resonance_insertion_2" write (u, "(A)") "* Purpose: resonance insertion with color mismatch" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 0, n_in = 2, n_rem = 0, n_vir = 0, n_out = 3, & pdg = [1, -1, 1, -2, 24], model = model) call col%init_col_acl (1,0) call pset%set_color (1, col) call col%init_col_acl (0,2) call pset%set_color (2, col) call col%init_col_acl (1,0) call pset%set_color (3, col) call col%init_col_acl (0,2) call pset%set_color (4, col) call col%init_col_acl (0,0) call pset%set_color (5, col) write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Prepare resonance history set" write (u, "(A)") call res_history_set(1)%init () call res_info%init (3, -24, model, 2) call res_history%add_resonance (res_info) call res_history_set(1)%enter (res_history) call res_history%clear () call res_history_set(1)%freeze () write (u, "(A)") "* Initialize resonance insertion transform" write (u, "(A)") evt_trivial%next => evt_resonance evt_resonance%previous => evt_trivial allocate (rng_test_t :: rng) call evt_resonance%import_rng (rng) call evt_resonance%set_resonance_data (res_history_set) call evt_resonance%select_component (1) call evt_resonance%write (u) write (u, "(A)") write (u, "(A)") "* Fill resonance insertion transform" write (u, "(A)") call evt_resonance%prepare_new_event (1, 1) call evt_resonance%init_selector ([1._default]) call evt_resonance%generate_weighted (probability) call evt_resonance%make_particle_set (0, .false.) call evt_resonance%write (u) write (u, "(A)") write (u, "(A,1x,F8.5)") "Event probability =", probability write (u, "(A)") call evt_resonance%find_prt_invalid_color (i_invalid, prt_invalid) write (u, "(A)") "Particles with invalid color:" select case (size (prt_invalid)) case (0) write (u, "(2x,A)") "[none]" case default do i = 1, size (prt_invalid) write (u, "(1x,A,1x,I0)", advance="no") "Particle", i_invalid(i) call prt_invalid(i)%write (u) end do end select write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_resonance%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: resonance_insertion_2" end subroutine resonance_insertion_2 @ %def resonance_insertion_2 @ \subsubsection{Complex resonance history} This is the resonance history $u\bar u \to (t\to W^+ b) + (\bar t\to (h \to b\bar b) + (\bar t^\ast \to W^-\bar b))$. <>= call test (resonance_insertion_3, "resonance_insertion_3", & "complex resonance history", & u, results) <>= public :: resonance_insertion_3 <>= subroutine resonance_insertion_3 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(resonance_history_set_t), dimension(1) :: res_history_set type(evt_trivial_t), target :: evt_trivial type(evt_resonance_t), target :: evt_resonance type(color_t) :: col class(rng_t), allocatable :: rng real(default) :: probability type(particle_t), dimension(:), allocatable :: prt_invalid integer, dimension(:), allocatable :: i_invalid integer :: i write (u, "(A)") "* Test output: resonance_insertion_3" write (u, "(A)") "* Purpose: resonance insertion with color mismatch" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 0, n_in = 2, n_rem = 0, n_vir = 0, n_out = 6, & pdg = [2, -2, 24, 5, 5, -5, -24, -5], model = model) call col%init_col_acl (1,0) call pset%set_color (1, col) call col%init_col_acl (0,2) call pset%set_color (2, col) call col%init_col_acl (0,0) call pset%set_color (3, col) call col%init_col_acl (1,0) call pset%set_color (4, col) call col%init_col_acl (3,0) call pset%set_color (5, col) call col%init_col_acl (0,3) call pset%set_color (6, col) call col%init_col_acl (0,0) call pset%set_color (7, col) call col%init_col_acl (0,2) call pset%set_color (8, col) write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Prepare resonance history set" write (u, "(A)") call res_history_set(1)%init () call res_info%init (3, 6, model, 6) call res_history%add_resonance (res_info) call res_info%init (12, 25, model, 6) call res_history%add_resonance (res_info) call res_info%init (60, -6, model, 6) call res_history%add_resonance (res_info) call res_history_set(1)%enter (res_history) call res_history%clear () call res_history_set(1)%freeze () write (u, "(A)") "* Initialize resonance insertion transform" write (u, "(A)") evt_trivial%next => evt_resonance evt_resonance%previous => evt_trivial allocate (rng_test_t :: rng) call evt_resonance%import_rng (rng) call evt_resonance%set_resonance_data (res_history_set) call evt_resonance%select_component (1) call evt_resonance%write (u) write (u, "(A)") write (u, "(A)") "* Fill resonance insertion transform" write (u, "(A)") call evt_resonance%prepare_new_event (1, 1) call evt_resonance%init_selector ([1._default]) call evt_resonance%generate_weighted (probability) call evt_resonance%make_particle_set (0, .false.) call evt_resonance%write (u) write (u, "(A)") call evt_resonance%find_prt_invalid_color (i_invalid, prt_invalid) write (u, "(A)") "Particles with invalid color:" select case (size (prt_invalid)) case (0) write (u, "(2x,A)") "[none]" case default do i = 1, size (prt_invalid) write (u, "(1x,A,1x,I0)", advance="no") "Particle", i_invalid(i) call prt_invalid(i)%write (u) end do end select write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_resonance%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: resonance_insertion_3" end subroutine resonance_insertion_3 @ %def resonance_insertion_3 @ \subsubsection{Resonance history selection} Another test with zero momenta: select one of several resonant channels using the selector component. <>= call test (resonance_insertion_4, "resonance_insertion_4", & "resonance history selection", & u, results) <>= public :: resonance_insertion_4 <>= subroutine resonance_insertion_4 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(resonance_history_set_t), dimension(1) :: res_history_set type(evt_trivial_t), target :: evt_trivial type(evt_resonance_t), target :: evt_resonance type(color_t) :: col class(rng_t), allocatable :: rng real(default) :: probability integer :: i write (u, "(A)") "* Test output: resonance_insertion_4" write (u, "(A)") "* Purpose: resonance history selection" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 0, n_in = 2, n_rem = 0, n_vir = 0, n_out = 4, & pdg = [1, -1, 1, -2, -3, 4], model = model) write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Prepare resonance history set" write (u, "(A)") call res_history_set(1)%init () call res_info%init (3, -24, model, 4) call res_history%add_resonance (res_info) call res_history_set(1)%enter (res_history) call res_history%clear () call res_info%init (12, 24, model, 4) call res_history%add_resonance (res_info) call res_history_set(1)%enter (res_history) call res_history%clear () call res_info%init (12, 24, model, 4) call res_history%add_resonance (res_info) call res_info%init (15, 25, model, 4) call res_history%add_resonance (res_info) call res_history_set(1)%enter (res_history) call res_history%clear () call res_history_set(1)%freeze () write (u, "(A)") "* Initialize resonance insertion transform" write (u, "(A)") evt_trivial%next => evt_resonance evt_resonance%previous => evt_trivial allocate (rng_test_t :: rng) call evt_resonance%import_rng (rng) call evt_resonance%set_resonance_data (res_history_set) call evt_resonance%select_component (1) call evt_resonance%write (u) write (u, "(A)") write (u, "(A)") "* Fill resonance insertion transform" write (u, "(A)") do i = 1, 6 write (u, "(A,1x,I0)") "* Event #", i write (u, "(A)") call evt_resonance%prepare_new_event (1, 1) call evt_resonance%init_selector ([1._default, 2._default, 1._default]) call evt_resonance%generate_weighted (probability) call evt_resonance%make_particle_set (0, .false.) call evt_resonance%write (u) write (u, "(A)") end do write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_resonance%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: resonance_insertion_4" end subroutine resonance_insertion_4 @ %def resonance_insertion_4 @ \subsubsection{Resonance history selection} Another test with zero momenta: select either a resonant channel or no resonance. <>= call test (resonance_insertion_5, "resonance_insertion_5", & "resonance history on/off", & u, results) <>= public :: resonance_insertion_5 <>= subroutine resonance_insertion_5 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(resonance_history_set_t), dimension(1) :: res_history_set type(evt_trivial_t), target :: evt_trivial type(evt_resonance_t), target :: evt_resonance type(color_t) :: col class(rng_t), allocatable :: rng real(default) :: probability integer :: i write (u, "(A)") "* Test output: resonance_insertion_5" write (u, "(A)") "* Purpose: resonance history selection including no resonance" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 0, n_in = 2, n_rem = 0, n_vir = 0, n_out = 4, & pdg = [1, -1, 1, -2, -3, 4], model = model) write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) write (u, "(A)") "* Prepare resonance history set" write (u, "(A)") call res_history_set(1)%init () call res_info%init (3, -24, model, 4) call res_history%add_resonance (res_info) call res_history_set(1)%enter (res_history) call res_history%clear () call res_history_set(1)%freeze () write (u, "(A)") "* Initialize resonance insertion transform" write (u, "(A)") evt_trivial%next => evt_resonance evt_resonance%previous => evt_trivial allocate (rng_test_t :: rng) call evt_resonance%import_rng (rng) call evt_resonance%set_resonance_data (res_history_set) call evt_resonance%select_component (1) write (u, "(A)") "* Fill resonance insertion transform" write (u, "(A)") do i = 1, 2 write (u, "(A,1x,I0)") "* Event #", i write (u, "(A)") call evt_resonance%prepare_new_event (1, 1) call evt_resonance%init_selector ([1._default, 3._default], offset = -1) call evt_resonance%generate_weighted (probability) call evt_resonance%make_particle_set (0, .false.) call evt_resonance%write (u) write (u, "(A)") end do write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_resonance%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: resonance_insertion_5" end subroutine resonance_insertion_5 @ %def resonance_insertion_5 @ \subsubsection{Resonance insertion with structured beams} Insert a resonance (W boson) into an event with beam and virtual particles. <>= call test (resonance_insertion_6, "resonance_insertion_6", & "resonance insertion with beam structure", & u, results) <>= public :: resonance_insertion_6 <>= subroutine resonance_insertion_6 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_list_t) :: model_list type(particle_set_t) :: pset type(model_t), pointer :: model type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(resonance_history_set_t), dimension(1) :: res_history_set type(evt_trivial_t), target :: evt_trivial type(evt_resonance_t), target :: evt_resonance class(rng_t), allocatable :: rng real(default) :: probability write (u, "(A)") "* Test output: resonance_insertion_6" write (u, "(A)") "* Purpose: resonance insertion with structured beams" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 2, n_in = 2, n_rem = 2, n_vir = 0, n_out = 2, & pdg = [11, -11, 11, -11, 22, 22, 13, -13], model = model) write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Prepare resonance history set" write (u, "(A)") call res_history_set(1)%init () call res_info%init (3, 23, model, 2) call res_history%add_resonance (res_info) call res_history_set(1)%enter (res_history) call res_history%clear () call res_history_set(1)%freeze () write (u, "(A)") "* Initialize resonance insertion transform" write (u, "(A)") evt_trivial%next => evt_resonance evt_resonance%previous => evt_trivial allocate (rng_test_t :: rng) call evt_resonance%import_rng (rng) call evt_resonance%set_resonance_data (res_history_set) call evt_resonance%select_component (1) call evt_resonance%write (u) write (u, "(A)") write (u, "(A)") "* Fill resonance insertion transform" write (u, "(A)") call evt_resonance%prepare_new_event (1, 1) call evt_resonance%init_selector ([1._default]) call evt_resonance%generate_weighted (probability) call evt_resonance%make_particle_set (0, .false.) call evt_resonance%write (u) write (u, "(A)") write (u, "(A,1x,F8.5)") "Event probability =", probability write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_resonance%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: resonance_insertion_6" end subroutine resonance_insertion_6 @ %def resonance_insertion_6 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Recoil kinematics} <<[[recoil_kinematics.f90]]>>= <> module recoil_kinematics <> use constants, only: twopi use lorentz, only: vector4_t use lorentz, only: vector4_null use lorentz, only: vector4_moving use lorentz, only: vector3_moving use lorentz, only: transverse_part use lorentz, only: lorentz_transformation_t use lorentz, only: inverse use lorentz, only: boost use lorentz, only: transformation use lorentz, only: operator(+) use lorentz, only: operator(-) use lorentz, only: operator(*) use lorentz, only: operator(**) use lorentz, only: lambda <> <> <> <> contains <> end module recoil_kinematics @ %def recoil_kinematics @ \subsection{$\phi$ sampler} This is trivial. Generate an azimuthal angle, given a $(0,1)$ RNG parameter. <>= elemental subroutine generate_phi_recoil (r, phi) real(default), intent(in) :: r real(default), intent(out) :: phi phi = r * twopi end subroutine generate_phi_recoil @ %def generate_phi_recoil @ \subsection{$Q^2$ sampler} The dynamics of factorization suggests to generate a flat $Q^2$ distribution from a (random) number, event by event. At the lowest momentum transfer values, the particle (electron) mass sets a smooth cutoff. The formula can produce $Q$ values below the electron mass, down to zero, but with a power distribution that eventually evolves into the expected logarithmic distribution for $Q^2 > m^2$. We are talking about the absolute value here, so all $Q^2$ values are positive. For the actual momentum transfer, $q^2=-Q^2$. <>= public :: generate_q2_recoil <>= elemental subroutine generate_q2_recoil (s, x_bar, q2_max, m2, r, q2) real(default), intent(in) :: s real(default), intent(in) :: q2_max real(default), intent(in) :: x_bar real(default), intent(in) :: m2 real(default), intent(in) :: r real(default), intent(out) :: q2 real(default) :: q2_max_evt q2_max_evt = q2_max_event (s, x_bar, q2_max) q2 = m2 * (exp (r * log (1 + (q2_max_evt / m2))) - 1) end subroutine generate_q2_recoil @ %def generate_q_recoil @ The $Q$ distribution is cut off from above by the kinematic limit, which depends on the energy that is available for the radiated photon, or by a user-defined cutoff -- whichever is less. The kinematic limit fits the formulas for recoil momenta (see below), and it also implicitly enters the ISR collinear structure function, so the normalization of the distribution should be correct. <>= elemental function q2_max_event (s, x_bar, q2_max) result (q2) real(default), intent(in) :: s real(default), intent(in) :: x_bar real(default), intent(in) :: q2_max real(default) :: q2 q2 = min (x_bar * s, q2_max) end function q2_max_event @ %def q2_max_event @ \subsection{Kinematics functions} Given values for energies, $Q_{1,2}^2$, azimuthal angle, compute the matching polar angle of the radiating particle. The subroutine returns $\sin\theta$ and $\cos\theta$. <>= subroutine polar_angles (s, xb, rho, ee, q2, sin_th, cos_th, ok) real(default), intent(in) :: s real(default), intent(in) :: xb real(default), intent(in) :: rho real(default), dimension(2), intent(in) :: ee real(default), dimension(2), intent(in) :: q2 real(default), dimension(2), intent(out) :: sin_th real(default), dimension(2), intent(out) :: cos_th logical, intent(out) :: ok real(default), dimension(2) :: sin2_th_2 sin2_th_2 = q2 / (ee * rho * xb * s) if (all (sin2_th_2 <= 1)) then sin_th = 2 * sqrt (sin2_th_2 * (1 - sin2_th_2)) cos_th = 1 - 2 * sin2_th_2 ok = .true. else sin_th = 0 cos_th = 1 ok = .false. end if end subroutine polar_angles @ %def polar_angles @ Compute the acollinearity parameter $\lambda$ from azimuthal and polar angles. The result is a number between $0$ and $1$. <>= function lambda_factor (sin_th, cos_th, cphi) result (lambda) real(default), dimension(2), intent(in) :: sin_th real(default), dimension(2), intent(in) :: cos_th real(default), intent(in) :: cphi real(default) :: lambda lambda = (1 - cos_th(1) * cos_th(2) - cphi * sin_th(1) * sin_th(2)) / 2 end function lambda_factor @ %def lambda_factor @ Compute the factor that rescales photon energies, such that the radiation angles match the kinematics parameters. For small values of $\bar x/\cosh\eta$, we have to use the Taylor expansion if we do not want to lose precision. The optional argument allows for a unit test that compares exact and approximate. <>= function scale_factor (che, lambda, xb0, approximate) result (rho) real(default), intent(in) :: che real(default), intent(in) :: lambda real(default), intent(in) :: xb0 logical, intent(in), optional :: approximate real(default) :: rho real(default), parameter :: & e0 = (100 * epsilon (1._default)) ** (0.3_default) logical :: approx if (present (approximate)) then approx = approximate else approx = (xb0/che) < e0 end if if (approx) then rho = 1 - lambda * (xb0/(2*che)) * (1 + (1-lambda) * (xb0/che)) else rho = (che / ((1-lambda)*xb0)) & * (1 - sqrt (1 - 2 * (1-lambda) * (xb0/che) & & + (1-lambda) * (xb0 / che)**2)) end if end function scale_factor @ %def scale_factor @ The code snippet below is not used anywhere, but may be manually inserted in a unit test to numerically verify the approximation above. <>= write (u, "(A)") write (u, "(A)") "*** Table: scale factor calculation" write (u, "(A)") lambda = 0.25_default write (u, FMT1) "lambda =", lambda che = 4._default write (u, FMT1) "che =", che write (u, "(A)") " x0 rho(exact) rho(approx) rho(chosen)" xb0 = 1._default do i = 1, 30 xb0 = xb0 / 10 write (u, FMT4) xb0, & scale_factor (che, lambda, xb0, approximate=.false.), & scale_factor (che, lambda, xb0, approximate=.true.), & scale_factor (che, lambda, xb0) end do @ Compute the current values for the $x_{1,2}$ parameters, given the updated scale factor $\rho$ and the collinear parameters. <>= subroutine scaled_x (rho, ee, xb0, x, xb) real(default), intent(in) :: rho real(default), dimension(2), intent(in) :: ee real(default), intent(in) :: xb0 real(default), dimension(2), intent(out) :: x real(default), dimension(2), intent(out) :: xb xb = rho * ee * xb0 x = 1 - xb end subroutine scaled_x @ %def scaled_x @ \subsection{Iterative solution of kinematics constraints} Find a solution of the kinematics constraints. We know the parameters appropriate for collinear kinematics $\sqrt{s}$, $x^c_{1,2}$. We have picked values vor the momentum transfer $Q_{1,2}$ and the azimuthal angles $\phi_{1,2}$. The solution consists of modified energy fractions $x_{1,2}$ and polar angles $\theta_{1,2}$. If the computation fails, which can happen for large momentum transfer, the flag [[ok]] will indicate this. <>= public :: solve_recoil <>= subroutine solve_recoil (sqrts, xc, xcb, phi, q2, x, xb, cos_th, sin_th, ok) real(default), intent(in) :: sqrts real(default), dimension(2), intent(in) :: xc real(default), dimension(2), intent(in) :: xcb real(default), dimension(2), intent(in) :: phi real(default), dimension(2), intent(in) :: q2 real(default), dimension(2), intent(out) :: x real(default), dimension(2), intent(out) :: xb real(default), dimension(2), intent(out) :: cos_th real(default), dimension(2), intent(out) :: sin_th logical, intent(out) :: ok real(default) :: s real(default), dimension(2) :: ee real(default), dimension(2) :: th real(default) :: xb0, cphi real(default) :: che, lambda real(default) :: rho_new, rho, rho_old real(default) :: dr_old, dr_new real(default), parameter :: dr_limit = 100 * epsilon (1._default) integer, parameter :: n_it_max = 20 integer :: i ok = .true. s = sqrts**2 ee = sqrt ([xcb(1)/xcb(2), xcb(2)/xcb(1)]) che = sum (ee) / 2 xb0 = sqrt (xcb(1) * xcb(2)) cphi = cos (phi(1) - phi(2)) rho_old = 10 rho = 1 th = 0 sin_th = sin (th) cos_th = cos (th) lambda = lambda_factor (sin_th, cos_th, cphi) call scaled_x (rho, ee, xb0, x, xb) iterate_loop: do i = 1, n_it_max call polar_angles (s, xb0, rho, ee, q2, sin_th, cos_th, ok) if (.not. ok) return th = atan2 (sin_th, cos_th) lambda = lambda_factor (sin_th, cos_th, cphi) rho_new = scale_factor (che, lambda, xb0) call scaled_x (rho_new, ee, xb0, x, xb) dr_old = abs (rho - rho_old) dr_new = abs (rho_new - rho) rho_old = rho rho = rho_new if (dr_new < dr_limit .or. dr_new >= dr_old) exit iterate_loop end do iterate_loop end subroutine solve_recoil @ %def solve_recoil @ With all kinematics parameters known, construct actual four-vectors for the recoil momenta, the off-shell (spacelike) parton momenta, and on-shell projected parton momenta. <>= public :: recoil_momenta <>= subroutine recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, mo, & km, qm, qo, ok) real(default), intent(in) :: sqrts real(default), dimension(2), intent(in) :: xc real(default), dimension(2), intent(in) :: xb real(default), dimension(2), intent(in) :: cos_th real(default), dimension(2), intent(in) :: sin_th real(default), dimension(2), intent(in) :: phi real(default), dimension(2), intent(in) :: mo type(vector4_t), dimension(2), intent(out) :: km type(vector4_t), dimension(2), intent(out) :: qm type(vector4_t), dimension(2), intent(out) :: qo logical, intent(out) :: ok type(vector4_t), dimension(2) :: pm type(lorentz_transformation_t) :: lt real(default) :: sqsh real(default) :: po4, po2 real(default), dimension(2) :: p0, p3 pm(1) = & vector4_moving (sqrts/2, & vector3_moving ([0._default, 0._default, sqrts/2])) pm(2) = & vector4_moving (sqrts/2, & vector3_moving ([0._default, 0._default,-sqrts/2])) km(1) = xb(1) * (sqrts/2) * vector4_moving ( & 1._default, & vector3_moving ([ & & sin_th(1) * cos (phi(1)), & & sin_th(1) * sin (phi(1)), & & cos_th(1)]) & ) km(2) = xb(2) * (sqrts/2) * vector4_moving ( & 1._default, & vector3_moving ([ & & -sin_th(2) * cos (phi(2)), & & -sin_th(2) * sin (phi(2)), & & -cos_th(2)]) & ) qm(1) = pm(1) - km(1) qm(2) = pm(2) - km(2) sqsh = sqrt (xc(1)*xc(2)) * sqrts lt = transformation (3, qm(1), qm(2), sqsh) po4 = lambda (sqsh**2, mo(1)**2, mo(2)**2) ok = po4 > 0 if (ok) then po2 = sqrt (po4)/4 p0 = sqrt (po2 + mo**2) p3 = [sqrt (po2), -sqrt (po2)] qo = lt * vector4_moving (p0, p3, 3) else qo = vector4_null end if end subroutine recoil_momenta @ %def recoil_momenta @ Compute the Lorentz transformation that we can use to transform any outgoing momenta into the new c.m.\ system of the incoming partons. Not relying on the previous calculations, we determine the transformation that transforms the original collinear partons into their c.m.\ system, and then transform this to the new c.m.\ system. <>= public :: recoil_transformation <>= subroutine recoil_transformation (sqrts, xc, qo, lt) real(default), intent(in) :: sqrts real(default), dimension(2), intent(in) :: xc type(vector4_t), dimension(2), intent(in) :: qo type(lorentz_transformation_t), intent(out) :: lt real(default) :: sqsh type(vector4_t), dimension(2) :: qc type(lorentz_transformation_t) :: ltc, lto qc(1) = xc(1) * vector4_moving (sqrts/2, sqrts/2, 3) qc(2) = xc(2) * vector4_moving (sqrts/2,-sqrts/2, 3) sqsh = sqrt (xc(1) * xc(2)) * sqrts ltc = transformation (3, qc(1), qc(2), sqsh) lto = transformation (3, qo(1), qo(2), sqsh) lt = lto * inverse (ltc) end subroutine recoil_transformation @ %def recoil_transformation @ Compute the Lorentz boost that transforms the c.m.\ frame of the momenta into the lab frame where they are given. Also return their common invariant mass, $\sqrt{s}$. If the initial momenta are not collinear, [[ok]] is set false. <>= public :: initial_transformation <>= subroutine initial_transformation (p, sqrts, lt, ok) type(vector4_t), dimension(2), intent(in) :: p real(default), intent(out) :: sqrts type(lorentz_transformation_t), intent(out) :: lt logical, intent(out) :: ok ok = all (transverse_part (p) == 0) sqrts = (p(1) + p(2)) ** 1 lt = boost (p(1) + p(2), sqrts) end subroutine initial_transformation @ %def initial_transformation @ \subsection{Generate recoil event} Combine the above kinematics calculations. First generate azimuthal angles and momentum transfer, solve kinematics and compute momenta for the radiated photons and the on-shell projected, recoiling partons. The [[mo]] masses are used for the on-shell projection of the partons after radiation. They may be equal to [[m]], or set to zero. If [[ok]] is false, the data point has failed and we should repeat the procedure for a new set of RNG parameters [[r]]. <>= public :: generate_recoil <>= subroutine generate_recoil (sqrts, q_max, m, mo, xc, xcb, r, km, qm, qo, ok) real(default), intent(in) :: sqrts real(default), intent(in), dimension(2) :: q_max real(default), intent(in), dimension(2) :: m real(default), intent(in), dimension(2) :: mo real(default), intent(in), dimension(2) :: xc real(default), intent(in), dimension(2) :: xcb real(default), intent(in), dimension(4) :: r type(vector4_t), dimension(2), intent(out) :: km type(vector4_t), dimension(2), intent(out) :: qm type(vector4_t), dimension(2), intent(out) :: qo logical, intent(out) :: ok real(default), dimension(2) :: q2 real(default), dimension(2) :: phi real(default), dimension(2) :: x real(default), dimension(2) :: xb real(default), dimension(2) :: cos_th real(default), dimension(2) :: sin_th call generate_q2_recoil (sqrts**2, xcb, q_max**2, m**2, r(1:2), q2) call generate_phi_recoil (r(3:4), phi) call solve_recoil (sqrts, xc, xcb, phi, q2, x, xb, cos_th, sin_th, ok) if (ok) then call recoil_momenta & (sqrts, xc, xb, cos_th, sin_th, phi, mo, km, qm, qo, ok) end if end subroutine generate_recoil @ %def generate_recoil @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[recoil_kinematics_ut.f90]]>>= <> module recoil_kinematics_ut use unit_tests use recoil_kinematics_uti <> <> contains <> end module recoil_kinematics_ut @ %def recoil_kinematics_ut @ <<[[recoil_kinematics_uti.f90]]>>= <> module recoil_kinematics_uti <> use constants, only: twopi use constants, only: degree use lorentz, only: vector4_t use lorentz, only: vector4_moving use lorentz, only: lorentz_transformation_t use lorentz, only: inverse use lorentz, only: operator(+) use lorentz, only: operator(*) use lorentz, only: operator(**) use lorentz, only: pacify use recoil_kinematics, only: solve_recoil use recoil_kinematics, only: recoil_momenta use recoil_kinematics, only: recoil_transformation use recoil_kinematics, only: initial_transformation use recoil_kinematics, only: generate_q2_recoil use recoil_kinematics, only: generate_recoil <> <> contains <> end module recoil_kinematics_uti @ %def recoil_kinematics_uti @ API: driver for the unit tests below. <>= public :: recoil_kinematics_test <>= subroutine recoil_kinematics_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine recoil_kinematics_test @ %def recoil_kinematics_test @ \subsubsection{Recoil kinematics} For a set of input data, solve the kinematics constraints and generate momenta accordingly. <>= call test (recoil_kinematics_1, "recoil_kinematics_1", & "iterative solution of non-collinear kinematics", & u, results) <>= public :: recoil_kinematics_1 <>= subroutine recoil_kinematics_1 (u) integer, intent(in) :: u real(default) :: sqrts real(default), dimension(2) :: xc, xcb real(default), dimension(2) :: q real(default), dimension(2) :: phi real(default), dimension(2) :: mo real(default), dimension(2) :: cos_th, sin_th real(default), dimension(2) :: x real(default), dimension(2) :: xb type(vector4_t), dimension(2) :: km type(vector4_t), dimension(2) :: qm type(vector4_t), dimension(2) :: qo integer :: i logical :: ok character(*), parameter :: FMT1 = "(1x,A,9(1x,F15.10))" character(*), parameter :: FMT2 = "(1x,A,9(1x,F10.5))" character(*), parameter :: FMT4 = "(3x,ES8.1,9(1x,ES19.12))" write (u, "(A)") "* Test output: recoil_kinematics_1" write (u, "(A)") "* Purpose: compute kinematics for various input data" write (u, "(A)") sqrts = 100 write (u, FMT1) "sqrts =", sqrts write (u, "(A)") write (u, "(A)") "*** collinear data set" write (u, "(A)") xc = [0.6_default, 0.9_default] xcb = 1 - xc phi = [0.1_default, 0.2_default] * twopi q = 0 mo = 0 call show_data call solve_recoil (sqrts, xc, xcb, phi, q**2, x, xb, cos_th, sin_th, ok) call show_results call recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, mo, km, qm, qo, ok) call show_momenta write (u, "(A)") write (u, "(A)") "*** moderate data set" write (u, "(A)") xc = [0.6_default, 0.9_default] xcb = 1 - xc phi = [0.1_default, 0.2_default] * twopi q = [0.2_default, 0.05_default] * sqrts call show_data call solve_recoil (sqrts, xc, xcb, phi, q**2, x, xb, cos_th, sin_th, ok) call show_results call recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, mo, km, qm, qo, ok) call show_momenta write (u, "(A)") write (u, "(A)") "*** semi-soft data set" write (u, "(A)") xcb= [0.1_default, 0.0001_default] xc = 1 - xcb phi = [0.1_default, 0.2_default] * twopi q = [0.2_default, 0.00001_default] * sqrts call show_data call solve_recoil (sqrts, xc, xcb, phi, q**2, x, xb, cos_th, sin_th, ok) call show_results call recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, mo, km, qm, qo, ok) call show_momenta write (u, "(A)") write (u, "(A)") "*** hard-soft data set" write (u, "(A)") xcb= [0.1_default, 1.e-30_default] xc = 1 - xcb phi = [0.1_default, 0.2_default] * twopi q = [0.2_default, 1.e-35_default] * sqrts call show_data call solve_recoil (sqrts, xc, xcb, phi, q**2, x, xb, cos_th, sin_th, ok) call show_results call recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, mo, km, qm, qo, ok) call show_momenta write (u, "(A)") write (u, "(A)") "*** hard data set" write (u, "(A)") xc = [0.2_default, 0.4_default] xcb = 1 - xc phi = [0.1_default, 0.8_default] * twopi q = [0.74_default, 0.3_default] * sqrts call show_data call solve_recoil (sqrts, xc, xcb, phi, q**2, x, xb, cos_th, sin_th, ok) call show_results call recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, mo, km, qm, qo, ok) call show_momenta write (u, "(A)") write (u, "(A)") "*** failing data set" write (u, "(A)") xc = [0.2_default, 0.4_default] xcb = 1 - xc phi = [0.1_default, 0.8_default] * twopi q = [0.9_default, 0.3_default] * sqrts call show_data call solve_recoil (sqrts, xc, xcb, phi, q**2, x, xb, cos_th, sin_th, ok) if (.not. ok) then write (u, "(A)") write (u, "(A)") "Failed as expected." end if write (u, "(A)") write (u, "(A)") "* Test output end: recoil_kinematics_1" contains subroutine show_data write (u, FMT1) "sqs_h =", sqrt (xc(1) * xc(2)) * sqrts write (u, FMT1) "xc =", xc write (u, FMT1) "xcb =", xcb write (u, FMT1) "Q =", Q write (u, FMT1) "phi/D =", phi / degree end subroutine show_data subroutine show_results write (u, "(A)") write (u, "(A)") "Result:" write (u, FMT1) "th/D =", atan2 (sin_th, cos_th) / degree write (u, FMT1) "x =", x write (u, "(A)") end subroutine show_results subroutine show_momenta type(vector4_t) :: qm0, qo0 real(default), parameter :: tol = 1.e-7_default call pacify (km, tol) call pacify (qm, tol) call pacify (qo, tol) write (u, "(A)") "Momenta: k" call km(1)%write (u, testflag=.true.) call km(2)%write (u, testflag=.true.) write (u, FMT1) "k^2 =", abs (km(1)**2), abs (km(2)**2) write (u, "(A)") write (u, "(A)") "Momenta: q" call qm(1)%write (u, testflag=.true.) call qm(2)%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "Momenta: q(os)" call qo(1)%write (u, testflag=.true.) call qo(2)%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "Check: parton momentum sum: q vs q(os)" qm0 = qm(1) + qm(2) call qm0%write (u, testflag=.true.) qo0 = qo(1) + qo(2) call qo0%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "* Check: momentum transfer (off-shell/on-shell)" write (u, FMT2) "|q| =", abs (qm(1)**1), abs (qm(2)**1) write (u, FMT2) "Q =", q write (u, FMT2) "|qo|=", abs (qo(1)**1), abs (qo(2)**1) write (u, "(A)") write (u, "(A)") "* Check: sqrts, sqrts_hat" write (u, FMT1) "|p| =", (km(1)+km(2)+qm(1)+qm(2))**1, (qm(1)+qm(2))**1 write (u, FMT1) "sqs =", sqrts, sqrt (product (xc)) * sqrts write (u, FMT1) "|po|=", abs ((km(1)+km(2)+qo(1)+qo(2))**1), abs ((qo(1)+qo(2))**1) end subroutine show_momenta end subroutine recoil_kinematics_1 @ %def recoil_kinematics_1 @ \subsubsection{Recoil $Q$ distribution} Sample the $Q$ distribution for equidistant bins in the input variable. <>= call test (recoil_kinematics_2, "recoil_kinematics_2", & "Q distribution", & u, results) <>= public :: recoil_kinematics_2 <>= subroutine recoil_kinematics_2 (u) integer, intent(in) :: u real(default) :: sqrts real(default) :: q_max real(default) :: m real(default) :: x_bar real(default) :: r real(default) :: q2, q2_old integer :: i integer :: n_bin character(*), parameter :: FMT1 = "(1x,A,9(1x,F15.10))" character(*), parameter :: FMT3 = "(2x,9(1x,F10.5))" write (u, "(A)") "* Test output: recoil_kinematics_2" write (u, "(A)") "* Purpose: compute Q distribution" write (u, "(A)") n_bin = 20 write (u, "(A)") "* No Q cutoff, xbar = 1" write (u, "(A)") sqrts = 100 q_max = sqrts m = 0.511e-3_default x_bar = 1._default call show_table write (u, "(A)") write (u, "(A)") "* With Q cutoff, xbar = 1" write (u, "(A)") q_max = 10 call show_table write (u, "(A)") write (u, "(A)") "* No Q cutoff, xbar = 0.01" write (u, "(A)") q_max = sqrts x_bar = 0.01_default call show_table write (u, "(A)") write (u, "(A)") "* Test output end: recoil_kinematics_2" contains subroutine show_table write (u, FMT1) "sqrts =", sqrts write (u, FMT1) "q_max =", q_max write (u, FMT1) "m =", m write (u, FMT1) "x_bar =", x_bar write (u, "(A)") write (u, "(1x,A)") "Table: r |Q| |Q_i/Q_(i-1)|" q2_old = 0 do i = 0, n_bin r = real (i, default) / n_bin call generate_q2_recoil (sqrts**2, x_bar, q_max**2, m**2, r, q2) if (q2_old > 0) then write (u, FMT3) r, sqrt (q2), sqrt (q2 / q2_old) else write (u, FMT3) r, sqrt (q2) end if q2_old = q2 end do end subroutine show_table end subroutine recoil_kinematics_2 @ %def recoil_kinematics_2 @ \subsubsection{Generate recoil event} Combine $Q^2$ sampling with momentum generation. <>= call test (recoil_kinematics_3, "recoil_kinematics_3", & "generate recoil event", & u, results) <>= public :: recoil_kinematics_3 <>= subroutine recoil_kinematics_3 (u) integer, intent(in) :: u real(default) :: sqrts real(default), dimension(2) :: q_max real(default), dimension(2) :: m, mo real(default), dimension(2) :: xc, xcb real(default), dimension(4) :: r type(vector4_t), dimension(2) :: km type(vector4_t), dimension(2) :: qm type(vector4_t), dimension(2) :: qo logical :: ok character(*), parameter :: FMT1 = "(1x,A,9(1x,F15.10))" character(*), parameter :: FMT2 = "(1x,A,9(1x,F10.5))" write (u, "(A)") "* Test output: recoil_kinematics_3" write (u, "(A)") "* Purpose: generate momenta from RNG parameters" write (u, "(A)") write (u, "(A)") "*** collinear data set" write (u, "(A)") sqrts = 100 q_max = sqrts m = 0.511e-3_default mo = 0 xc = [0.6_default, 0.9_default] xcb = 1 - xc r = [0._default, 0._default, 0._default, 0._default] call show_data call generate_recoil (sqrts, q_max, m, mo, xc, xcb, r, km, qm, qo, ok) call show_momenta write (u, "(A)") write (u, "(A)") "*** moderate data set" write (u, "(A)") xc = [0.6_default, 0.9_default] xcb = 1 - xc r = [0.8_default, 0.2_default, 0.1_default, 0.2_default] call show_data call generate_recoil (sqrts, q_max, m, mo, xc, xcb, r, km, qm, qo, ok) call show_momenta write (u, "(A)") write (u, "(A)") "*** failing data set" write (u, "(A)") xc = [0.2_default, 0.4_default] xcb = 1 - xc r = [0.9999_default, 0.3_default, 0.1_default, 0.8_default] call show_data call generate_recoil (sqrts, q_max, m, mo, xc, xcb, r, km, qm, qo, ok) if (.not. ok) then write (u, "(A)") write (u, "(A)") "Failed as expected." else call show_momenta end if contains subroutine show_data write (u, FMT1) "sqrts =", sqrts write (u, FMT1) "q_max =", q_max write (u, FMT1) "m =", m write (u, FMT1) "xc =", xc write (u, FMT1) "xcb =", xcb write (u, FMT1) "r =", r end subroutine show_data subroutine show_momenta real(default), parameter :: tol = 1.e-7_default call pacify (km, tol) call pacify (qo, tol) write (u, "(A)") write (u, "(A)") "* Momenta: k" call km(1)%write (u, testflag=.true.) call km(2)%write (u, testflag=.true.) write (u, FMT1) "k^2 =", abs (km(1)**2), abs (km(2)**2) write (u, "(A)") write (u, "(A)") "* Momenta: q(os)" call qo(1)%write (u, testflag=.true.) call qo(2)%write (u, testflag=.true.) write (u, FMT1) "q^2 =", abs (qo(1)**2), abs (qo(2)**2) write (u, "(A)") write (u, "(A)") "* Check: momentum transfer (off-shell/on-shell)" write (u, FMT2) "Q =", q_check (1), q_check (2) write (u, FMT2) "|q| =", abs (qm(1)**1), abs (qm(2)**1) write (u, "(A)") write (u, "(A)") "* Check: sqrts, sqrts_hat" write (u, FMT1) "sqs =", sqrts, sqrt (product (xc)) * sqrts write (u, FMT1) "|po|=", abs ((km(1)+km(2)+qo(1)+qo(2))**1), abs ((qo(1)+qo(2))**1) end subroutine show_momenta function q_check (i) result (q) integer, intent(in) :: i real(default) :: q real(default) :: q2 call generate_q2_recoil (sqrts**2, xcb(i), q_max(i)**2, m(i)**2, r(i), q2) q = sqrt (q2) end function q_check end subroutine recoil_kinematics_3 @ %def recoil_kinematics_3 @ \subsubsection{Transformation after recoil} Given a solution to recoil kinematics, compute the Lorentz transformation that transforms the old collinear parton momenta into the new parton momenta. <>= call test (recoil_kinematics_4, "recoil_kinematics_4", & "reference frame", & u, results) <>= public :: recoil_kinematics_4 <>= subroutine recoil_kinematics_4 (u) integer, intent(in) :: u real(default) :: sqrts real(default), dimension(2) :: xc, xcb real(default), dimension(2) :: q real(default), dimension(2) :: phi real(default), dimension(2) :: cos_th, sin_th real(default), dimension(2) :: mo real(default), dimension(2) :: x real(default), dimension(2) :: xb type(vector4_t), dimension(2) :: km type(vector4_t), dimension(2) :: qm type(vector4_t), dimension(2) :: qo type(lorentz_transformation_t) :: lt logical :: ok character(*), parameter :: FMT1 = "(1x,A,9(1x,F15.10))" character(*), parameter :: FMT2 = "(1x,A,9(1x,F10.5))" write (u, "(A)") "* Test output: recoil_kinematics_4" write (u, "(A)") "* Purpose: check Lorentz transformation for recoil" write (u, "(A)") sqrts = 100 write (u, FMT1) "sqrts =", sqrts write (u, "(A)") write (u, "(A)") "*** collinear data set" write (u, "(A)") xc = [0.6_default, 0.9_default] xcb = 1 - xc phi = [0.1_default, 0.2_default] * twopi q = 0 mo = 0 call show_data call solve_recoil (sqrts, xc, xcb, phi, q**2, x, xb, cos_th, sin_th, ok) call recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, mo, km, qm, qo, ok) call recoil_transformation (sqrts, xc, qo, lt) call show_transformation write (u, "(A)") write (u, "(A)") "*** moderate data set" write (u, "(A)") xc = [0.6_default, 0.9_default] xcb = 1 - xc phi = [0.1_default, 0.2_default] * twopi q = [0.2_default, 0.05_default] * sqrts call show_data call solve_recoil (sqrts, xc, xcb, phi, q**2, x, xb, cos_th, sin_th, ok) call recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, mo, km, qm, qo, ok) call recoil_transformation (sqrts, xc, qo, lt) call show_transformation write (u, "(A)") write (u, "(A)") "* Test output end: recoil_kinematics_4" contains subroutine show_data write (u, FMT1) "sqs_h =", sqrt (xc(1) * xc(2)) * sqrts write (u, FMT1) "xc =", xc write (u, FMT1) "xcb =", xcb write (u, FMT1) "Q =", Q write (u, FMT1) "phi/D =", phi / degree end subroutine show_data subroutine show_transformation type(vector4_t), dimension(2) :: qc type(vector4_t), dimension(2) :: qct real(default), parameter :: tol = 1.e-7_default qc(1) = xc(1) * vector4_moving (sqrts/2, sqrts/2, 3) qc(2) = xc(2) * vector4_moving (sqrts/2,-sqrts/2, 3) qct = lt * qc call pacify (qct, tol) write (u, "(A)") write (u, "(A)") "Momenta: q(os)" call qo(1)%write (u, testflag=.true.) call qo(2)%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "Momenta: LT * qc" call qct(1)%write (u, testflag=.true.) call qct(2)%write (u, testflag=.true.) end subroutine show_transformation end subroutine recoil_kinematics_4 @ %def recoil_kinematics_4 @ \subsubsection{Transformation before recoil} Given a pair of incoming `beam' partons (i.e., before ISR splitting), compute the transformation that transforms their common c.m.\ frame into the lab frame. <>= call test (recoil_kinematics_5, "recoil_kinematics_5", & "initial reference frame", & u, results) <>= public :: recoil_kinematics_5 <>= subroutine recoil_kinematics_5 (u) integer, intent(in) :: u real(default) :: sqrts real(default) :: sqrtsi real(default), dimension(2) :: x type(vector4_t), dimension(2) :: p type(vector4_t), dimension(2) :: pi type(vector4_t), dimension(2) :: p0 type(lorentz_transformation_t) :: lt logical :: ok character(*), parameter :: FMT1 = "(1x,A,9(1x,F15.10))" character(*), parameter :: FMT2 = "(1x,A,9(1x,F10.5))" write (u, "(A)") "* Test output: recoil_kinematics_5" write (u, "(A)") "* Purpose: determine initial Lorentz transformation" write (u, "(A)") sqrts = 100 write (u, FMT1) "sqrts =", sqrts x = [0.6_default, 0.9_default] p(1) = x(1) * vector4_moving (sqrts/2, sqrts/2, 3) p(2) = x(2) * vector4_moving (sqrts/2,-sqrts/2, 3) call show_data call initial_transformation (p, sqrtsi, lt, ok) pi(1) = vector4_moving (sqrtsi/2, sqrtsi/2, 3) pi(2) = vector4_moving (sqrtsi/2,-sqrtsi/2, 3) p0 = inverse (lt) * p call show_momenta write (u, "(A)") write (u, "(A)") "* Test output end: recoil_kinematics_5" contains subroutine show_data write (u, FMT1) "sqrts =", sqrts write (u, FMT1) "x =", x end subroutine show_data subroutine show_momenta real(default), parameter :: tol = 1.e-7_default write (u, "(A)") write (u, "(A)") "* Momenta: p_in(c.m.)" call pi(1)%write (u, testflag=.true.) call pi(2)%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "* Momenta: inv(LT) * p_in(lab)" call p0(1)%write (u, testflag=.true.) call p0(2)%write (u, testflag=.true.) end subroutine show_momenta end subroutine recoil_kinematics_5 @ %def recoil_kinematics_5 @ \subsubsection{Transformation after recoil with on-shell momenta} Given a solution to recoil kinematics, compute the Lorentz transformation that transforms the old collinear parton momenta into the new parton momenta. Compare the results for massless and massive on-shell projection. <>= call test (recoil_kinematics_6, "recoil_kinematics_6", & "massless/massive on-shell projection", & u, results) <>= public :: recoil_kinematics_6 <>= subroutine recoil_kinematics_6 (u) integer, intent(in) :: u real(default) :: sqrts real(default), dimension(2) :: xc, xcb real(default), dimension(2) :: q real(default), dimension(2) :: phi real(default), dimension(2) :: cos_th, sin_th real(default), dimension(2) :: x real(default), dimension(2) :: xb real(default), dimension(2) :: mo, z type(vector4_t), dimension(2) :: km type(vector4_t), dimension(2) :: qm type(vector4_t), dimension(2) :: qo type(lorentz_transformation_t) :: lt logical :: ok character(*), parameter :: FMT1 = "(1x,A,9(1x,F15.10))" character(*), parameter :: FMT2 = "(1x,A,9(1x,F11.6))" write (u, "(A)") "* Test output: recoil_kinematics_6" write (u, "(A)") "* Purpose: check effect of mass in on-shell projection" write (u, "(A)") sqrts = 10 write (u, FMT1) "sqrts =", sqrts z = 0 mo = 0.511e-3 write (u, FMT1) "mass =", mo write (u, "(A)") write (u, "(A)") "*** collinear data set" write (u, "(A)") xc = [0.6_default, 0.9_default] xcb = 1 - xc phi = [0.1_default, 0.2_default] * twopi q = 0 call show_data call solve_recoil (sqrts, xc, xcb, phi, q**2, x, xb, cos_th, sin_th, ok) call recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, z, km, qm, qo, ok) call recoil_transformation (sqrts, xc, qo, lt) write (u, "(A)") write (u, "(A)") "Massless projection:" call show_momenta call recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, mo, km, qm, qo, ok) call recoil_transformation (sqrts, xc, qo, lt) write (u, "(A)") write (u, "(A)") "Massive projection:" call show_momenta write (u, "(A)") write (u, "(A)") "*** moderate data set" write (u, "(A)") xc = [0.6_default, 0.9_default] xcb = 1 - xc phi = [0.1_default, 0.2_default] * twopi q = [0.2_default, 0.05_default] * sqrts call show_data call solve_recoil (sqrts, xc, xcb, phi, q**2, x, xb, cos_th, sin_th, ok) call recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, z, km, qm, qo, ok) call recoil_transformation (sqrts, xc, qo, lt) write (u, "(A)") write (u, "(A)") "Massless projection:" call show_momenta call recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, mo, km, qm, qo, ok) call recoil_transformation (sqrts, xc, qo, lt) write (u, "(A)") write (u, "(A)") "Massive projection:" call show_momenta write (u, "(A)") write (u, "(A)") "* Test output end: recoil_kinematics_6" contains subroutine show_data write (u, FMT1) "sqs_h =", sqrt (xc(1) * xc(2)) * sqrts write (u, FMT1) "xc =", xc write (u, FMT1) "xcb =", xcb write (u, FMT1) "Q =", Q write (u, FMT1) "phi/D =", phi / degree end subroutine show_data subroutine show_momenta write (u, "(A)") "Momenta: q(os)" call qo(1)%write (u, testflag=.true.) write (u, FMT2) "m = ", abs (qo(1)**1) call qo(2)%write (u, testflag=.true.) write (u, FMT2) "m = ", abs (qo(2)**1) end subroutine show_momenta end subroutine recoil_kinematics_6 @ %def recoil_kinematics_6 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Transverse momentum for the ISR and EPA approximations} The ISR and EPA handler takes an event with a single radiated collinear particle (photon for ISR, beam particle for EPA) for each beam, respectively, and inserts transverse momentum for both. The four-particle kinematics allows us to generate $Q^2$ and azimuthal angles independently, without violating energy-momentum conservation. The $Q^2$ distribution is logarithmic, as required by the effective particle approximation, and reflected in the inclusive ISR/EPA structure functions. We also conserve the invariant mass of the partonic systm after radiation. The total transverse-momentum kick is applied in form of a Lorentz transformation to the elementary process, both in- and out-particles. In fact, the incoming partons (beam particle for ISR, photon for EPA) which would be virtual space-like in the exact kinematics configuration, are replaced by on-shell incoming partons, such that energy, momentum, and invariant mass $\sqrt{\hat s}$ are conserved. Regarding kinematics, we treat all particles as massless. The beam-particle mass only appears as the parameter [[isr_mass]] or [[epa_mass]], respectively, and cuts off the logarithmic distribution. The upper cutoff is [[isr_q_max]] ([[epa_q_max]]), which defaults to the available energy $\sqrt{s}$. The only differences between ISR and EPA, in this context, are the particle types, and an extra $\bar x$ factor in the lower cutoff for EPA, see below. <<[[isr_epa_handler.f90]]>>= <> module isr_epa_handler <> <> use diagnostics, only: msg_fatal use diagnostics, only: msg_bug use io_units use format_defs, only: FMT_12, FMT_19 use format_utils, only: write_separator use format_utils, only: pac_fmt use physics_defs, only: PHOTON use lorentz, only: vector4_t use lorentz, only: energy use lorentz, only: lorentz_transformation_t use lorentz, only: identity use lorentz, only: inverse use lorentz, only: operator(*) use sm_qcd use flavors, only: flavor_t use particles, only: particle_t use model_data use models use rng_base, only: rng_t use event_transforms use recoil_kinematics, only: initial_transformation use recoil_kinematics, only: generate_recoil use recoil_kinematics, only: recoil_transformation <> <> <> <> contains <> end module isr_epa_handler @ %def isr_epa_handler @ \subsection{Event transform type} Convention: [[beam]] are the incoming partons before ISR -- not necessarily the actual beams, need not be in c.m.\ frame. [[radiated]] are the radiated particles (photon for ISR), and [[parton]] are the remainders which initiate the elementary process. These particles are copied verbatim from the event record, and must be collinear. The kinematical parameters are [[sqrts]] = invariant mass of the [[beam]] particles, [[q_max]] and [[m]] determining the $Q^2$ distribution, and [[xc]]/[[xcb]] as the energy fraction (complement) of the partons, relative to the beams. Transformations: [[lti]] is the Lorentz transformation that would boosts [[pi]] (c.m. frame) back to the original [[beam]] momenta (lab frame). [[lto]] is the recoil transformation, transforming the partons after ISR from the collinear frame to the recoiling frame. [[lt]] is the combination of both, which is to be applied to all particles after the hard interaction. Momenta: [[pi]] are the beams transformed to their common c.m.\ frame. [[ki]] and [[qi]] are the photon/parton momenta in the [[pi]] c.m.\ frame. [[km]] and [[qm]] are the photon/parton momenta with the $Q$ distribution applied, and finally [[qo]] are the partons [[qm]] projected on-shell. <>= public :: evt_isr_epa_t <>= type, extends (evt_t) :: evt_isr_epa_t private integer :: mode = ISR_TRIVIAL_COLLINEAR logical :: isr_active = .false. logical :: epa_active = .false. real(default) :: isr_q_max = 0 real(default) :: epa_q_max = 0 real(default) :: isr_mass = 0 real(default) :: epa_mass = 0 logical :: isr_keep_mass = .true. real(default) :: sqrts = 0 integer, dimension(2) :: rad_mode = BEAM_RAD_NONE real(default), dimension(2) :: q_max = 0 real(default), dimension(2) :: m = 0 real(default), dimension(2) :: xc = 0 real(default), dimension(2) :: xcb = 0 type(lorentz_transformation_t) :: lti = identity type(lorentz_transformation_t) :: lto = identity type(lorentz_transformation_t) :: lt = identity integer, dimension(2) :: i_beam = 0 type(particle_t), dimension(2) :: beam type(vector4_t), dimension(2) :: pi integer, dimension(2) :: i_radiated = 0 type(particle_t), dimension(2) :: radiated type(vector4_t), dimension(2) :: ki type(vector4_t), dimension(2) :: km integer, dimension(2) :: i_parton = 0 type(particle_t), dimension(2) :: parton type(vector4_t), dimension(2) :: qi type(vector4_t), dimension(2) :: qm type(vector4_t), dimension(2) :: qo contains <> end type evt_isr_epa_t @ %def evt_isr_epa_t @ \subsection{ISR/EPA distinction} <>= integer, parameter, public :: BEAM_RAD_NONE = 0 integer, parameter, public :: BEAM_RAD_ISR = 1 integer, parameter, public :: BEAM_RAD_EPA = 2 @ %def BEAM_RAD_NONE @ %def BEAM_RAD_ISR @ %def BEAM_RAD_EPA <>= function rad_mode_string (mode) result (string) type(string_t) :: string integer, intent(in) :: mode select case (mode) case (BEAM_RAD_NONE); string = "---" case (BEAM_RAD_ISR); string = "ISR" case (BEAM_RAD_EPA); string = "EPA" case default; string = "???" end select end function rad_mode_string @ %def rad_mode_string @ \subsection{Photon insertion modes} <>= integer, parameter, public :: ISR_TRIVIAL_COLLINEAR = 0 integer, parameter, public :: ISR_PAIR_RECOIL = 1 @ %def ISR_TRIVIAL_COLLINEAR ISR_PAIR_RECOIL @ <>= procedure :: get_mode_string => evt_isr_epa_get_mode_string <>= function evt_isr_epa_get_mode_string (evt) result (string) type(string_t) :: string class(evt_isr_epa_t), intent(in) :: evt select case (evt%mode) case (ISR_TRIVIAL_COLLINEAR) string = "trivial, collinear" case (ISR_PAIR_RECOIL) string = "pair recoil" case default string = "[undefined]" end select end function evt_isr_epa_get_mode_string @ %def evt_isr_epa_get_mode_string @ Set the numerical mode ID from a user-level string representation. <>= procedure :: set_mode_string => evt_isr_epa_set_mode_string <>= subroutine evt_isr_epa_set_mode_string (evt, string) class(evt_isr_epa_t), intent(inout) :: evt type(string_t), intent(in) :: string select case (char (string)) case ("trivial") evt%mode = ISR_TRIVIAL_COLLINEAR case ("recoil") evt%mode = ISR_PAIR_RECOIL case default call msg_fatal ("ISR handler: mode '" // char (string) & // "' is undefined") end select end subroutine evt_isr_epa_set_mode_string @ %def evt_isr_epa_set_mode_string @ \subsection{Output} <>= procedure :: write_name => evt_isr_epa_write_name <>= subroutine evt_isr_epa_write_name (evt, unit) class(evt_isr_epa_t), intent(in) :: evt integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Event transform: ISR/EPA handler" end subroutine evt_isr_epa_write_name @ %def evt_isr_epa_write_name @ The overall recoil-handling mode. <>= procedure :: write_mode => evt_isr_epa_write_mode <>= subroutine evt_isr_epa_write_mode (evt, unit) class(evt_isr_epa_t), intent(in) :: evt integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A,1x,I0,':',1x,A)") "Insertion mode =", evt%mode, & char (evt%get_mode_string ()) end subroutine evt_isr_epa_write_mode @ %def evt_isr_epa_write_mode @ The input data for ISR and EPA, respectively. <>= procedure :: write_input => evt_isr_epa_write_input <>= subroutine evt_isr_epa_write_input (evt, unit, testflag) class(evt_isr_epa_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: testflag character(len=7) :: fmt integer :: u u = given_output_unit (unit) call pac_fmt (fmt, FMT_19, FMT_12, testflag) if (evt%isr_active) then write (u, "(3x,A,1x," // fmt // ")") "ISR: Q_max =", evt%isr_q_max write (u, "(3x,A,1x," // fmt // ")") " m =", evt%isr_mass write (u, "(3x,A,1x,L1)") " keep m=", evt%isr_keep_mass else write (u, "(3x,A)") "ISR: [inactive]" end if if (evt%epa_active) then write (u, "(3x,A,1x," // fmt // ")") "EPA: Q_max =", evt%epa_q_max write (u, "(3x,A,1x," // fmt // ")") " m =", evt%epa_mass else write (u, "(3x,A)") "EPA: [inactive]" end if end subroutine evt_isr_epa_write_input @ %def evt_isr_epa_write_input @ The trivial mode does not depend on any data, since it does nothing to the event. <>= procedure :: write_data => evt_isr_epa_write_data <>= subroutine evt_isr_epa_write_data (evt, unit, testflag) class(evt_isr_epa_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: testflag character(len=7), parameter :: FMTL_19 = "A3,16x" character(len=7), parameter :: FMTL_12 = "A3,9x" character(len=7) :: fmt, fmtl integer :: u u = given_output_unit (unit) call pac_fmt (fmt, FMT_19, FMT_12, testflag) call pac_fmt (fmtl, FMTL_19, FMTL_12, testflag) select case (evt%mode) case (ISR_PAIR_RECOIL) write (u, "(1x,A)") "Event:" write (u, "(3x,A,2(1x," // fmtl // "))") & "mode = ", & char (rad_mode_string (evt%rad_mode(1))), & char (rad_mode_string (evt%rad_mode(2))) write (u, "(3x,A,2(1x," // fmt // "))") "Q_max =", evt%q_max write (u, "(3x,A,2(1x," // fmt // "))") "m =", evt%m write (u, "(3x,A,2(1x," // fmt // "))") "x =", evt%xc write (u, "(3x,A,2(1x," // fmt // "))") "xb =", evt%xcb write (u, "(3x,A,1x," // fmt // ")") "sqrts =", evt%sqrts call write_separator (u) write (u, "(A)") "Lorentz boost (partons before radiation & &c.m. -> lab) =" call evt%lti%write (u, testflag) write (u, "(A)") "Lorentz transformation (collinear partons & &-> partons with recoil in c.m.) =" call evt%lto%write (u, testflag) write (u, "(A)") "Combined transformation (partons & &-> partons with recoil in lab frame) =" call evt%lt%write (u, testflag) end select end subroutine evt_isr_epa_write_data @ %def evt_isr_epa_write_data @ Output method. <>= procedure :: write => evt_isr_epa_write <>= subroutine evt_isr_epa_write (evt, unit, verbose, more_verbose, testflag) class(evt_isr_epa_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, more_verbose, testflag logical :: show_mass integer :: u, i u = given_output_unit (unit) if (present (testflag)) then show_mass = .not. testflag else show_mass = .true. end if call write_separator (u, 2) call evt%write_name (u) call write_separator (u, 2) call evt%write_mode (u) call evt%write_input (u, testflag=testflag) call evt%write_data (u, testflag=testflag) call write_separator (u) call evt%base_write (u, testflag = testflag, show_set = .false.) if (all (evt%i_beam > 0)) then call write_separator (u) write (u, "(A,2(1x,I0))") "Partons before radiation:", evt%i_beam do i = 1, 2 call evt%beam(i)%write (u, testflag=testflag) end do call write_separator (u) write (u, "(A)") "... boosted to c.m.:" do i = 1, 2 call evt%pi(i)%write (u, show_mass=show_mass, testflag=testflag) end do end if if (all (evt%i_radiated > 0)) then call write_separator (u) write (u, "(A,2(1x,I0))") "Radiated particles, collinear:", & evt%i_radiated do i = 1, 2 call evt%radiated(i)%write (u, testflag=testflag) end do call write_separator (u) write (u, "(A)") "... boosted to c.m.:" do i = 1, 2 call evt%ki(i)%write (u, show_mass=show_mass, testflag=testflag) end do call write_separator (u) write (u, "(A)") "... with kT:" do i = 1, 2 call evt%km(i)%write (u, show_mass=show_mass, testflag=testflag) end do end if if (all (evt%i_parton > 0)) then call write_separator (u) write (u, "(A,2(1x,I0))") "Partons after radiation, collinear:", & evt%i_parton do i = 1, 2 call evt%parton(i)%write (u, testflag=testflag) end do call write_separator (u) write (u, "(A)") "... boosted to c.m.:" do i = 1, 2 call evt%qi(i)%write (u, show_mass=show_mass, testflag=testflag) end do call write_separator (u) write (u, "(A)") "... with qT, off-shell:" do i = 1, 2 call evt%qm(i)%write (u, show_mass=show_mass, testflag=testflag) end do call write_separator (u) write (u, "(A)") "... projected on-shell:" do i = 1, 2 call evt%qo(i)%write (u, show_mass=show_mass, testflag=testflag) end do call write_separator (u) end if if (evt%particle_set_exists) & call evt%particle_set%write & (u, summary = .true., compressed = .true., testflag = testflag) call write_separator (u) end subroutine evt_isr_epa_write @ %def evt_isr_epa_write @ \subsection{Initialization} Manually import a random-number generator object. This should be done only for testing purposes. The standard procedure is to [[connect]] a process to an event transform; this will create an appropriate [[rng]] from the RNG factory in the process object. <>= procedure :: import_rng => evt_isr_epa_import_rng <>= subroutine evt_isr_epa_import_rng (evt, rng) class(evt_isr_epa_t), intent(inout) :: evt class(rng_t), allocatable, intent(inout) :: rng call move_alloc (from = rng, to = evt%rng) end subroutine evt_isr_epa_import_rng @ %def evt_isr_epa_import_rng @ Set constant kinematics limits and initialize for ISR. Note that [[sqrts]] is used only as the fallback value for [[q_max]]. The actual [[sqrts]] value for the transform object is inferred from the incoming particles, event by event. <>= procedure :: set_data_isr => evt_isr_epa_set_data_isr <>= subroutine evt_isr_epa_set_data_isr (evt, sqrts, q_max, m, keep_mass) class(evt_isr_epa_t), intent(inout) :: evt real(default), intent(in) :: sqrts real(default), intent(in) :: q_max real(default), intent(in) :: m logical, intent(in) :: keep_mass if (sqrts <= 0) then call msg_fatal ("ISR handler: sqrts value must be positive") end if if (q_max <= 0 .or. q_max > sqrts) then evt%isr_q_max = sqrts else evt%isr_q_max = q_max end if if (m > 0) then evt%isr_mass = m else call msg_fatal ("ISR handler: ISR_mass value must be positive") end if evt%isr_active = .true. evt%isr_keep_mass = keep_mass end subroutine evt_isr_epa_set_data_isr @ %def evt_isr_epa_set_data_isr @ Set constant kinematics limits and initialize for EPA. Note that [[sqrts]] is used only as the fallback value for [[q_max]]. The actual [[sqrts]] value for the transform object is inferred from the incoming particles, event by event. <>= procedure :: set_data_epa => evt_isr_epa_set_data_epa <>= subroutine evt_isr_epa_set_data_epa (evt, sqrts, q_max, m) class(evt_isr_epa_t), intent(inout) :: evt real(default), intent(in) :: sqrts real(default), intent(in) :: q_max real(default), intent(in) :: m if (sqrts <= 0) then call msg_fatal ("EPA handler: sqrts value must be positive") end if if (q_max <= 0 .or. q_max > sqrts) then evt%epa_q_max = sqrts else evt%epa_q_max = q_max end if if (m > 0) then evt%epa_mass = m else call msg_fatal ("EPA handler: EPA_mass value must be positive") end if evt%epa_active = .true. end subroutine evt_isr_epa_set_data_epa @ %def evt_isr_epa_set_data_epa @ \subsection{Fetch event data} Identify the radiated particles and the recoil momenta in the particle set. Without much sophistication, start from the end and find particles with the ``remnant'' status. Their parents should point to the recoiling parton. If successful, set the particle indices in the [[evt]] object, for further processing. <>= procedure, private :: identify_radiated <>= subroutine identify_radiated (evt) class(evt_isr_epa_t), intent(inout) :: evt integer :: i, k k = 2 FIND_LAST_RADIATED: do i = evt%particle_set%get_n_tot (), 1, -1 associate (prt => evt%particle_set%prt(i)) if (prt%is_beam_remnant ()) then evt%i_radiated(k) = i evt%radiated(k) = prt k = k - 1 if (k == 0) exit FIND_LAST_RADIATED end if end associate end do FIND_LAST_RADIATED if (k /= 0) call err_count contains subroutine err_count call evt%particle_set%write () call msg_fatal ("ISR/EPA handler: & &event does not contain two radiated particles") end subroutine err_count end subroutine identify_radiated @ %def identify_radiated @ When the radiated particles are known, we can fetch their parent particles and ask for the other child, the incoming parton. <>= procedure, private :: identify_partons <>= subroutine identify_partons (evt) class(evt_isr_epa_t), intent(inout) :: evt integer, dimension(:), allocatable :: parent, child integer :: i, j if (all (evt%i_radiated > 0)) then do i = 1, 2 parent = evt%radiated(i)%get_parents () if (size (parent) /= 1) call err_mismatch evt%i_beam(i) = parent(1) evt%beam(i) = evt%particle_set%prt(parent(1)) associate (prt => evt%beam(i)) child = prt%get_children () if (size (child) /= 2) call err_mismatch do j = 1, 2 if (child(j) /= evt%i_radiated(i)) then evt%i_parton(i) = child(j) evt%parton(i) = evt%particle_set%prt(child(j)) end if end do end associate end do end if contains subroutine err_mismatch call evt%particle_set%write () call msg_bug ("ISR/EPA handler: mismatch in parent-child relations") end subroutine err_mismatch end subroutine identify_partons @ %def identify_partons @ Check whether the radiated particle is a photon, or the incoming parton is a photon. Then set the ISR/EPA switch appropriately, for each beam. <>= procedure :: check_radiation => evt_isr_epa_check_radiation <>= subroutine evt_isr_epa_check_radiation (evt) class(evt_isr_epa_t), intent(inout) :: evt type(flavor_t) :: flv integer :: i do i = 1, 2 flv = evt%radiated(i)%get_flv () if (flv%get_pdg () == PHOTON) then if (evt%isr_active) then evt%rad_mode(i) = BEAM_RAD_ISR else call err_isr_init end if else flv = evt%parton(i)%get_flv () if (flv%get_pdg () == PHOTON) then if (evt%epa_active) then evt%rad_mode(i) = BEAM_RAD_EPA else call err_epa_init end if else call err_no_photon end if end if end do contains subroutine err_isr_init call evt%particle_set%write () call msg_fatal ("ISR/EPA handler: & &event contains radiated photon, but ISR is not initialized") end subroutine err_isr_init subroutine err_epa_init call evt%particle_set%write () call msg_fatal ("ISR/EPA handler: & &event contains incoming photon, but EPA is not initialized") end subroutine err_epa_init subroutine err_no_photon call evt%particle_set%write () call msg_fatal ("ISR/EPA handler: & &event does not appear to be ISR or EPA - missing photon") end subroutine err_no_photon end subroutine evt_isr_epa_check_radiation @ %def evt_isr_epa_check_radiation @ Internally set the appropriate parameters (ISR/EPA) for the two beams in the recoil mode. <>= procedure :: set_recoil_parameters => evt_isr_epa_set_recoil_parameters <>= subroutine evt_isr_epa_set_recoil_parameters (evt) class(evt_isr_epa_t), intent(inout) :: evt integer :: i do i = 1, 2 select case (evt%rad_mode(i)) case (BEAM_RAD_ISR) evt%q_max(i) = evt%isr_q_max evt%m(i) = evt%isr_mass case (BEAM_RAD_EPA) evt%q_max(i) = evt%epa_q_max evt%m(i) = evt%epa_mass end select end do end subroutine evt_isr_epa_set_recoil_parameters @ %def evt_isr_epa_set_recoil_parameters @ Boost the particles that participate in ISR to their proper c.m.\ frame, copying the momenta to [[pi]], [[ki]], [[qi]]. Also assign [[sqrts]] properly. <>= procedure, private :: boost_to_cm <>= subroutine boost_to_cm (evt) class(evt_isr_epa_t), intent(inout) :: evt type(vector4_t), dimension(2) :: p type(vector4_t), dimension(2) :: k type(vector4_t), dimension(2) :: q logical :: ok p = evt%beam%get_momentum () k = evt%radiated%get_momentum () q = evt%parton%get_momentum () call initial_transformation (p, evt%sqrts, evt%lti, ok) if (.not. ok) call err_non_collinear evt%pi = inverse (evt%lti) * p evt%ki = inverse (evt%lti) * k evt%qi = inverse (evt%lti) * q contains subroutine err_non_collinear call evt%particle_set%write () call msg_fatal ("ISR/EPA handler: & &partons before radiation are not collinear") end subroutine err_non_collinear end subroutine boost_to_cm @ %def boost_to_cm @ We can infer the $x$ and $\bar x$ values of the event by looking at the energy fractions of the radiated particles and incoming partons, respectively, relative to their parents. Of course, we must assume that they are all collinear, and that energy is conserved. <>= procedure, private :: infer_x <>= subroutine infer_x (evt) class(evt_isr_epa_t), intent(inout) :: evt real(default) :: E_parent, E_radiated, E_parton integer :: i if (all (evt%i_radiated > 0)) then do i = 1, 2 E_parent = energy (evt%pi(i)) E_radiated = energy (evt%ki(i)) E_parton = energy (evt%qi(i)) if (E_parent > 0) then evt%xc(i) = E_parton / E_parent evt%xcb(i)= E_radiated / E_parent else call err_energy end if end do end if contains subroutine err_energy call evt%particle_set%write () call msg_bug ("ISR/EPA handler: non-positive energy in splitting") end subroutine err_energy end subroutine infer_x @ %def infer_x @ \subsection{Two-parton recoil} For transforming partons into recoil momenta, we make use of the routines in the [[recoil_kinematics]] module. In addition to the collinear momenta, we use the $x$ energy fractions, and four numbers from the RNG. There is one subtle difference w.r.t.\ ISR case: the EPA mass parameter is multiplied by the energy fraction $x$, separately for each beam. This is the effective lower $Q$ cutoff. For certain kinematics, close to the $Q_\text{max}$ endpoint, this may fail, and [[ok]] is set to false. In that case, we should generate new recoil momenta for the same event. This is handled by the generic unweighting procedure. <>= procedure, private :: generate_recoil => evt_generate_recoil <>= subroutine evt_generate_recoil (evt, ok) class(evt_isr_epa_t), intent(inout) :: evt logical, intent(out) :: ok real(default), dimension(4) :: r real(default), dimension(2) :: m, mo integer :: i call evt%rng%generate (r) m = 0 mo = 0 do i = 1, 2 select case (evt%rad_mode(i)) case (BEAM_RAD_ISR) m(i) = evt%m(i) if (evt%isr_keep_mass) mo(i) = m(i) case (BEAM_RAD_EPA) m(i) = evt%xc(i) * evt%m(i) end select end do call generate_recoil (evt%sqrts, evt%q_max, m, mo, evt%xc, evt%xcb, r, & evt%km, evt%qm, evt%qo, ok) end subroutine evt_generate_recoil @ %def evt_generate_recoil @ Replace the collinear radiated (incoming) parton momenta by the momenta that we have generated, respectively. Recall that the recoil has been applied in the c.m.\ system of the partons before ISR, so we apply the stored Lorentz transformation to boost them to the lab frame. <>= procedure, private :: replace_radiated procedure, private :: replace_partons <>= subroutine replace_radiated (evt) class(evt_isr_epa_t), intent(inout) :: evt integer :: i do i = 1, 2 associate (prt => evt%particle_set%prt(evt%i_radiated(i))) call prt%set_momentum (evt%lti * evt%km(i)) end associate end do end subroutine replace_radiated subroutine replace_partons (evt) class(evt_isr_epa_t), intent(inout) :: evt integer :: i do i = 1, 2 associate (prt => evt%particle_set%prt(evt%i_parton(i))) call prt%set_momentum (evt%lti * evt%qo(i)) end associate end do end subroutine replace_partons @ %def replace_radiated @ %def replace_partons @ \subsection{Transform the event} Knowing the new incoming partons for the elementary process, we can make use of another procedure in [[recoil_kinematics]] to determine the Lorentz transformation that transforms the collinear frame into the frame with transverse momentum. We apply this transformation, recursively, to all particles that originate from those incoming partons in the original particle set. We have to allow for the pre-ISR partons being not in their common c.m.\ frame. Taking into account non-commutativity, we actually have to first transform the outgoing particles to that c.m.\ frame, then apply the recoil transformation, then boost back to the lab frame. The [[mask]] keep track of particles that we transform, just in case the parent-child tree is multiply connected. <>= procedure :: transform_outgoing => evt_transform_outgoing <>= subroutine evt_transform_outgoing (evt) class(evt_isr_epa_t), intent(inout) :: evt logical, dimension(:), allocatable :: mask call recoil_transformation (evt%sqrts, evt%xc, evt%qo, evt%lto) evt%lt = evt%lti * evt%lto * inverse (evt%lti) allocate (mask (evt%particle_set%get_n_tot ()), source=.false.) call transform_children (evt%i_parton(1)) contains recursive subroutine transform_children (i) integer, intent(in) :: i integer :: j, n_child, c integer, dimension(:), allocatable :: child child = evt%particle_set%prt(i)%get_children () do j = 1, size (child) c = child(j) if (.not. mask(c)) then associate (prt => evt%particle_set%prt(c)) call prt%set_momentum (evt%lt * prt%get_momentum ()) mask(c) = .true. call transform_children (c) end associate end if end do end subroutine transform_children end subroutine evt_transform_outgoing @ %def evt_transform_outgoing @ \subsection{Implemented methods} Here we take the particle set from the previous event transform and copy it, then generate the transverse momentum for the radiated particles and for the incoming partons. If this fails (rarely, for large $p_T$), return zero for the probability, to trigger another try. NOTE: The boost for the initial partonic system, if not in the c.m.\ frame, has not been implemented yet. <>= procedure :: generate_weighted => & evt_isr_epa_generate_weighted <>= subroutine evt_isr_epa_generate_weighted (evt, probability) class(evt_isr_epa_t), intent(inout) :: evt real(default), intent(inout) :: probability logical :: valid call evt%particle_set%final () evt%particle_set = evt%previous%particle_set evt%particle_set_exists = .true. select case (evt%mode) case (ISR_TRIVIAL_COLLINEAR) probability = 1 valid = .true. case (ISR_PAIR_RECOIL) call evt%identify_radiated () call evt%identify_partons () call evt%check_radiation () call evt%set_recoil_parameters () call evt%boost_to_cm () call evt%infer_x () call evt%generate_recoil (valid) if (valid) then probability = 1 else probability = 0 end if case default call msg_bug ("ISR/EPA handler: generate weighted: unsupported mode") end select evt%particle_set_exists = .false. end subroutine evt_isr_epa_generate_weighted @ %def evt_isr_epa_generate_weighted @ Insert the generated radiated particles and incoming partons with $p_T$ in their respective places. The factorization parameters are irrelevant. <>= procedure :: make_particle_set => & evt_isr_epa_make_particle_set <>= subroutine evt_isr_epa_make_particle_set & (evt, factorization_mode, keep_correlations, r) class(evt_isr_epa_t), intent(inout) :: evt integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r select case (evt%mode) case (ISR_TRIVIAL_COLLINEAR) case (ISR_PAIR_RECOIL) call evt%replace_radiated () call evt%replace_partons () call evt%transform_outgoing () case default call msg_bug ("ISR/EPA handler: make particle set: unsupported mode") end select evt%particle_set_exists = .true. end subroutine evt_isr_epa_make_particle_set @ %def event_isr_epa_handler_make_particle_set @ <>= procedure :: prepare_new_event => & evt_isr_epa_prepare_new_event <>= subroutine evt_isr_epa_prepare_new_event (evt, i_mci, i_term) class(evt_isr_epa_t), intent(inout) :: evt integer, intent(in) :: i_mci, i_term call evt%reset () end subroutine evt_isr_epa_prepare_new_event @ %def evt_isr_epa_prepare_new_event @ \subsection{Unit tests: ISR} Test module, followed by the corresponding implementation module. This test module differs from most of the other test modules, since it contains two test subroutines: one for ISR and one for EPA below. <<[[isr_epa_handler_ut.f90]]>>= <> module isr_epa_handler_ut use unit_tests use isr_epa_handler_uti <> <> contains <> end module isr_epa_handler_ut @ %def isr_epa_handler_ut @ <<[[isr_epa_handler_uti.f90]]>>= <> module isr_epa_handler_uti <> <> use format_utils, only: write_separator use os_interface use lorentz, only: vector4_t, vector4_moving, operator(*) use rng_base, only: rng_t use models, only: syntax_model_file_init, syntax_model_file_final use models, only: model_list_t, model_t use particles, only: particle_set_t use event_transforms use isr_epa_handler, only: evt_isr_epa_t use rng_base_ut, only: rng_test_t <> <> contains <> end module isr_epa_handler_uti @ %def isr_epa_handler_uti @ API: driver for the unit tests below. <>= public :: isr_handler_test <>= subroutine isr_handler_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine isr_handler_test @ %def isr_handler_test @ \subsubsection{Trivial case} Handle photons resulting from ISR radiation. This test is for the trivial case where the event is kept collinear. <>= call test (isr_handler_1, "isr_handler_1", & "collinear case, no modification", & u, results) <>= public :: isr_handler_1 <>= subroutine isr_handler_1 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(evt_trivial_t), target :: evt_trivial type(evt_isr_epa_t), target :: evt_isr_epa type(vector4_t), dimension(8) :: p real(default) :: sqrts real(default), dimension(2) :: x, xb real(default) :: probability write (u, "(A)") "* Test output: isr_handler_1" write (u, "(A)") "* Purpose: apply photon handler trivially (no-op)" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 2, n_in = 2, n_rem = 2, n_vir = 0, n_out = 2, & pdg = [11, -11, 11, -11, 22, 22, 13, -13], model = model) sqrts = 100._default x = [0.6_default, 0.9_default] xb= 1 - x p(1) = vector4_moving (sqrts/2, sqrts/2, 3) p(2) = vector4_moving (sqrts/2,-sqrts/2, 3) p(3:4) = x * p(1:2) p(5:6) = xb * p(1:2) p(7:8) = p(3:4) call pset%set_momentum (p, on_shell = .false.) write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Initialize ISR handler transform" write (u, "(A)") evt_trivial%next => evt_isr_epa evt_isr_epa%previous => evt_trivial call evt_isr_epa%write (u) write (u, "(A)") write (u, "(A)") "* Fill ISR handler transform" write (u, "(A)") call evt_isr_epa%prepare_new_event (1, 1) call evt_isr_epa%generate_weighted (probability) call evt_isr_epa%make_particle_set (0, .false.) call evt_isr_epa%write (u) write (u, "(A)") write (u, "(A,1x,F8.5)") "Event probability =", probability write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_isr_epa%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: isr_handler_1" end subroutine isr_handler_1 @ %def isr_handler_1 @ \subsubsection{Photon pair with recoil} Handle photons resulting from ISR radiation. This test invokes the two-photon recoil mechanism. Both photons acquire transverse momentum, the parton momenta recoil, such that total energy-momentum is conserved, and all outgoing photons and partons are on-shell (massless). <>= call test (isr_handler_2, "isr_handler_2", & "two-photon recoil", & u, results) <>= public :: isr_handler_2 <>= subroutine isr_handler_2 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(evt_trivial_t), target :: evt_trivial type(evt_isr_epa_t), target :: evt_isr_epa type(vector4_t), dimension(8) :: p real(default) :: sqrts real(default), dimension(2) :: x, xb class(rng_t), allocatable :: rng real(default) :: probability write (u, "(A)") "* Test output: isr_handler_2" write (u, "(A)") "* Purpose: apply photon handler with two-photon recoil" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 2, n_in = 2, n_rem = 2, n_vir = 0, n_out = 2, & pdg = [11, -11, 11, -11, 22, 22, 13, -13], model = model) sqrts = 100._default x = [0.6_default, 0.9_default] xb= 1 - x p(1) = vector4_moving (sqrts/2, sqrts/2, 3) p(2) = vector4_moving (sqrts/2,-sqrts/2, 3) p(3:4) = x * p(1:2) p(5:6) = xb * p(1:2) p(7:8) = p(3:4) call pset%set_momentum (p, on_shell = .false.) write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Initialize ISR handler transform" write (u, "(A)") evt_trivial%next => evt_isr_epa evt_isr_epa%previous => evt_trivial call evt_isr_epa%set_mode_string (var_str ("recoil")) call evt_isr_epa%set_data_isr ( & sqrts = sqrts, & q_max = sqrts, & m = 511.e-3_default, & keep_mass = .false. & ) allocate (rng_test_t :: rng) call rng%init (3) ! default would produce pi for azimuthal angle call evt_isr_epa%import_rng (rng) call evt_isr_epa%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "* Fill ISR handler transform" write (u, "(A)") call evt_isr_epa%prepare_new_event (1, 1) call evt_isr_epa%generate_weighted (probability) call evt_isr_epa%make_particle_set (0, .false.) call evt_isr_epa%write (u, testflag=.true.) write (u, "(A)") write (u, "(A,1x,F8.5)") "Event probability =", probability write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_isr_epa%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: isr_handler_2" end subroutine isr_handler_2 @ %def isr_handler_2 @ \subsubsection{Boosted beams} Handle photons resulting from ISR radiation. This test invokes the two-photon recoil mechanism, in the case that the partons before ISR are not in their c.m.\ frame (but collinear). <>= call test (isr_handler_3, "isr_handler_3", & "two-photon recoil with boost", & u, results) <>= public :: isr_handler_3 <>= subroutine isr_handler_3 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(evt_trivial_t), target :: evt_trivial type(evt_isr_epa_t), target :: evt_isr_epa type(vector4_t), dimension(8) :: p real(default) :: sqrts real(default), dimension(2) :: x0 real(default), dimension(2) :: x, xb class(rng_t), allocatable :: rng real(default) :: probability write (u, "(A)") "* Test output: isr_handler_3" write (u, "(A)") "* Purpose: apply photon handler for boosted beams & &and two-photon recoil" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 2, n_in = 2, n_rem = 2, n_vir = 0, n_out = 2, & pdg = [11, -11, 11, -11, 22, 22, 13, -13], model = model) write (u, "(A)") "* Event data" write (u, "(A)") sqrts = 100._default write (u, "(A,2(1x,F12.7))") "sqrts =", sqrts x0 = [0.9_default, 0.4_default] write (u, "(A,2(1x,F12.7))") "x0 =", x0 write (u, "(A)") write (u, "(A,2(1x,F12.7))") "sqs_hat =", sqrts * sqrt (product (x0)) x = [0.6_default, 0.9_default] xb= 1 - x write (u, "(A,2(1x,F12.7))") "x =", x write (u, "(A)") write (u, "(A,2(1x,F12.7))") "x0 * x =", x0 * x p(1) = x0(1) * vector4_moving (sqrts/2, sqrts/2, 3) p(2) = x0(2) * vector4_moving (sqrts/2,-sqrts/2, 3) p(3:4) = x * p(1:2) p(5:6) = xb * p(1:2) p(7:8) = p(3:4) call pset%set_momentum (p, on_shell = .false.) write (u, "(A)") write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Initialize ISR handler transform" write (u, "(A)") evt_trivial%next => evt_isr_epa evt_isr_epa%previous => evt_trivial call evt_isr_epa%set_mode_string (var_str ("recoil")) call evt_isr_epa%set_data_isr ( & sqrts = sqrts, & q_max = sqrts, & m = 511.e-3_default, & keep_mass = .false. & ) allocate (rng_test_t :: rng) call rng%init (3) ! default would produce pi for azimuthal angle call evt_isr_epa%import_rng (rng) call evt_isr_epa%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "* Fill ISR handler transform" write (u, "(A)") call evt_isr_epa%prepare_new_event (1, 1) call evt_isr_epa%generate_weighted (probability) call evt_isr_epa%make_particle_set (0, .false.) call evt_isr_epa%write (u, testflag=.true.) write (u, "(A)") write (u, "(A,1x,F8.5)") "Event probability =", probability write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_isr_epa%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: isr_handler_3" end subroutine isr_handler_3 @ %def isr_handler_3 @ \subsection{Unit tests: EPA} API: Extra driver for the unit tests below. <>= public :: epa_handler_test <>= subroutine epa_handler_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine epa_handler_test @ %def epa_handler_test @ \subsubsection{Trivial case} Handle events resulting from the EPA approximation. This test is for the trivial case where the event is kept collinear. <>= call test (epa_handler_1, "epa_handler_1", & "collinear case, no modification", & u, results) <>= public :: epa_handler_1 <>= subroutine epa_handler_1 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(evt_trivial_t), target :: evt_trivial type(evt_isr_epa_t), target :: evt_isr_epa type(vector4_t), dimension(8) :: p real(default) :: sqrts real(default), dimension(2) :: x, xb real(default) :: probability write (u, "(A)") "* Test output: epa_handler_1" write (u, "(A)") "* Purpose: apply beam handler trivially (no-op)" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct & (n_beam = 2, n_in = 2, n_rem = 2, n_vir = 0, n_out = 2, & pdg = [11, -11, 22, 22, 11, -11, 13, -13], & model = model) sqrts = 100._default x = [0.6_default, 0.9_default] xb= 1 - x p(1) = vector4_moving (sqrts/2, sqrts/2, 3) p(2) = vector4_moving (sqrts/2,-sqrts/2, 3) p(3:4) = x * p(1:2) p(5:6) = xb * p(1:2) p(7:8) = p(3:4) call pset%set_momentum (p, on_shell = .false.) write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Initialize EPA handler transform" write (u, "(A)") evt_trivial%next => evt_isr_epa evt_isr_epa%previous => evt_trivial call evt_isr_epa%write (u) write (u, "(A)") write (u, "(A)") "* Fill EPA handler transform" write (u, "(A)") call evt_isr_epa%prepare_new_event (1, 1) call evt_isr_epa%generate_weighted (probability) call evt_isr_epa%make_particle_set (0, .false.) call evt_isr_epa%write (u) write (u, "(A)") write (u, "(A,1x,F8.5)") "Event probability =", probability write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_isr_epa%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: epa_handler_1" end subroutine epa_handler_1 @ %def epa_handler_1 @ \subsubsection{Beam pair with recoil} Handle beams resulting from the EPA approximation. This test invokes the two-beam recoil mechanism. Both beam remnants acquire transverse momentum, the photon momenta recoil, such that total energy-momentum is conserved, and all outgoing beam remnants and photons are on-shell (massless). <>= call test (epa_handler_2, "epa_handler_2", & "two-beam recoil", & u, results) <>= public :: epa_handler_2 <>= subroutine epa_handler_2 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(evt_trivial_t), target :: evt_trivial type(evt_isr_epa_t), target :: evt_isr_epa type(vector4_t), dimension(8) :: p real(default) :: sqrts real(default), dimension(2) :: x, xb class(rng_t), allocatable :: rng real(default) :: probability write (u, "(A)") "* Test output: epa_handler_2" write (u, "(A)") "* Purpose: apply beam handler with two-beam recoil" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 2, n_in = 2, n_rem = 2, n_vir = 0, n_out = 2, & pdg = [11, -11, 22, 22, 11, -11, 13, -13], model = model) sqrts = 100._default x = [0.6_default, 0.9_default] xb= 1 - x p(1) = vector4_moving (sqrts/2, sqrts/2, 3) p(2) = vector4_moving (sqrts/2,-sqrts/2, 3) p(3:4) = x * p(1:2) p(5:6) = xb * p(1:2) p(7:8) = p(3:4) call pset%set_momentum (p, on_shell = .false.) write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Initialize EPA handler transform" write (u, "(A)") evt_trivial%next => evt_isr_epa evt_isr_epa%previous => evt_trivial call evt_isr_epa%set_mode_string (var_str ("recoil")) call evt_isr_epa%set_data_epa ( & sqrts = sqrts, & q_max = sqrts, & m = 511.e-3_default & ) allocate (rng_test_t :: rng) call rng%init (3) ! default would produce pi for azimuthal angle call evt_isr_epa%import_rng (rng) call evt_isr_epa%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "* Fill EPA handler transform" write (u, "(A)") call evt_isr_epa%prepare_new_event (1, 1) call evt_isr_epa%generate_weighted (probability) call evt_isr_epa%make_particle_set (0, .false.) call evt_isr_epa%write (u, testflag=.true.) write (u, "(A)") write (u, "(A,1x,F8.5)") "Event probability =", probability write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_isr_epa%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: epa_handler_2" end subroutine epa_handler_2 @ %def epa_handler_2 @ \subsubsection{Boosted beams} Handle radiated beam remnants resulting from EPA radiation. This test invokes the two-beam recoil mechanism, in the case that the partons before EPA are not in their c.m.\ frame (but collinear). <>= call test (epa_handler_3, "epa_handler_3", & "two-beam recoil with boost", & u, results) <>= public :: epa_handler_3 <>= subroutine epa_handler_3 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(evt_trivial_t), target :: evt_trivial type(evt_isr_epa_t), target :: evt_isr_epa type(vector4_t), dimension(8) :: p real(default) :: sqrts real(default), dimension(2) :: x0 real(default), dimension(2) :: x, xb class(rng_t), allocatable :: rng real(default) :: probability write (u, "(A)") "* Test output: epa_handler_3" write (u, "(A)") "* Purpose: apply beam handler for boosted beams & &and two-beam recoil" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 2, n_in = 2, n_rem = 2, n_vir = 0, n_out = 2, & pdg = [11, -11, 22, 22, 11, -11, 13, -13], model = model) write (u, "(A)") "* Event data" write (u, "(A)") sqrts = 100._default write (u, "(A,2(1x,F12.7))") "sqrts =", sqrts x0 = [0.9_default, 0.4_default] write (u, "(A,2(1x,F12.7))") "x0 =", x0 write (u, "(A)") write (u, "(A,2(1x,F12.7))") "sqs_hat =", sqrts * sqrt (product (x0)) x = [0.6_default, 0.9_default] xb= 1 - x write (u, "(A,2(1x,F12.7))") "x =", x write (u, "(A)") write (u, "(A,2(1x,F12.7))") "x0 * x =", x0 * x p(1) = x0(1) * vector4_moving (sqrts/2, sqrts/2, 3) p(2) = x0(2) * vector4_moving (sqrts/2,-sqrts/2, 3) p(3:4) = x * p(1:2) p(5:6) = xb * p(1:2) p(7:8) = p(3:4) call pset%set_momentum (p, on_shell = .false.) write (u, "(A)") write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Initialize EPA handler transform" write (u, "(A)") evt_trivial%next => evt_isr_epa evt_isr_epa%previous => evt_trivial call evt_isr_epa%set_mode_string (var_str ("recoil")) call evt_isr_epa%set_data_epa ( & sqrts = sqrts, & q_max = sqrts, & m = 511.e-3_default & ) allocate (rng_test_t :: rng) call rng%init (3) ! default would produce pi for azimuthal angle call evt_isr_epa%import_rng (rng) call evt_isr_epa%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "* Fill EPA handler transform" write (u, "(A)") call evt_isr_epa%prepare_new_event (1, 1) call evt_isr_epa%generate_weighted (probability) call evt_isr_epa%make_particle_set (0, .false.) call evt_isr_epa%write (u, testflag=.true.) write (u, "(A)") write (u, "(A,1x,F8.5)") "Event probability =", probability write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_isr_epa%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: epa_handler_3" end subroutine epa_handler_3 @ %def epa_handler_3 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Decays} <<[[decays.f90]]>>= <> module decays <> <> use io_units use format_utils, only: write_indent, write_separator use format_defs, only: FMT_15 use numeric_utils use diagnostics use flavors use helicities use quantum_numbers use interactions use evaluators use variables, only: var_list_t use model_data use rng_base use selectors use parton_states use process, only: process_t use instances, only: process_instance_t, pacify use process_stacks use event_transforms <> <> <> <> contains <> end module decays @ %def decays @ \subsection{Final-State Particle Configuration} A final-state particle may be either stable or unstable. Here is an empty abstract type as the parent of both, with holds just the flavor information. <>= type, abstract :: any_config_t private contains <> end type any_config_t @ %def any_config_t @ Finalizer, depends on the implementation. <>= procedure (any_config_final), deferred :: final <>= interface subroutine any_config_final (object) import class(any_config_t), intent(inout) :: object end subroutine any_config_final end interface @ %def any_config_final @ The output is also deferred: <>= procedure (any_config_write), deferred :: write <>= interface subroutine any_config_write (object, unit, indent, verbose) import class(any_config_t), intent(in) :: object integer, intent(in), optional :: unit, indent logical, intent(in), optional :: verbose end subroutine any_config_write end interface @ %def any_config_write @ This is a container for a stable or unstable particle configurator. We need this wrapper for preparing arrays that mix stable and unstable particles. <>= type :: particle_config_t private class(any_config_t), allocatable :: c end type particle_config_t @ %def particle_config_t @ \subsection{Final-State Particle} In theory, for the particle instance we only need to consider the unstable case. However, it is more straightforward to treat configuration and instance on the same footing, and to introduce a wrapper for particle objects as above. <>= type, abstract :: any_t private contains <> end type any_t @ %def any_t @ Finalizer, depends on the implementation. <>= procedure (any_final), deferred :: final <>= interface subroutine any_final (object) import class(any_t), intent(inout) :: object end subroutine any_final end interface @ %def any_final @ The output is also deferred: <>= procedure (any_write), deferred :: write <>= interface subroutine any_write (object, unit, indent) import class(any_t), intent(in) :: object integer, intent(in), optional :: unit, indent end subroutine any_write end interface @ %def any_write @ This is a container for a stable or unstable outgoing particle. We need this wrapper for preparing arrays that mix stable and unstable particles. <>= type :: particle_out_t private class(any_t), allocatable :: c end type particle_out_t @ %def particle_config_t @ \subsection{Decay Term Configuration} A decay term is a distinct final state, corresponding to a process term. Each decay process may give rise to several terms with, possibly, differing flavor content. <>= type :: decay_term_config_t private type(particle_config_t), dimension(:), allocatable :: prt contains <> end type decay_term_config_t @ %def decay_term_config_t @ Finalizer, recursive. <>= procedure :: final => decay_term_config_final <>= recursive subroutine decay_term_config_final (object) class(decay_term_config_t), intent(inout) :: object integer :: i if (allocated (object%prt)) then do i = 1, size (object%prt) if (allocated (object%prt(i)%c)) call object%prt(i)%c%final () end do end if end subroutine decay_term_config_final @ %def decay_term_config_final @ Output, with optional indentation <>= procedure :: write => decay_term_config_write <>= recursive subroutine decay_term_config_write (object, unit, indent, verbose) class(decay_term_config_t), intent(in) :: object integer, intent(in), optional :: unit, indent logical, intent(in), optional :: verbose integer :: i, j, u, ind logical :: verb u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent verb = .true.; if (present (verbose)) verb = verbose call write_indent (u, ind) write (u, "(1x,A)", advance="no") "Final state:" do i = 1, size (object%prt) select type (prt_config => object%prt(i)%c) type is (stable_config_t) write (u, "(1x,A)", advance="no") & char (prt_config%flv(1)%get_name ()) do j = 2, size (prt_config%flv) write (u, "(':',A)", advance="no") & char (prt_config%flv(j)%get_name ()) end do type is (unstable_config_t) write (u, "(1x,A)", advance="no") & char (prt_config%flv%get_name ()) end select end do write (u, *) if (verb) then do i = 1, size (object%prt) call object%prt(i)%c%write (u, ind) end do end if end subroutine decay_term_config_write @ %def decay_term_config_write @ Initialize, given a set of flavors. For each flavor, we must indicate whether the particle is stable. The second index of the flavor array runs over alternatives for each decay product; alternatives are allowed only if the decay product is itself stable. <>= procedure :: init => decay_term_config_init <>= recursive subroutine decay_term_config_init & (term, flv, stable, model, process_stack, var_list) class(decay_term_config_t), intent(out) :: term type(flavor_t), dimension(:,:), intent(in) :: flv logical, dimension(:), intent(in) :: stable class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack type(var_list_t), intent(in), optional :: var_list type(string_t), dimension(:), allocatable :: decay integer :: i allocate (term%prt (size (flv, 1))) do i = 1, size (flv, 1) associate (prt => term%prt(i)) if (stable(i)) then allocate (stable_config_t :: prt%c) else allocate (unstable_config_t :: prt%c) end if select type (prt_config => prt%c) type is (stable_config_t) call prt_config%init (flv(i,:)) type is (unstable_config_t) if (all (flv(i,:) == flv(i,1))) then call prt_config%init (flv(i,1)) call flv(i,1)%get_decays (decay) call prt_config%init_decays & (decay, model, process_stack, var_list) else call prt_config%write () call msg_fatal ("Decay configuration: & &unstable product must be unique") end if end select end associate end do end subroutine decay_term_config_init @ %def decay_term_config_init @ Recursively compute widths and branching ratios for all unstable particles. <>= procedure :: compute => decay_term_config_compute <>= recursive subroutine decay_term_config_compute (term) class(decay_term_config_t), intent(inout) :: term integer :: i do i = 1, size (term%prt) select type (unstable_config => term%prt(i)%c) type is (unstable_config_t) call unstable_config%compute () end select end do end subroutine decay_term_config_compute @ %def decay_term_config_compute @ \subsection{Decay Term} A decay term instance is selected when we generate an event for the associated process instance. When evaluated, it triggers further decays down the chain. Only unstable products are allocated as child particles. <>= type :: decay_term_t private type(decay_term_config_t), pointer :: config => null () type(particle_out_t), dimension(:), allocatable :: particle_out contains <> end type decay_term_t @ %def decay_term_t @ Finalizer. <>= procedure :: final => decay_term_final <>= recursive subroutine decay_term_final (object) class(decay_term_t), intent(inout) :: object integer :: i if (allocated (object%particle_out)) then do i = 1, size (object%particle_out) call object%particle_out(i)%c%final () end do end if end subroutine decay_term_final @ %def decay_term_final @ Output. <>= procedure :: write => decay_term_write <>= recursive subroutine decay_term_write (object, unit, indent) class(decay_term_t), intent(in) :: object integer, intent(in), optional :: unit, indent integer :: i, u, ind u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent call object%config%write (u, ind, verbose = .false.) do i = 1, size (object%particle_out) call object%particle_out(i)%c%write (u, ind) end do end subroutine decay_term_write @ %def decay_term_write @ Recursively write the embedded process instances. <>= procedure :: write_process_instances => decay_term_write_process_instances <>= recursive subroutine decay_term_write_process_instances (term, unit, verbose) class(decay_term_t), intent(in) :: term integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: i do i = 1, size (term%particle_out) select type (unstable => term%particle_out(i)%c) type is (unstable_t) call unstable%write_process_instances (unit, verbose) end select end do end subroutine decay_term_write_process_instances @ %def decay_term_write_process_instances @ Initialization, using the configuration object. We allocate particle objects in parallel to the particle configuration objects which we use to initialize them, one at a time. <>= procedure :: init => decay_term_init <>= recursive subroutine decay_term_init (term, config) class(decay_term_t), intent(out) :: term type(decay_term_config_t), intent(in), target :: config integer :: i term%config => config allocate (term%particle_out (size (config%prt))) do i = 1, size (config%prt) select type (prt_config => config%prt(i)%c) type is (stable_config_t) allocate (stable_t :: term%particle_out(i)%c) select type (stable => term%particle_out(i)%c) type is (stable_t) call stable%init (prt_config) end select type is (unstable_config_t) allocate (unstable_t :: term%particle_out(i)%c) select type (unstable => term%particle_out(i)%c) type is (unstable_t) call unstable%init (prt_config) end select end select end do end subroutine decay_term_init @ %def decay_term_init @ Implement a RNG instance, spawned by the process object. <>= procedure :: make_rng => decay_term_make_rng <>= subroutine decay_term_make_rng (term, process) class(decay_term_t), intent(inout) :: term type(process_t), intent(inout) :: process class(rng_t), allocatable :: rng integer :: i do i = 1, size (term%particle_out) select type (unstable => term%particle_out(i)%c) type is (unstable_t) call process%make_rng (rng) call unstable%import_rng (rng) end select end do end subroutine decay_term_make_rng @ %def decay_term_make_rng @ Link the interactions for unstable decay products to the interaction of the parent process. <>= procedure :: link_interactions => decay_term_link_interactions <>= recursive subroutine decay_term_link_interactions (term, trace) class(decay_term_t), intent(inout) :: term type(interaction_t), intent(in), target :: trace integer :: i do i = 1, size (term%particle_out) select type (unstable => term%particle_out(i)%c) type is (unstable_t) call unstable%link_interactions (i, trace) end select end do end subroutine decay_term_link_interactions @ %def decay_term_link_interactions @ Recursively generate a decay chain, for each of the unstable particles in the final state. <>= procedure :: select_chain => decay_term_select_chain <>= recursive subroutine decay_term_select_chain (term) class(decay_term_t), intent(inout) :: term integer :: i do i = 1, size (term%particle_out) select type (unstable => term%particle_out(i)%c) type is (unstable_t) call unstable%select_chain () end select end do end subroutine decay_term_select_chain @ %def decay_term_select_chain @ Recursively generate a decay event, for each of the unstable particles in the final state. <>= procedure :: generate => decay_term_generate <>= recursive subroutine decay_term_generate (term) class(decay_term_t), intent(inout) :: term integer :: i do i = 1, size (term%particle_out) select type (unstable => term%particle_out(i)%c) type is (unstable_t) call unstable%generate () end select end do end subroutine decay_term_generate @ %def decay_term_generate @ \subsection{Decay Root Configuration} At the root of a decay chain, there is a parent process. The decay root stores a pointer to the parent process and the set of decay configurations. <>= public :: decay_root_config_t <>= type :: decay_root_config_t private type(string_t) :: process_id type(process_t), pointer :: process => null () class(model_data_t), pointer :: model => null () type(decay_term_config_t), dimension(:), allocatable :: term_config contains <> end type decay_root_config_t @ %def decay_root_config_t @ The finalizer is recursive since there may be cascade decays. <>= procedure :: final => decay_root_config_final <>= recursive subroutine decay_root_config_final (object) class(decay_root_config_t), intent(inout) :: object integer :: i if (allocated (object%term_config)) then do i = 1, size (object%term_config) call object%term_config(i)%final () end do end if end subroutine decay_root_config_final @ %def decay_root_config_final @ The output routine is also recursive, and it contains an adjustable indentation. <>= procedure :: write => decay_root_config_write procedure :: write_header => decay_root_config_write_header procedure :: write_terms => decay_root_config_write_terms <>= recursive subroutine decay_root_config_write (object, unit, indent, verbose) class(decay_root_config_t), intent(in) :: object integer, intent(in), optional :: unit, indent logical, intent(in), optional :: verbose integer :: u, ind u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent call write_indent (u, ind) write (u, "(1x,A)") "Final-state decay tree:" call object%write_header (unit, indent) call object%write_terms (unit, indent, verbose) end subroutine decay_root_config_write subroutine decay_root_config_write_header (object, unit, indent) class(decay_root_config_t), intent(in) :: object integer, intent(in), optional :: unit, indent integer :: u, ind u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent call write_indent (u, ind) if (associated (object%process)) then write (u, 3) "process ID =", char (object%process_id), "*" else write (u, 3) "process ID =", char (object%process_id) end if 3 format (3x,A,2(1x,A)) end subroutine decay_root_config_write_header recursive subroutine decay_root_config_write_terms & (object, unit, indent, verbose) class(decay_root_config_t), intent(in) :: object integer, intent(in), optional :: unit, indent logical, intent(in), optional :: verbose integer :: i, u, ind logical :: verb u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent verb = .true.; if (present (verbose)) verb = verbose if (verb .and. allocated (object%term_config)) then do i = 1, size (object%term_config) call object%term_config(i)%write (u, ind + 1) end do end if end subroutine decay_root_config_write_terms @ %def decay_root_config_write @ Initialize for a named process and (optionally) a pre-determined number of terms. <>= procedure :: init => decay_root_config_init <>= subroutine decay_root_config_init (decay, model, process_id, n_terms) class(decay_root_config_t), intent(out) :: decay class(model_data_t), intent(in), target :: model type(string_t), intent(in) :: process_id integer, intent(in), optional :: n_terms decay%model => model decay%process_id = process_id if (present (n_terms)) then allocate (decay%term_config (n_terms)) end if end subroutine decay_root_config_init @ %def decay_root_config_init @ Declare a decay term, given an array of flavors. <>= procedure :: init_term => decay_root_config_init_term <>= recursive subroutine decay_root_config_init_term & (decay, i, flv, stable, model, process_stack, var_list) class(decay_root_config_t), intent(inout) :: decay integer, intent(in) :: i type(flavor_t), dimension(:,:), intent(in) :: flv logical, dimension(:), intent(in) :: stable class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack type(var_list_t), intent(in), optional, target :: var_list call decay%term_config(i)%init (flv, stable, model, process_stack, var_list) end subroutine decay_root_config_init_term @ %def decay_root_config_init_term @ Connect the decay root configuration with a process object (which should represent the parent process). This includes initialization, therefore intent(out). The flavor state is retrieved from the process term object. However, we have to be careful: the flavor object points to the model instance that is stored in the process object. This model instance may not contain the current setting for unstable particles and decay. Therefore, we assign the model directly. If the [[process_instance]] argument is provided, we use this for the flavor state. This applies to the decay root only, where the process can be entangled with a beam setup, and the latter contains beam remnants as further outgoing particles. These must be included in the set of outgoing flavors, since the decay application is also done on the connected state. Infer stability from the particle properties, using the first row in the set of flavor states. For unstable particles, we look for decays, recursively, available from the process stack (if present). For the unstable particles, we have to check whether their masses match between the production and the decay. Fortunately, both versions are available for comparison. The optional [[var_list]] argument may override integral/error values for decay processes. <>= procedure :: connect => decay_root_config_connect <>= recursive subroutine decay_root_config_connect & (decay, process, model, process_stack, process_instance, var_list) class(decay_root_config_t), intent(out) :: decay type(process_t), intent(in), target :: process class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack type(process_instance_t), intent(in), optional, target :: process_instance type(var_list_t), intent(in), optional, target :: var_list type(connected_state_t), pointer :: connected_state type(interaction_t), pointer :: int type(flavor_t), dimension(:,:), allocatable :: flv logical, dimension(:), allocatable :: stable real(default), dimension(:), allocatable :: m_prod, m_dec integer :: i call decay%init (model, process%get_id (), process%get_n_terms ()) do i = 1, size (decay%term_config) if (present (process_instance)) then connected_state => process_instance%get_connected_state_ptr (i) int => connected_state%get_matrix_int_ptr () call int%get_flv_out (flv) else call process%get_term_flv_out (i, flv) end if allocate (m_prod (size (flv(:,1)%get_mass ()))) m_prod = flv(:,1)%get_mass () call flv%set_model (model) allocate (m_dec (size (flv(:,1)%get_mass ()))) m_dec = flv(:,1)%get_mass () allocate (stable (size (flv, 1))) stable = flv(:,1)%is_stable () call check_masses () call decay%init_term (i, flv, stable, model, process_stack, var_list) deallocate (flv, stable, m_prod, m_dec) end do decay%process => process contains subroutine check_masses () integer :: i logical :: ok ok = .true. do i = 1, size (m_prod) if (.not. stable(i)) then if (.not. nearly_equal (m_prod(i), m_dec(i))) then write (msg_buffer, "(A,A,A)") "particle '", & char (flv(i,1)%get_name ()), "':" call msg_message write (msg_buffer, & "(2x,A,1x," // FMT_15 // ",3x,A,1x," // FMT_15 // ")") & "m_prod =", m_prod(i), "m_dec =", m_dec(i) call msg_message ok = .false. end if end if end do if (.not. ok) call msg_fatal & ("Particle mass mismatch between production and decay") end subroutine check_masses end subroutine decay_root_config_connect @ %def decay_root_config_connect @ Recursively compute widths, errors, and branching ratios. <>= procedure :: compute => decay_root_config_compute <>= recursive subroutine decay_root_config_compute (decay) class(decay_root_config_t), intent(inout) :: decay integer :: i do i = 1, size (decay%term_config) call decay%term_config(i)%compute () end do end subroutine decay_root_config_compute @ %def decay_root_config_compute @ \subsection{Decay Root Instance} This is the common parent type for decay and decay root. The process instance points to the parent process. The model pointer is separate because particle settings may be updated w.r.t.\ the parent process object. <>= type, abstract :: decay_gen_t private type(decay_term_t), dimension(:), allocatable :: term type(process_instance_t), pointer :: process_instance => null () integer :: selected_mci = 0 integer :: selected_term = 0 contains <> end type decay_gen_t @ %def decay_gen_t @ The decay root represents the parent process. When an event is generated, the generator selects the term to which the decay chain applies (if possible). The process instance is just a pointer. <>= public :: decay_root_t <>= type, extends (decay_gen_t) :: decay_root_t private type(decay_root_config_t), pointer :: config => null () contains <> end type decay_root_t @ %def decay_root_t @ The finalizer has to recursively finalize the terms, but we can skip the process instance which is not explicitly allocated. <>= procedure :: base_final => decay_gen_final <>= recursive subroutine decay_gen_final (object) class(decay_gen_t), intent(inout) :: object integer :: i if (allocated (object%term)) then do i = 1, size (object%term) call object%term(i)%final () end do end if end subroutine decay_gen_final @ %def decay_gen_final @ No extra finalization for the decay root. <>= procedure :: final => decay_root_final <>= subroutine decay_root_final (object) class(decay_root_t), intent(inout) :: object call object%base_final () end subroutine decay_root_final @ %def decay_gen_final @ Output. <>= procedure :: write => decay_root_write <>= subroutine decay_root_write (object, unit) class(decay_root_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) if (associated (object%config)) then call object%config%write (unit, verbose = .false.) else write (u, "(1x,A)") "Final-state decay tree: [not configured]" end if if (object%selected_mci > 0) then write (u, "(3x,A,I0)") "Selected MCI = ", object%selected_mci else write (u, "(3x,A)") "Selected MCI = [undefined]" end if if (object%selected_term > 0) then write (u, "(3x,A,I0)") "Selected term = ", object%selected_term call object%term(object%selected_term)%write (u, 1) else write (u, "(3x,A)") "Selected term = [undefined]" end if end subroutine decay_root_write @ %def decay_root_write @ Write the process instances, recursively. <>= procedure :: write_process_instances => decay_gen_write_process_instances <>= recursive subroutine decay_gen_write_process_instances (decay, unit, verbose) class(decay_gen_t), intent(in) :: decay integer, intent(in), optional :: unit logical, intent(in), optional :: verbose logical :: verb verb = .true.; if (present (verbose)) verb = verbose if (associated (decay%process_instance)) then if (verb) then call decay%process_instance%write (unit) else call decay%process_instance%write_header (unit) end if end if if (decay%selected_term > 0) then call decay%term(decay%selected_term)%write_process_instances (unit, verb) end if end subroutine decay_gen_write_process_instances @ %def decay_gen_write_process_instances @ Generic initializer. All can be done recursively. <>= procedure :: base_init => decay_gen_init <>= recursive subroutine decay_gen_init (decay, term_config) class(decay_gen_t), intent(out) :: decay type(decay_term_config_t), dimension(:), intent(in), target :: term_config integer :: i allocate (decay%term (size (term_config))) do i = 1, size (decay%term) call decay%term(i)%init (term_config(i)) end do end subroutine decay_gen_init @ %def decay_gen_init @ Specific initializer. We assign the configuration object, which should correspond to a completely initialized decay configuration tree. We also connect to an existing process instance. Then, we recursively link the child interactions to the parent process. <>= procedure :: init => decay_root_init <>= subroutine decay_root_init (decay_root, config, process_instance) class(decay_root_t), intent(out) :: decay_root type(decay_root_config_t), intent(in), target :: config type(process_instance_t), intent(in), target :: process_instance call decay_root%base_init (config%term_config) decay_root%config => config decay_root%process_instance => process_instance call decay_root%make_term_rng (config%process) call decay_root%link_term_interactions () end subroutine decay_root_init @ %def decay_root_init @ Explicitly set/get mci and term indices. (Used in unit test.) <>= procedure :: set_mci => decay_gen_set_mci procedure :: set_term => decay_gen_set_term procedure :: get_mci => decay_gen_get_mci procedure :: get_term => decay_gen_get_term <>= subroutine decay_gen_set_mci (decay, i) class(decay_gen_t), intent(inout) :: decay integer, intent(in) :: i decay%selected_mci = i end subroutine decay_gen_set_mci subroutine decay_gen_set_term (decay, i) class(decay_gen_t), intent(inout) :: decay integer, intent(in) :: i decay%selected_term = i end subroutine decay_gen_set_term function decay_gen_get_mci (decay) result (i) class(decay_gen_t), intent(inout) :: decay integer :: i i = decay%selected_mci end function decay_gen_get_mci function decay_gen_get_term (decay) result (i) class(decay_gen_t), intent(inout) :: decay integer :: i i = decay%selected_term end function decay_gen_get_term @ %def decay_gen_set_mci @ %def decay_gen_set_term @ %def decay_gen_get_mci @ %def decay_gen_get_term @ Implement random-number generators for unstable decay selection in all terms. This is not recursive. We also make use of the fact that [[process]] is a pointer; the (state of the RNG factory inside the) target process will be modified by the rng-spawning method, but not the pointer. <>= procedure :: make_term_rng => decay_gen_make_term_rng <>= subroutine decay_gen_make_term_rng (decay, process) class(decay_gen_t), intent(inout) :: decay type(process_t), intent(in), pointer :: process integer :: i do i = 1, size (decay%term) call decay%term(i)%make_rng (process) end do end subroutine decay_gen_make_term_rng @ %def decay_gen_make_term_rng @ Recursively link interactions of the enclosed decay terms to the corresponding terms in the current process instance. <>= procedure :: link_term_interactions => decay_gen_link_term_interactions <>= recursive subroutine decay_gen_link_term_interactions (decay) class(decay_gen_t), intent(inout) :: decay integer :: i type(interaction_t), pointer :: trace associate (instance => decay%process_instance) do i = 1, size (decay%term) trace => instance%get_trace_int_ptr (i) call decay%term(i)%link_interactions (trace) end do end associate end subroutine decay_gen_link_term_interactions @ %def decay_gen_link_term_interactions @ Select a decay chain: decay modes and process components. <>= procedure :: select_chain => decay_root_select_chain <>= subroutine decay_root_select_chain (decay_root) class(decay_root_t), intent(inout) :: decay_root if (decay_root%selected_term > 0) then call decay_root%term(decay_root%selected_term)%select_chain () else call msg_bug ("Decays: no term selected for parent process") end if end subroutine decay_root_select_chain @ %def decay_root_select_chain @ Generate a decay tree, i.e., for the selected term in the parent process, recursively generate a decay event for all unstable particles. Factor out the trace of the connected state of the parent process. This trace should not be taken into account for unweighting the decay chain, since it was already used for unweighting the parent event, or it determines the overall event weight. <>= procedure :: generate => decay_root_generate <>= subroutine decay_root_generate (decay_root) class(decay_root_t), intent(inout) :: decay_root type(connected_state_t), pointer :: connected_state if (decay_root%selected_term > 0) then connected_state => decay_root%process_instance%get_connected_state_ptr & (decay_root%selected_term) call connected_state%normalize_matrix_by_trace () call decay_root%term(decay_root%selected_term)%generate () else call msg_bug ("Decays: no term selected for parent process") end if end subroutine decay_root_generate @ %def decay_root_generate @ \subsection{Decay Configuration} A decay configuration describes a distinct decay mode of a particle. Each decay mode may include several terms, which correspond to the terms in the associated process. In addition to the base type, the decay configuration object contains the integral of the parent process and the selector for the MCI group inside this process. The flavor component should be identical to the flavor component of the parent particle ([[unstable]] object). <>= type, extends (decay_root_config_t) :: decay_config_t private type(flavor_t) :: flv real(default) :: weight = 0 real(default) :: integral = 0 real(default) :: abs_error = 0 real(default) :: rel_error = 0 type(selector_t) :: mci_selector contains <> end type decay_config_t @ %def decay_config_t @ The output routine extends the decay-root writer by listing numerical component values. <>= procedure :: write => decay_config_write <>= recursive subroutine decay_config_write (object, unit, indent, verbose) class(decay_config_t), intent(in) :: object integer, intent(in), optional :: unit, indent logical, intent(in), optional :: verbose integer :: u, ind u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent call write_indent (u, ind) write (u, "(1x,A)") "Decay:" call object%write_header (unit, indent) call write_indent (u, ind) write (u, 2) "branching ratio =", object%weight * 100 call write_indent (u, ind) write (u, 1) "partial width =", object%integral call write_indent (u, ind) write (u, 1) "error (abs) =", object%abs_error call write_indent (u, ind) write (u, 1) "error (rel) =", object%rel_error 1 format (3x,A,ES19.12) 2 format (3x,A,F11.6,1x,'%') call object%write_terms (unit, indent, verbose) end subroutine decay_config_write @ %def decay_config_write @ Connect a decay configuration with a process object (which should represent the decay). This includes initialization, therefore intent(out). We first connect the process itself, then do initializations that are specific for this decay. Infer stability from the particle properties, using the first row in the set of flavor states. Once we can deal with predetermined decay chains, they should be used instead. If there is an optional [[var_list]], check if the stored values for the decay partial width and error have been overridden there. <>= procedure :: connect => decay_config_connect <>= recursive subroutine decay_config_connect & (decay, process, model, process_stack, process_instance, var_list) class(decay_config_t), intent(out) :: decay type(process_t), intent(in), target :: process class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack type(process_instance_t), intent(in), optional, target :: process_instance type(var_list_t), intent(in), optional, target :: var_list real(default), dimension(:), allocatable :: integral_mci type(string_t) :: process_id integer :: i, n_mci call decay%decay_root_config_t%connect & (process, model, process_stack, var_list=var_list) process_id = process%get_id () if (process%lab_is_cm ()) then call msg_fatal ("Decay process " // char (process_id) & // ": unusable because rest frame is fixed.") end if decay%integral = process%get_integral () decay%abs_error = process%get_error () if (present (var_list)) then call update (decay%integral, "integral(" // process_id // ")") call update (decay%abs_error, "error(" // process_id // ")") end if n_mci = process%get_n_mci () allocate (integral_mci (n_mci)) do i = 1, n_mci integral_mci(i) = process%get_integral_mci (i) end do call decay%mci_selector%init (integral_mci) contains subroutine update (var, var_name) real(default), intent(inout) :: var type(string_t), intent(in) :: var_name if (var_list%contains (var_name)) then var = var_list%get_rval (var_name) end if end subroutine update end subroutine decay_config_connect @ %def decay_config_connect @ Set the flavor entry, which repeats the flavor of the parent unstable particle. <>= procedure :: set_flv => decay_config_set_flv <>= subroutine decay_config_set_flv (decay, flv) class(decay_config_t), intent(inout) :: decay type(flavor_t), intent(in) :: flv decay%flv = flv end subroutine decay_config_set_flv @ %def decay_config_set_flv @ Compute embedded branchings and the relative error. This method does not apply to the decay root. <>= procedure :: compute => decay_config_compute <>= recursive subroutine decay_config_compute (decay) class(decay_config_t), intent(inout) :: decay call decay%decay_root_config_t%compute () if (.not. vanishes (decay%integral)) then decay%rel_error = decay%abs_error / decay%integral else decay%rel_error = 0 end if end subroutine decay_config_compute @ %def decay_config_compute @ \subsection{Decay Instance} The decay contains a collection of terms. One of them is selected when the decay is evaluated. This is similar to the decay root, but we implement it independently. The process instance object is allocated via a pointer, so it automatically behaves as a target. <>= type, extends (decay_gen_t) :: decay_t private type(decay_config_t), pointer :: config => null () class(rng_t), allocatable :: rng contains <> end type decay_t @ %def decay_t @ The finalizer is recursive. <>= procedure :: final => decay_final <>= recursive subroutine decay_final (object) class(decay_t), intent(inout) :: object integer :: i call object%base_final () do i = 1, object%config%process%get_n_mci () call object%process_instance%final_simulation (i) end do call object%process_instance%final () deallocate (object%process_instance) end subroutine decay_final @ %def decay_final @ Output. <>= procedure :: write => decay_write <>= recursive subroutine decay_write (object, unit, indent, recursive) class(decay_t), intent(in) :: object integer, intent(in), optional :: unit, indent, recursive integer :: u, ind u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent call object%config%write (unit, indent, verbose = .false.) if (allocated (object%rng)) then call object%rng%write (u, ind + 1) end if call write_indent (u, ind) if (object%selected_mci > 0) then write (u, "(3x,A,I0)") "Selected MCI = ", object%selected_mci else write (u, "(3x,A)") "Selected MCI = [undefined]" end if call write_indent (u, ind) if (object%selected_term > 0) then write (u, "(3x,A,I0)") "Selected term = ", object%selected_term call object%term(object%selected_term)%write (u, ind + 1) else write (u, "(3x,A)") "Selected term = [undefined]" end if end subroutine decay_write @ %def decay_write @ Initializer. Base initialization is done recursively. Then, we prepare the current process instance and allocate a random-number generator for term selection. For all unstable particles, we also allocate a r.n.g. as spawned by the current process. <>= procedure :: init => decay_init <>= recursive subroutine decay_init (decay, config) class(decay_t), intent(out) :: decay type(decay_config_t), intent(in), target :: config integer :: i call decay%base_init (config%term_config) decay%config => config allocate (decay%process_instance) call decay%process_instance%init (decay%config%process) call decay%process_instance%setup_event_data (decay%config%model) do i = 1, decay%config%process%get_n_mci () call decay%process_instance%init_simulation (i) end do call decay%config%process%make_rng (decay%rng) call decay%make_term_rng (decay%config%process) end subroutine decay_init @ %def decay_init @ Link interactions to the parent process. [[i_prt]] is the index of the current outgoing particle in the parent interaction, for which we take the trace evaluator. We link it to the beam particle in the beam interaction of the decay process instance. Then, repeat the procedure for the outgoing particles. <>= procedure :: link_interactions => decay_link_interactions <>= recursive subroutine decay_link_interactions (decay, i_prt, trace) class(decay_t), intent(inout) :: decay integer, intent(in) :: i_prt type(interaction_t), intent(in), target :: trace type(interaction_t), pointer :: beam_int integer :: n_in, n_vir beam_int => decay%process_instance%get_beam_int_ptr () n_in = trace%get_n_in () n_vir = trace%get_n_vir () call beam_int%set_source_link (1, trace, & n_in + n_vir + i_prt) call decay%link_term_interactions () end subroutine decay_link_interactions @ %def decay_link_interactions @ Determine a decay chain. For each unstable particle we select one of the possible decay modes, and for each decay process we select one of the possible decay MCI components, calling the random-number generators. We do not generate momenta, yet. <>= procedure :: select_chain => decay_select_chain <>= recursive subroutine decay_select_chain (decay) class(decay_t), intent(inout) :: decay real(default) :: x integer :: i call decay%rng%generate (x) decay%selected_mci = decay%config%mci_selector%select (x) call decay%process_instance%choose_mci (decay%selected_mci) decay%selected_term = decay%process_instance%select_i_term () do i = 1, size (decay%term) call decay%term(i)%select_chain () end do end subroutine decay_select_chain @ %def decay_select_chain @ Generate a decay. We first receive the beam momenta from the parent process (assuming that this is properly linked), then call the associated process object for a new event. Factor out the trace of the helicity density matrix of the isolated state (the one that will be used for the decay chain). The trace is taken into account for unweighting the individual decay event and should therefore be ignored for unweighting the correlated decay chain afterwards. <>= procedure :: generate => decay_generate <>= recursive subroutine decay_generate (decay) class(decay_t), intent(inout) :: decay type(isolated_state_t), pointer :: isolated_state integer :: i call decay%process_instance%receive_beam_momenta () call decay%process_instance%generate_unweighted_event (decay%selected_mci) if (signal_is_pending ()) return call decay%process_instance%evaluate_event_data () isolated_state => & decay%process_instance%get_isolated_state_ptr (decay%selected_term) call isolated_state%normalize_matrix_by_trace () do i = 1, size (decay%term) call decay%term(i)%generate () if (signal_is_pending ()) return end do end subroutine decay_generate @ %def decay_generate @ \subsection{Stable Particles} This is a stable particle. The flavor can be ambiguous (e.g., partons). <>= type, extends (any_config_t) :: stable_config_t private type(flavor_t), dimension(:), allocatable :: flv contains <> end type stable_config_t @ %def stable_config_t @ The finalizer is empty: <>= procedure :: final => stable_config_final <>= subroutine stable_config_final (object) class(stable_config_t), intent(inout) :: object end subroutine stable_config_final @ %def stable_config_final @ Output. <>= procedure :: write => stable_config_write <>= recursive subroutine stable_config_write (object, unit, indent, verbose) class(stable_config_t), intent(in) :: object integer, intent(in), optional :: unit, indent logical, intent(in), optional :: verbose integer :: u, i, ind u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent call write_indent (u, ind) write (u, "(1x,'+',1x,A)", advance = "no") "Stable:" write (u, "(1x,A)", advance = "no") char (object%flv(1)%get_name ()) do i = 2, size (object%flv) write (u, "(':',A)", advance = "no") & char (object%flv(i)%get_name ()) end do write (u, *) end subroutine stable_config_write @ %def stable_config_write @ Initializer. We are presented with an array of flavors, but there may be double entries which we remove, so we store only the distinct flavors. <>= procedure :: init => stable_config_init <>= subroutine stable_config_init (config, flv) class(stable_config_t), intent(out) :: config type(flavor_t), dimension(:), intent(in) :: flv integer, dimension (size (flv)) :: pdg logical, dimension (size (flv)) :: mask integer :: i pdg = flv%get_pdg () mask(1) = .true. forall (i = 2 : size (pdg)) mask(i) = all (pdg(i) /= pdg(1:i-1)) end forall allocate (config%flv (count (mask))) config%flv = pack (flv, mask) end subroutine stable_config_init @ %def stable_config_init @ Here is the corresponding object instance. Except for the pointer to the configuration, there is no content. <>= type, extends (any_t) :: stable_t private type(stable_config_t), pointer :: config => null () contains <> end type stable_t @ %def stable_t @ The finalizer does nothing. <>= procedure :: final => stable_final <>= subroutine stable_final (object) class(stable_t), intent(inout) :: object end subroutine stable_final @ %def stable_final @ We can delegate output to the configuration object. <>= procedure :: write => stable_write <>= subroutine stable_write (object, unit, indent) class(stable_t), intent(in) :: object integer, intent(in), optional :: unit, indent call object%config%write (unit, indent) end subroutine stable_write @ %def stable_write @ Initializer: just assign the configuration. <>= procedure :: init => stable_init <>= subroutine stable_init (stable, config) class(stable_t), intent(out) :: stable type(stable_config_t), intent(in), target :: config stable%config => config end subroutine stable_init @ %def stable_init @ \subsection{Unstable Particles} A branching configuration enables us to select among distinct decay modes of a particle. We store the particle flavor (with its implicit link to a model), an array of decay configurations, and a selector object. The total width, absolute and relative error are stored as [[integral]], [[abs_error]], and [[rel_error]], respectively. The flavor must be unique in this case. <>= public :: unstable_config_t <>= type, extends (any_config_t) :: unstable_config_t private type(flavor_t) :: flv real(default) :: integral = 0 real(default) :: abs_error = 0 real(default) :: rel_error = 0 type(selector_t) :: selector type(decay_config_t), dimension(:), allocatable :: decay_config contains <> end type unstable_config_t @ %def unstable_config_t @ Finalizer. The branching configuration can be a recursive structure. <>= procedure :: final => unstable_config_final <>= recursive subroutine unstable_config_final (object) class(unstable_config_t), intent(inout) :: object integer :: i if (allocated (object%decay_config)) then do i = 1, size (object%decay_config) call object%decay_config(i)%final () end do end if end subroutine unstable_config_final @ %def unstable_config_final @ Output. Since this may be recursive, we include indentation. <>= procedure :: write => unstable_config_write <>= recursive subroutine unstable_config_write (object, unit, indent, verbose) class(unstable_config_t), intent(in) :: object integer, intent(in), optional :: unit, indent logical, intent(in), optional :: verbose integer :: u, i, ind logical :: verb u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent verb = .true.; if (present (verbose)) verb = verbose call write_indent (u, ind) write (u, "(1x,'+',1x,A,1x,A)") "Unstable:", & char (object%flv%get_name ()) call write_indent (u, ind) write (u, 1) "total width =", object%integral call write_indent (u, ind) write (u, 1) "error (abs) =", object%abs_error call write_indent (u, ind) write (u, 1) "error (rel) =", object%rel_error 1 format (5x,A,ES19.12) if (verb .and. allocated (object%decay_config)) then do i = 1, size (object%decay_config) call object%decay_config(i)%write (u, ind + 1) end do end if end subroutine unstable_config_write @ %def unstable_config_write @ Initializer. For the unstable particle, the flavor is unique. <>= procedure :: init => unstable_config_init <>= subroutine unstable_config_init (unstable, flv, set_decays, model) class(unstable_config_t), intent(out) :: unstable type(flavor_t), intent(in) :: flv logical, intent(in), optional :: set_decays class(model_data_t), intent(in), optional, target :: model type(string_t), dimension(:), allocatable :: decay unstable%flv = flv if (present (set_decays)) then call unstable%flv%get_decays (decay) call unstable%init_decays (decay, model) end if end subroutine unstable_config_init @ %def unstable_config_init @ Further initialization: determine the number of decay modes. We can assume that the flavor of the particle has been set already. If the process stack is given, we can delve recursively into actually assigning decay processes. Otherwise, we just initialize with decay process names. <>= procedure :: init_decays => unstable_config_init_decays <>= recursive subroutine unstable_config_init_decays & (unstable, decay_id, model, process_stack, var_list) class(unstable_config_t), intent(inout) :: unstable type(string_t), dimension(:), intent(in) :: decay_id class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack type(var_list_t), intent(in), optional :: var_list integer :: i allocate (unstable%decay_config (size (decay_id))) do i = 1, size (decay_id) associate (decay => unstable%decay_config(i)) if (present (process_stack)) then call decay%connect (process_stack%get_process_ptr (decay_id(i)), & model, process_stack, var_list=var_list) else call decay%init (model, decay_id(i)) end if call decay%set_flv (unstable%flv) end associate end do end subroutine unstable_config_init_decays @ %def unstable_config_init @ Explicitly connect a specific decay with a process. This is used only in unit tests. <>= procedure :: connect_decay => unstable_config_connect_decay <>= subroutine unstable_config_connect_decay (unstable, i, process, model) class(unstable_config_t), intent(inout) :: unstable integer, intent(in) :: i type(process_t), intent(in), target :: process class(model_data_t), intent(in), target :: model associate (decay => unstable%decay_config(i)) call decay%connect (process, model) end associate end subroutine unstable_config_connect_decay @ %def unstable_config_connect_decay @ Compute the total width and branching ratios, initializing the decay selector. <>= procedure :: compute => unstable_config_compute <>= recursive subroutine unstable_config_compute (unstable) class(unstable_config_t), intent(inout) :: unstable integer :: i do i = 1, size (unstable%decay_config) call unstable%decay_config(i)%compute () end do unstable%integral = sum (unstable%decay_config%integral) if (unstable%integral <= 0) then call unstable%write () call msg_fatal ("Decay configuration: computed total width is zero") end if unstable%abs_error = sqrt (sum (unstable%decay_config%abs_error ** 2)) unstable%rel_error = unstable%abs_error / unstable%integral call unstable%selector%init (unstable%decay_config%integral) do i = 1, size (unstable%decay_config) unstable%decay_config(i)%weight & = unstable%selector%get_weight (i) end do end subroutine unstable_config_compute @ %def unstable_config_compute @ Now we define the instance of an unstable particle. <>= public :: unstable_t <>= type, extends (any_t) :: unstable_t private type(unstable_config_t), pointer :: config => null () class(rng_t), allocatable :: rng integer :: selected_decay = 0 type(decay_t), dimension(:), allocatable :: decay contains <> end type unstable_t @ %def unstable_t @ Recursive finalizer. <>= procedure :: final => unstable_final <>= recursive subroutine unstable_final (object) class(unstable_t), intent(inout) :: object integer :: i if (allocated (object%decay)) then do i = 1, size (object%decay) call object%decay(i)%final () end do end if end subroutine unstable_final @ %def unstable_final @ Output. <>= procedure :: write => unstable_write <>= recursive subroutine unstable_write (object, unit, indent) class(unstable_t), intent(in) :: object integer, intent(in), optional :: unit, indent integer :: u, ind u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent call object%config%write (u, ind, verbose=.false.) if (allocated (object%rng)) then call object%rng%write (u, ind + 2) end if call write_indent (u, ind) if (object%selected_decay > 0) then write (u, "(5x,A,I0)") "Sel. decay = ", object%selected_decay call object%decay(object%selected_decay)%write (u, ind + 1) else write (u, "(5x,A)") "Sel. decay = [undefined]" end if end subroutine unstable_write @ %def unstable_write @ Write the embedded process instances. <>= procedure :: write_process_instances => unstable_write_process_instances <>= recursive subroutine unstable_write_process_instances & (unstable, unit, verbose) class(unstable_t), intent(in) :: unstable integer, intent(in), optional :: unit logical, intent(in), optional :: verbose if (unstable%selected_decay > 0) then call unstable%decay(unstable%selected_decay)% & write_process_instances (unit, verbose) end if end subroutine unstable_write_process_instances @ %def unstable_write_process_instances @ Initialization, using the configuration object. <>= procedure :: init => unstable_init <>= recursive subroutine unstable_init (unstable, config) class(unstable_t), intent(out) :: unstable type(unstable_config_t), intent(in), target :: config integer :: i unstable%config => config allocate (unstable%decay (size (config%decay_config))) do i = 1, size (config%decay_config) call unstable%decay(i)%init (config%decay_config(i)) end do end subroutine unstable_init @ %def unstable_init @ Recursively link interactions to the parent process. [[i_prt]] is the index of the current outgoing particle in the parent interaction. <>= procedure :: link_interactions => unstable_link_interactions <>= recursive subroutine unstable_link_interactions (unstable, i_prt, trace) class(unstable_t), intent(inout) :: unstable integer, intent(in) :: i_prt type(interaction_t), intent(in), target :: trace integer :: i do i = 1, size (unstable%decay) call unstable%decay(i)%link_interactions (i_prt, trace) end do end subroutine unstable_link_interactions @ %def unstable_link_interactions @ Import the random-number generator state. <>= procedure :: import_rng => unstable_import_rng <>= subroutine unstable_import_rng (unstable, rng) class(unstable_t), intent(inout) :: unstable class(rng_t), intent(inout), allocatable :: rng call move_alloc (from = rng, to = unstable%rng) end subroutine unstable_import_rng @ %def unstable_import_rng @ Generate a decay chain. First select a decay mode, then call the [[select_chain]] method of the selected mode. <>= procedure :: select_chain => unstable_select_chain <>= recursive subroutine unstable_select_chain (unstable) class(unstable_t), intent(inout) :: unstable real(default) :: x call unstable%rng%generate (x) unstable%selected_decay = unstable%config%selector%select (x) call unstable%decay(unstable%selected_decay)%select_chain () end subroutine unstable_select_chain @ %def unstable_select_chain @ Generate a decay event. <>= procedure :: generate => unstable_generate <>= recursive subroutine unstable_generate (unstable) class(unstable_t), intent(inout) :: unstable call unstable%decay(unstable%selected_decay)%generate () end subroutine unstable_generate @ %def unstable_generate @ \subsection{Decay Chain} While the decay configuration tree and the decay tree are static entities (during a simulation run), the decay chain is dynamically generated for each event. The reason is that with the possibility of several decay modes for each particle, and several terms for each process, the total number of distinct decay chains is not under control. Each entry in the decay chain is a connected parton state. The origin of the chain is a connected state in the parent process (not part of the chain itself). For each decay, mode and term chosen, we convolute this with the isolated (!) state of the current decay, to generate a new connected state. We accumulate this chain by recursively traversing the allocated decay tree. Whenever a particle decays, it becomes virtual and is replaced by its decay product, while all other particles stay in the parton state as spectators. Technically, we implement the decay chain as a stack structure and include information from the associated decay object for easier debugging. This is a decay chain entry: <>= type, extends (connected_state_t) :: decay_chain_entry_t private integer :: index = 0 type(decay_config_t), pointer :: config => null () integer :: selected_mci = 0 integer :: selected_term = 0 type(decay_chain_entry_t), pointer :: previous => null () end type decay_chain_entry_t @ %def decay_chain_entry_t @ This is the complete chain; we need just a pointer to the last entry. We also include a pointer to the master process instance, which serves as the seed for the decay chain. The evaluator [[correlated_trace]] traces over all quantum numbers for the final spin-correlated (but color-summed) evaluator of the decay chain. This allows us to compute the probability for a momentum configuration, given that all individual density matrices (of the initial process and the subsequent decays) have been normalized to one. Note: This trace is summed over color, so color is treated exactly when computing spin correlations. However, we do not keep non-diagonal color correlations. When an event is accepted, we compute probabilities for all color states and can choose one of them. <>= public :: decay_chain_t <>= type :: decay_chain_t private type(process_instance_t), pointer :: process_instance => null () integer :: selected_term = 0 type(evaluator_t) :: correlated_trace type(decay_chain_entry_t), pointer :: last => null () contains <> end type decay_chain_t @ %def decay_chain_t @ The finalizer recursively deletes and deallocates the entries. <>= procedure :: final => decay_chain_final <>= subroutine decay_chain_final (object) class(decay_chain_t), intent(inout) :: object type(decay_chain_entry_t), pointer :: entry do while (associated (object%last)) entry => object%last object%last => entry%previous call entry%final () deallocate (entry) end do call object%correlated_trace%final () end subroutine decay_chain_final @ %def decay_chain_final @ Doing output recursively allows us to display the chain in chronological order. <>= procedure :: write => decay_chain_write <>= subroutine decay_chain_write (object, unit) class(decay_chain_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) call write_separator (u, 2) write (u, "(1x,A)") "Decay chain:" call write_entries (object%last) call write_separator (u, 2) write (u, "(1x,A)") "Evaluator (correlated trace of the decay chain):" call write_separator (u) call object%correlated_trace%write (u) call write_separator (u, 2) contains recursive subroutine write_entries (entry) type(decay_chain_entry_t), intent(in), pointer :: entry if (associated (entry)) then call write_entries (entry%previous) call write_separator (u, 2) write (u, "(1x,A,I0)") "Decay #", entry%index call entry%config%write_header (u) write (u, "(3x,A,I0)") "Selected MCI = ", entry%selected_mci write (u, "(3x,A,I0)") "Selected term = ", entry%selected_term call entry%config%term_config(entry%selected_term)%write (u, indent=1) call entry%write (u) end if end subroutine write_entries end subroutine decay_chain_write @ %def decay_chain_write @ Build a decay chain, recursively following the selected decays and terms in a decay tree. Before start, we finalize the chain, deleting any previous contents. <>= procedure :: build => decay_chain_build <>= subroutine decay_chain_build (chain, decay_root) class(decay_chain_t), intent(inout), target :: chain type(decay_root_t), intent(in) :: decay_root type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask type(interaction_t), pointer :: int_last_decay call chain%final () if (decay_root%selected_term > 0) then chain%process_instance => decay_root%process_instance chain%selected_term = decay_root%selected_term call chain%build_term_entries (decay_root%term(decay_root%selected_term)) end if int_last_decay => chain%last%get_matrix_int_ptr () allocate (qn_mask (int_last_decay%get_n_tot ())) call qn_mask%init (mask_f = .true., mask_c = .true., mask_h = .true.) call chain%correlated_trace%init_qn_sum (int_last_decay, qn_mask) end subroutine decay_chain_build @ %def decay_chain_build @ Build the entries that correspond to a decay term. We have to scan all unstable particles. <>= procedure :: build_term_entries => decay_chain_build_term_entries <>= recursive subroutine decay_chain_build_term_entries (chain, term) class(decay_chain_t), intent(inout) :: chain type(decay_term_t), intent(in) :: term integer :: i do i = 1, size (term%particle_out) select type (unstable => term%particle_out(i)%c) type is (unstable_t) if (unstable%selected_decay > 0) then call chain%build_decay_entries & (unstable%decay(unstable%selected_decay)) end if end select end do end subroutine decay_chain_build_term_entries @ %def decay_chain_build_term_entries @ Build the entries that correspond to a specific decay. The decay term should have been determined, so we allocate a decay chain entry and fill it, then proceed to child decays. For the first entry, we convolute the connected state of the parent process instance with the isolated state of the current decay (which does not contain an extra beam entry for the parent). For subsequent entries, we take the previous entry as first factor. In principle, each chain entry (as a parton state) is capable of holding a subevent object and associated expressions. We currently do not make use of that feature. Before generating the decays, factor out the trace of the helicity density matrix of the parent parton state. This trace has been used for unweighting the original event (unweighted case) or it determines the overall weight, so it should not be taken into account in the decay chain generation. <>= procedure :: build_decay_entries => decay_chain_build_decay_entries <>= recursive subroutine decay_chain_build_decay_entries (chain, decay) class(decay_chain_t), intent(inout) :: chain type(decay_t), intent(in) :: decay type(decay_chain_entry_t), pointer :: entry type(connected_state_t), pointer :: previous_state type(isolated_state_t), pointer :: current_decay type(helicity_t) :: hel type(quantum_numbers_t) :: qn_filter_conn allocate (entry) if (associated (chain%last)) then entry%previous => chain%last entry%index = entry%previous%index + 1 previous_state => entry%previous%connected_state_t else entry%index = 1 previous_state => & chain%process_instance%get_connected_state_ptr (chain%selected_term) end if entry%config => decay%config entry%selected_mci = decay%selected_mci entry%selected_term = decay%selected_term current_decay => decay%process_instance%get_isolated_state_ptr & (decay%selected_term) call entry%setup_connected_trace & (current_decay, previous_state%get_trace_int_ptr (), resonant=.true.) if (entry%config%flv%has_decay_helicity ()) then call hel%init (entry%config%flv%get_decay_helicity ()) call qn_filter_conn%init (hel) call entry%setup_connected_matrix & (current_decay, previous_state%get_matrix_int_ptr (), & resonant=.true., qn_filter_conn = qn_filter_conn) call entry%setup_connected_flows & (current_decay, previous_state%get_flows_int_ptr (), & resonant=.true., qn_filter_conn = qn_filter_conn) else call entry%setup_connected_matrix & (current_decay, previous_state%get_matrix_int_ptr (), & resonant=.true.) call entry%setup_connected_flows & (current_decay, previous_state%get_flows_int_ptr (), & resonant=.true.) end if chain%last => entry call chain%build_term_entries (decay%term(decay%selected_term)) end subroutine decay_chain_build_decay_entries @ %def decay_chain_build_decay_entries @ Recursively fill the decay chain with momenta and evaluate the matrix elements. Since all evaluators should have correct source entries at this point, momenta are automatically retrieved from the appropriate process instance. Like we did above for the parent process, factor out the trace for each subsequent decay (the helicity density matrix in the isolated state, which is taken for the convolution). <>= procedure :: evaluate => decay_chain_evaluate <>= subroutine decay_chain_evaluate (chain) class(decay_chain_t), intent(inout) :: chain call evaluate (chain%last) call chain%correlated_trace%receive_momenta () call chain%correlated_trace%evaluate () contains recursive subroutine evaluate (entry) type(decay_chain_entry_t), intent(inout), pointer :: entry if (associated (entry)) then call evaluate (entry%previous) call entry%receive_kinematics () call entry%evaluate_trace () call entry%evaluate_event_data () end if end subroutine evaluate end subroutine decay_chain_evaluate @ %def decay_chain_evaluate @ Return the probability of a decay chain. This is given as the trace of the density matrix with intermediate helicity correlations, normalized by the product of the uncorrelated density matrix traces. This works only if an event has been evaluated and the [[correlated_trace]] evaluator is filled. By definition, this evaluator has only one matrix element, and this must be real. <>= procedure :: get_probability => decay_chain_get_probability <>= function decay_chain_get_probability (chain) result (x) class(decay_chain_t), intent(in) :: chain real(default) :: x x = real (chain%correlated_trace%get_matrix_element (1)) end function decay_chain_get_probability @ %def decay_chain_get_probability @ \subsection{Decay as Event Transform} The [[evt_decay]] object combines decay configuration, decay tree, and chain in a single object, as an implementation of the [[evt]] (event transform) abstract type. The [[var_list]] may be a pointer to the user variable list, which could contain overridden parameters for the decay processes. <>= public :: evt_decay_t <>= type, extends (evt_t) :: evt_decay_t private type(decay_root_config_t) :: decay_root_config type(decay_root_t) :: decay_root type(decay_chain_t) :: decay_chain type(var_list_t), pointer :: var_list => null () contains <> end type evt_decay_t @ %def evt_decay_t @ <>= procedure :: write_name => evt_decay_write_name <>= subroutine evt_decay_write_name (evt, unit) class(evt_decay_t), intent(in) :: evt integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Event transform: partonic decays" end subroutine evt_decay_write_name @ %def evt_decay_write_name @ Output. We display the currently selected decay tree, which includes configuration data, and the decay chain, i.e., the evaluators. <>= procedure :: write => evt_decay_write <>= subroutine evt_decay_write (evt, unit, verbose, more_verbose, testflag) class(evt_decay_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, more_verbose, testflag logical :: verb, verb2 integer :: u u = given_output_unit (unit) verb = .true.; if (present (verbose)) verb = verbose verb2 = .false.; if (present (more_verbose)) verb2 = more_verbose call write_separator (u, 2) call evt%write_name (u) call write_separator (u, 2) call evt%base_write (u, testflag = testflag) if (associated (evt%var_list)) then call write_separator (u) write (u, "(1x,A)") "Variable list for simulation: & &[associated, not shown]" end if if (verb) then call write_separator (u) call evt%decay_root%write (u) if (verb2) then call evt%decay_chain%write (u) call evt%decay_root%write_process_instances (u, verb) end if else call write_separator (u, 2) end if end subroutine evt_decay_write @ %def evt_decay_write @ Set the pointer to a user variable list. <>= procedure :: set_var_list => evt_decay_set_var_list <>= subroutine evt_decay_set_var_list (evt, var_list) class(evt_decay_t), intent(inout) :: evt type(var_list_t), intent(in), target :: var_list evt%var_list => var_list end subroutine evt_decay_set_var_list @ %def evt_decay_set_var_list @ Connect with a process instance and process. This initializes the decay configuration. The process stack is used to look for process objects that implement daughter decays. When all processes are assigned, configure the decay tree instance, using the decay tree configuration. First obtain the branching ratios, then allocate the decay tree. This is done once for all events. <>= procedure :: connect => evt_decay_connect <>= subroutine evt_decay_connect (evt, process_instance, model, process_stack) class(evt_decay_t), intent(inout), target :: evt type(process_instance_t), intent(in), target :: process_instance class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack call evt%base_connect (process_instance, model) if (associated (evt%var_list)) then call evt%decay_root_config%connect (process_instance%process, & model, process_stack, process_instance, evt%var_list) else call evt%decay_root_config%connect (process_instance%process, & model, process_stack, process_instance) end if call evt%decay_root_config%compute () call evt%decay_root%init (evt%decay_root_config, evt%process_instance) end subroutine evt_decay_connect @ %def evt_decay_connect @ Prepare a new event: Select a decay chain and build the corresponding chain object. <>= procedure :: prepare_new_event => evt_decay_prepare_new_event <>= subroutine evt_decay_prepare_new_event (evt, i_mci, i_term) class(evt_decay_t), intent(inout) :: evt integer, intent(in) :: i_mci, i_term call evt%reset () evt%decay_root%selected_mci = i_mci evt%decay_root%selected_term = i_term call evt%decay_root%select_chain () call evt%decay_chain%build (evt%decay_root) end subroutine evt_decay_prepare_new_event @ %def evt_decay_prepare_new_event @ Generate a weighted event and assign the resulting weight (probability). We use a chain initialized by the preceding subroutine, fill it with momenta and evaluate. <>= procedure :: generate_weighted => evt_decay_generate_weighted <>= subroutine evt_decay_generate_weighted (evt, probability) class(evt_decay_t), intent(inout) :: evt real(default), intent(inout) :: probability call evt%decay_root%generate () if (signal_is_pending ()) return call evt%decay_chain%evaluate () probability = evt%decay_chain%get_probability () end subroutine evt_decay_generate_weighted @ %def evt_decay_generate_weighted @ To create a usable event, we have to transform the interaction into a particle set; this requires factorization for the correlated density matrix, according to the factorization mode. <>= procedure :: make_particle_set => evt_decay_make_particle_set <>= subroutine evt_decay_make_particle_set & (evt, factorization_mode, keep_correlations, r) class(evt_decay_t), intent(inout) :: evt integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r type(interaction_t), pointer :: int_matrix, int_flows type(decay_chain_entry_t), pointer :: last_entry last_entry => evt%decay_chain%last int_matrix => last_entry%get_matrix_int_ptr () int_flows => last_entry%get_flows_int_ptr () call evt%factorize_interactions (int_matrix, int_flows, & factorization_mode, keep_correlations, r) call evt%tag_incoming () end subroutine evt_decay_make_particle_set @ %def event_decay_make_particle_set @ \subsubsection{Auxiliary} Eliminate numerical noise for the associated process instances. <>= public :: pacify <>= interface pacify module procedure pacify_decay module procedure pacify_decay_gen module procedure pacify_term module procedure pacify_unstable end interface pacify <>= subroutine pacify_decay (evt) class(evt_decay_t), intent(inout) :: evt call pacify_decay_gen (evt%decay_root) end subroutine pacify_decay recursive subroutine pacify_decay_gen (decay) class(decay_gen_t), intent(inout) :: decay if (associated (decay%process_instance)) then call pacify (decay%process_instance) end if if (decay%selected_term > 0) then call pacify_term (decay%term(decay%selected_term)) end if end subroutine pacify_decay_gen recursive subroutine pacify_term (term) class(decay_term_t), intent(inout) :: term integer :: i do i = 1, size (term%particle_out) select type (unstable => term%particle_out(i)%c) type is (unstable_t); call pacify_unstable (unstable) end select end do end subroutine pacify_term recursive subroutine pacify_unstable (unstable) class(unstable_t), intent(inout) :: unstable if (unstable%selected_decay > 0) then call pacify_decay_gen (unstable%decay(unstable%selected_decay)) end if end subroutine pacify_unstable @ %def pacify @ Prepare specific configurations for use in unit tests. <>= procedure :: init_test_case1 procedure :: init_test_case2 <>= subroutine init_test_case1 (unstable, i, flv, integral, relerr, model) class(unstable_config_t), intent(inout) :: unstable integer, intent(in) :: i type(flavor_t), dimension(:,:), intent(in) :: flv real(default), intent(in) :: integral real(default), intent(in) :: relerr class(model_data_t), intent(in), target :: model associate (decay => unstable%decay_config(i)) allocate (decay%term_config (1)) call decay%init_term (1, flv, stable = [.true., .true.], model=model) decay%integral = integral decay%abs_error = integral * relerr end associate end subroutine init_test_case1 subroutine init_test_case2 (unstable, flv1, flv21, flv22, model) class(unstable_config_t), intent(inout) :: unstable type(flavor_t), dimension(:,:), intent(in) :: flv1, flv21, flv22 class(model_data_t), intent(in), target :: model associate (decay => unstable%decay_config(1)) decay%integral = 1.e-3_default decay%abs_error = decay%integral * .01_default allocate (decay%term_config (1)) call decay%init_term (1, flv1, stable = [.false., .true.], model=model) select type (w => decay%term_config(1)%prt(1)%c) type is (unstable_config_t) associate (w_decay => w%decay_config(1)) w_decay%integral = 2._default allocate (w_decay%term_config (1)) call w_decay%init_term (1, flv21, stable = [.true., .true.], & model=model) end associate associate (w_decay => w%decay_config(2)) w_decay%integral = 1._default allocate (w_decay%term_config (1)) call w_decay%init_term (1, flv22, stable = [.true., .true.], & model=model) end associate call w%compute () end select end associate end subroutine init_test_case2 @ %def init_test_case1 @ %def init_test_case2 @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[decays_ut.f90]]>>= <> module decays_ut use unit_tests use decays_uti <> <> <> contains <> end module decays_ut @ %def decays_ut @ <<[[decays_uti.f90]]>>= <> module decays_uti <> <> use os_interface use sm_qcd use model_data use models use state_matrices, only: FM_IGNORE_HELICITY use interactions, only: reset_interaction_counter use flavors use process_libraries use rng_base use mci_base use mci_midpoint use phs_base use phs_single use prc_core use prc_test, only: prc_test_create_library use process, only: process_t use instances, only: process_instance_t use process_stacks use decays use rng_base_ut, only: rng_test_t, rng_test_factory_t <> <> <> contains <> <> end module decays_uti @ %def decays_uti @ API: driver for the unit tests below. <>= public :: decays_test <>= subroutine decays_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine decays_test @ %def decays_test @ \subsubsection{Testbed} As a variation of the [[prepare_test_process]] routine used elsewhere, we define here a routine that creates two processes (scattering $ss\to ss$ and decay $s\to f\bar f$), compiles and integrates them and prepares for event generation. <>= public :: prepare_testbed <>= subroutine prepare_testbed & (lib, process_stack, prefix, os_data, & scattering, decay, decay_rest_frame) type(process_library_t), intent(out), target :: lib type(process_stack_t), intent(out) :: process_stack type(string_t), intent(in) :: prefix type(os_data_t), intent(in) :: os_data logical, intent(in) :: scattering, decay logical, intent(in), optional :: decay_rest_frame type(model_t), target :: model type(model_t), target :: model_copy type(string_t) :: libname, procname1, procname2 type(process_entry_t), pointer :: process type(process_instance_t), allocatable, target :: process_instance class(phs_config_t), allocatable :: phs_config_template type(field_data_t), pointer :: field_data real(default) :: sqrts libname = prefix // "_lib" procname1 = prefix // "_p" procname2 = prefix // "_d" call model%init_test () call model%set_par (var_str ("ff"), 0.4_default) call model%set_par (var_str ("mf"), & model%get_real (var_str ("ff")) * model%get_real (var_str ("ms"))) if (scattering .and. decay) then field_data => model%get_field_ptr (25) call field_data%set (p_is_stable = .false.) end if call prc_test_create_library (libname, lib, & scattering = .true., decay = .true., & procname1 = procname1, procname2 = procname2) call reset_interaction_counter () allocate (phs_single_config_t :: phs_config_template) if (scattering) then call model_copy%init (model%get_name (), & model%get_n_real (), & model%get_n_complex (), & model%get_n_field (), & model%get_n_vtx ()) call model_copy%copy_from (model) allocate (process) call process%init (procname1, lib, os_data, model_copy) call process%setup_test_cores () call process%init_components (phs_config_template) sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_test_midpoint) call process%setup_terms () allocate (process_instance) call process_instance%init (process%process_t) call process_instance%integrate (1, n_it = 1, n_calls = 100) call process%final_integration (1) call process_instance%final () deallocate (process_instance) call process%prepare_simulation (1) call process_stack%push (process) end if if (decay) then call model_copy%init (model%get_name (), & model%get_n_real (), & model%get_n_complex (), & model%get_n_field (), & model%get_n_vtx ()) call model_copy%copy_from (model) allocate (process) call process%init (procname2, lib, os_data, model_copy) call process%setup_test_cores () call process%init_components (phs_config_template) if (present (decay_rest_frame)) then call process%setup_beams_decay (rest_frame = decay_rest_frame, i_core = 1) else call process%setup_beams_decay (rest_frame = .not. scattering, i_core = 1) end if call process%configure_phs () call process%setup_mci (dispatch_mci_test_midpoint) call process%setup_terms () allocate (process_instance) call process_instance%init (process%process_t) call process_instance%integrate (1, n_it=1, n_calls=100) call process%final_integration (1) call process_instance%final () deallocate (process_instance) call process%prepare_simulation (1) call process_stack%push (process) end if call model%final () call model_copy%final () end subroutine prepare_testbed @ %def prepare_testbed @ MCI record prepared for midpoint integrator. <>= subroutine dispatch_mci_test_midpoint (mci, var_list, process_id, is_nlo) use variables, only: var_list_t class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo allocate (mci_midpoint_t :: mci) end subroutine dispatch_mci_test_midpoint @ %def dispatch_mci_test_midpoint @ \subsubsection{Simple decay configuration} We define a branching configuration with two decay modes. We set the integral values by hand, so we do not need to evaluate processes, yet. <>= call test (decays_1, "decays_1", & "branching and decay configuration", & u, results) <>= public :: decays_1 <>= subroutine decays_1 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_data_t), target :: model type(flavor_t) :: flv_h type(flavor_t), dimension(2,1) :: flv_hbb, flv_hgg type(unstable_config_t), allocatable :: unstable write (u, "(A)") "* Test output: decays_1" write (u, "(A)") "* Purpose: Set up branching and decay configuration" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call os_data%init () call model%init_sm_test () call flv_h%init (25, model) call flv_hbb(:,1)%init ([5, -5], model) call flv_hgg(:,1)%init ([22, 22], model) write (u, "(A)") "* Set up branching and decay" write (u, "(A)") allocate (unstable) call unstable%init (flv_h) call unstable%init_decays ([var_str ("h_bb"), var_str ("h_gg")], model) call unstable%init_test_case1 & (1, flv_hbb, 1.234e-3_default, .02_default, model) call unstable%init_test_case1 & (2, flv_hgg, 3.085e-4_default, .08_default, model) call unstable%compute () call unstable%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call unstable%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: decays_1" end subroutine decays_1 @ %def decays_1 @ \subsubsection{Cascade decay configuration} We define a branching configuration with one decay, which is followed by another branching. <>= call test (decays_2, "decays_2", & "cascade decay configuration", & u, results) <>= public :: decays_2 <>= subroutine decays_2 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_data_t), target :: model type(flavor_t) :: flv_h, flv_wp, flv_wm type(flavor_t), dimension(2,1) :: flv_hww, flv_wud, flv_wen type(unstable_config_t), allocatable :: unstable write (u, "(A)") "* Test output: decays_2" write (u, "(A)") "* Purpose: Set up cascade branching" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call os_data%init () call model%init_sm_test () call model%set_unstable (25, [var_str ("h_ww")]) call model%set_unstable (24, [var_str ("w_ud"), var_str ("w_en")]) call flv_h%init (25, model) call flv_hww(:,1)%init ([24, -24], model) call flv_wp%init (24, model) call flv_wm%init (-24, model) call flv_wud(:,1)%init ([2, -1], model) call flv_wen(:,1)%init ([-11, 12], model) write (u, "(A)") "* Set up branching and decay" write (u, "(A)") allocate (unstable) call unstable%init (flv_h, set_decays=.true., model=model) call unstable%init_test_case2 (flv_hww, flv_wud, flv_wen, model) call unstable%compute () call unstable%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call unstable%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: decays_2" end subroutine decays_2 @ %def decays_2 @ \subsubsection{Decay and Process Object} We define a branching configuration with one decay and connect this with an actual process object. <>= call test (decays_3, "decays_3", & "associate process", & u, results) <>= public :: decays_3 <>= subroutine decays_3 (u) integer, intent(in) :: u type(os_data_t) :: os_data class(model_data_t), pointer :: model type(process_library_t), target :: lib type(string_t) :: prefix type(string_t) :: procname2 type(process_stack_t) :: process_stack type(process_t), pointer :: process type(unstable_config_t), allocatable :: unstable type(flavor_t) :: flv write (u, "(A)") "* Test output: decays_3" write (u, "(A)") "* Purpose: Connect a decay configuration & &with a process" write (u, "(A)") write (u, "(A)") "* Initialize environment and integrate process" write (u, "(A)") call os_data%init () prefix = "decays_3" call prepare_testbed & (lib, process_stack, prefix, os_data, & scattering=.false., decay=.true., decay_rest_frame=.false.) procname2 = prefix // "_d" process => process_stack%get_process_ptr (procname2) model => process%get_model_ptr () call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Set up branching and decay" write (u, "(A)") call flv%init (25, model) allocate (unstable) call unstable%init (flv) call unstable%init_decays ([procname2], model) write (u, "(A)") "* Connect decay with process object" write (u, "(A)") call unstable%connect_decay (1, process, model) call unstable%compute () call unstable%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call unstable%final () call process_stack%final () write (u, "(A)") write (u, "(A)") "* Test output end: decays_3" end subroutine decays_3 @ %def decays_3 @ \subsubsection{Decay and Process Object} Building upon the previous test, we set up a decay instance and generate a decay event. <>= call test (decays_4, "decays_4", & "decay instance", & u, results) <>= public :: decays_4 <>= subroutine decays_4 (u) integer, intent(in) :: u type(os_data_t) :: os_data class(model_data_t), pointer :: model type(process_library_t), target :: lib type(string_t) :: prefix, procname2 class(rng_t), allocatable :: rng type(process_stack_t) :: process_stack type(process_t), pointer :: process type(unstable_config_t), allocatable, target :: unstable type(flavor_t) :: flv type(unstable_t), allocatable :: instance write (u, "(A)") "* Test output: decays_4" write (u, "(A)") "* Purpose: Create a decay process and evaluate & &an instance" write (u, "(A)") write (u, "(A)") "* Initialize environment, process, & &and decay configuration" write (u, "(A)") call os_data%init () prefix = "decays_4" call prepare_testbed & (lib, process_stack, prefix, os_data, & scattering=.false., decay=.true., decay_rest_frame = .false.) procname2 = prefix // "_d" process => process_stack%get_process_ptr (procname2) model => process%get_model_ptr () call flv%init (25, model) allocate (unstable) call unstable%init (flv) call unstable%init_decays ([procname2], model) call model%set_unstable (25, [procname2]) call unstable%connect_decay (1, process, model) call unstable%compute () allocate (rng_test_t :: rng) allocate (instance) call instance%init (unstable) call instance%import_rng (rng) call instance%select_chain () call instance%generate () call instance%write (u) write (u, *) call instance%write_process_instances (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call instance%final () call process_stack%final () call unstable%final () write (u, "(A)") write (u, "(A)") "* Test output end: decays_4" end subroutine decays_4 @ %def decays_4 @ \subsubsection{Decay with Parent Process} We define a scattering process $ss\to ss$ and subsequent decays $s\to f\bar f$. <>= call test (decays_5, "decays_5", & "parent process and decay", & u, results) <>= public :: decays_5 <>= subroutine decays_5 (u) integer, intent(in) :: u type(os_data_t) :: os_data class(model_data_t), pointer :: model type(process_library_t), target :: lib type(string_t) :: prefix, procname1, procname2 type(process_stack_t) :: process_stack type(process_t), pointer :: process type(process_instance_t), allocatable, target :: process_instance type(decay_root_config_t), target :: decay_root_config type(decay_root_t) :: decay_root type(decay_chain_t) :: decay_chain write (u, "(A)") "* Test output: decays_5" write (u, "(A)") "* Purpose: Handle a process with subsequent decays" write (u, "(A)") write (u, "(A)") "* Initialize environment and parent process" write (u, "(A)") call os_data%init () prefix = "decays_5" procname1 = prefix // "_p" procname2 = prefix // "_d" call prepare_testbed & (lib, process_stack, prefix, os_data, & scattering=.true., decay=.true.) write (u, "(A)") "* Initialize decay process" write (u, "(A)") process => process_stack%get_process_ptr (procname1) model => process%get_model_ptr () call model%set_unstable (25, [procname2]) write (u, "(A)") "* Initialize decay tree configuration" write (u, "(A)") call decay_root_config%connect (process, model, process_stack) call decay_root_config%compute () call decay_root_config%write (u) write (u, "(A)") write (u, "(A)") "* Initialize decay tree" allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data () call process_instance%init_simulation (1) call decay_root%init (decay_root_config, process_instance) write (u, "(A)") write (u, "(A)") "* Select decay chain" write (u, "(A)") call decay_root%set_mci (1) !!! Not yet implemented; there is only one term anyway: ! call process_instance%select_i_term (decay_root%selected_term) call decay_root%set_term (1) call decay_root%select_chain () call decay_chain%build (decay_root) call decay_root%write (u) write (u, "(A)") write (u, "(A)") "* Generate event" write (u, "(A)") call process_instance%generate_unweighted_event (decay_root%get_mci ()) call process_instance%evaluate_event_data () call decay_root%generate () call pacify (decay_root) write (u, "(A)") "* Process instances" write (u, "(A)") call decay_root%write_process_instances (u) write (u, "(A)") write (u, "(A)") "* Generate decay chain" write (u, "(A)") call decay_chain%evaluate () call decay_chain%write (u) write (u, *) write (u, "(A,ES19.12)") "chain probability =", & decay_chain%get_probability () write (u, "(A)") write (u, "(A)") "* Cleanup" call decay_chain%final () call decay_root%final () call decay_root_config%final () call process_instance%final () deallocate (process_instance) call process_stack%final () write (u, "(A)") write (u, "(A)") "* Test output end: decays_5" end subroutine decays_5 @ %def decays_5 @ \subsubsection{Decay as Event Transform} Again, we define a scattering process $ss\to ss$ and subsequent decays $s\to f\bar f$. <>= call test (decays_6, "decays_6", & "evt_decay object", & u, results) <>= public :: decays_6 <>= subroutine decays_6 (u) integer, intent(in) :: u type(os_data_t) :: os_data class(model_data_t), pointer :: model type(process_library_t), target :: lib type(string_t) :: prefix, procname1, procname2 type(process_stack_t) :: process_stack type(process_t), pointer :: process type(process_instance_t), allocatable, target :: process_instance type(evt_decay_t), target :: evt_decay integer :: factorization_mode logical :: keep_correlations write (u, "(A)") "* Test output: decays_6" write (u, "(A)") "* Purpose: Handle a process with subsequent decays" write (u, "(A)") write (u, "(A)") "* Initialize environment and parent process" write (u, "(A)") call os_data%init () prefix = "decays_6" procname1 = prefix // "_p" procname2 = prefix // "_d" call prepare_testbed & (lib, process_stack, prefix, os_data, & scattering=.true., decay=.true.) write (u, "(A)") "* Initialize decay process" process => process_stack%get_process_ptr (procname1) model => process%get_model_ptr () call model%set_unstable (25, [procname2]) allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data () call process_instance%init_simulation (1) write (u, "(A)") write (u, "(A)") "* Initialize decay object" call evt_decay%connect (process_instance, model, process_stack) write (u, "(A)") write (u, "(A)") "* Generate scattering event" call process_instance%generate_unweighted_event (1) call process_instance%evaluate_event_data () write (u, "(A)") write (u, "(A)") "* Select decay chain and generate event" write (u, "(A)") call evt_decay%prepare_new_event (1, 1) call evt_decay%generate_unweighted () factorization_mode = FM_IGNORE_HELICITY keep_correlations = .false. call evt_decay%make_particle_set (factorization_mode, keep_correlations) call evt_decay%write (u, verbose = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_decay%final () call process_instance%final () deallocate (process_instance) call process_stack%final () write (u, "(A)") write (u, "(A)") "* Test output end: decays_6" end subroutine decays_6 @ %def decays_6 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Tau decays} <<[[tau_decays.f90]]>>= <> module tau_decays <> use io_units use format_utils, only: write_separator use sm_qcd use model_data use models use event_transforms <> <> <> contains <> end module tau_decays @ %def tau_decays \subsection{Tau Decays Event Transform} This is the type for the tau decay event transform. <>= public :: evt_tau_decays_t <>= type, extends (evt_t) :: evt_tau_decays_t type(model_t), pointer :: model_hadrons => null() type(qcd_t) :: qcd contains <> end type evt_tau_decays_t @ %def evt_tau_decays_t <>= procedure :: write_name => evt_tau_decays_write_name <>= subroutine evt_tau_decays_write_name (evt, unit) class(evt_tau_decays_t), intent(in) :: evt integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Event transform: tau decays" end subroutine evt_tau_decays_write_name @ %def evt_tau_decays_write_name @ Output. <>= procedure :: write => evt_tau_decays_write <>= subroutine evt_tau_decays_write (evt, unit, verbose, more_verbose, testflag) class(evt_tau_decays_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, more_verbose, testflag integer :: u u = given_output_unit (unit) call write_separator (u, 2) call evt%write_name (u) call write_separator (u) call evt%base_write (u, testflag = testflag, show_set = .false.) if (evt%particle_set_exists) & call evt%particle_set%write & (u, summary = .true., compressed = .true., testflag = testflag) call write_separator (u) end subroutine evt_tau_decays_write @ %def evt_tau_decays_write @ Here we take the particle set from the previous event transform and apply the tau decays. What probability should be given back, the product of branching ratios of the corresponding tau decays? <>= procedure :: generate_weighted => evt_tau_decays_generate_weighted <>= subroutine evt_tau_decays_generate_weighted (evt, probability) class(evt_tau_decays_t), intent(inout) :: evt real(default), intent(inout) :: probability logical :: valid evt%particle_set = evt%previous%particle_set !!! To be checked or expanded probability = 1 valid = .true. evt%particle_set_exists = valid end subroutine evt_tau_decays_generate_weighted @ %def evt_tau_decays_generate_weighted @ The factorization parameters are irrelevant. <>= procedure :: make_particle_set => evt_tau_decays_make_particle_set <>= subroutine evt_tau_decays_make_particle_set & (evt, factorization_mode, keep_correlations, r) class(evt_tau_decays_t), intent(inout) :: evt integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r logical :: valid !!! to be checked and expanded valid = .true. evt%particle_set_exists = evt%particle_set_exists .and. valid end subroutine evt_tau_decays_make_particle_set @ %def event_tau_decays_make_particle_set @ <>= procedure :: prepare_new_event => evt_tau_decays_prepare_new_event <>= subroutine evt_tau_decays_prepare_new_event (evt, i_mci, i_term) class(evt_tau_decays_t), intent(inout) :: evt integer, intent(in) :: i_mci, i_term call evt%reset () end subroutine evt_tau_decays_prepare_new_event @ %def evt_tau_decays_prepare_new_event @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Shower} We might use matrix elements of LO and NLO to increase the accuracy of the shower in the sense of matching as well as merging. <<[[shower.f90]]>>= <> module shower <> <> <> use io_units use format_utils, only: write_separator use system_defs, only: LF use os_interface use diagnostics use lorentz use pdf use subevents, only: PRT_BEAM_REMNANT, PRT_INCOMING, PRT_OUTGOING use shower_base use matching_base use powheg_matching, only: powheg_matching_t use sm_qcd use model_data use rng_base use event_transforms use models use hep_common use process, only: process_t use instances, only: process_instance_t use process_stacks <> <> <> <> contains <> end module shower @ %def shower @ \subsection{Configuration Parameters} [[POWHEG_TESTING]] allows to disable the parton shower for validation and testing of the POWHEG procedure. <>= logical, parameter :: POWHEG_TESTING = .false. @ %def POWHEG_TESTING @ \subsection{Event Transform} The event transforms can do more than mere showering. Especially, it may reweight showered events to fixed-order matrix elements. The [[model_hadrons]] is supposed to be the SM variant that contains all hadrons that can be generated in the shower. <>= public :: evt_shower_t <>= type, extends (evt_t) :: evt_shower_t class(shower_base_t), allocatable :: shower class(matching_t), allocatable :: matching type(model_t), pointer :: model_hadrons => null () type(qcd_t) :: qcd type(pdf_data_t) :: pdf_data type(os_data_t) :: os_data logical :: is_first_event contains <> end type evt_shower_t @ %def evt_shower_t @ <>= procedure :: write_name => evt_shower_write_name <>= subroutine evt_shower_write_name (evt, unit) class(evt_shower_t), intent(in) :: evt integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Event transform: shower" end subroutine evt_shower_write_name @ %def evt_shower_write_name @ Output. <>= procedure :: write => evt_shower_write <>= subroutine evt_shower_write (evt, unit, verbose, more_verbose, testflag) class(evt_shower_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, more_verbose, testflag integer :: u u = given_output_unit (unit) call write_separator (u, 2) call evt%write_name (u) call write_separator (u) call evt%base_write (u, testflag = testflag, show_set = .false.) if (evt%particle_set_exists) call evt%particle_set%write & (u, summary = .true., compressed = .true., testflag = testflag) call write_separator (u) call evt%shower%settings%write (u) end subroutine evt_shower_write @ %def evt_shower_write <>= procedure :: connect => evt_shower_connect <>= subroutine evt_shower_connect & (evt, process_instance, model, process_stack) class(evt_shower_t), intent(inout), target :: evt type(process_instance_t), intent(in), target :: process_instance class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack call evt%base_connect (process_instance, model, process_stack) call evt%make_rng (evt%process) if (allocated (evt%matching)) then call evt%matching%connect (process_instance, model, evt%shower) end if end subroutine evt_shower_connect @ %def evt_shower_connect @ Initialize the event transformation. This will be executed once during dispatching. The [[model_hadrons]] is supposed to be the SM variant that contains all hadrons that may be generated in the shower. <>= procedure :: init => evt_shower_init <>= subroutine evt_shower_init (evt, model_hadrons, os_data) class(evt_shower_t), intent(out) :: evt type(model_t), intent(in), target :: model_hadrons type(os_data_t), intent(in) :: os_data evt%os_data = os_data evt%model_hadrons => model_hadrons evt%is_first_event = .true. end subroutine evt_shower_init @ %def evt_shower_init @ Create RNG instances, spawned by the process object. <>= procedure :: make_rng => evt_shower_make_rng <>= subroutine evt_shower_make_rng (evt, process) class(evt_shower_t), intent(inout) :: evt type(process_t), intent(inout) :: process class(rng_t), allocatable :: rng call process%make_rng (rng) call evt%shower%import_rng (rng) if (allocated (evt%matching)) then call process%make_rng (rng) call evt%matching%import_rng (rng) end if end subroutine evt_shower_make_rng @ %def evt_shower_make_rng @ Things we want to do for a new event before the whole event transformation chain is evaluated. <>= procedure :: prepare_new_event => evt_shower_prepare_new_event <>= subroutine evt_shower_prepare_new_event (evt, i_mci, i_term) class(evt_shower_t), intent(inout) :: evt integer, intent(in) :: i_mci, i_term real(default) :: fac_scale, alpha_s fac_scale = evt%process_instance%get_fac_scale (i_term) alpha_s = evt%process_instance%get_alpha_s (i_term) call evt%reset () call evt%shower%prepare_new_event (fac_scale, alpha_s) end subroutine evt_shower_prepare_new_event @ %def evt_shower_prepare_new_event @ <>= procedure :: first_event => evt_shower_first_event <>= subroutine evt_shower_first_event (evt) class(evt_shower_t), intent(inout) :: evt double precision :: pdftest if (debug_on) call msg_debug (D_TRANSFORMS, "evt_shower_first_event") associate (settings => evt%shower%settings) settings%hadron_collision = .false. !!! !!! !!! Workaround for PGF90 v16.1 !!! if (all (evt%particle_set%prt(1:2)%flv%get_pdg_abs () <= 39)) then if (evt%particle_set%prt(1)%flv%get_pdg_abs () <= 39 .and. & evt%particle_set%prt(2)%flv%get_pdg_abs () <= 39) then settings%hadron_collision = .false. !!! else if (all (evt%particle_set%prt(1:2)%flv%get_pdg_abs () >= 100)) then else if (evt%particle_set%prt(1)%flv%get_pdg_abs () >= 100 .and. & evt%particle_set%prt(2)%flv%get_pdg_abs () >= 100) then settings%hadron_collision = .true. else call msg_fatal ("evt_shower didn't recognize beams setup") end if if (debug_on) call msg_debug (D_TRANSFORMS, "hadron_collision", settings%hadron_collision) if (allocated (evt%matching)) then evt%matching%is_hadron_collision = settings%hadron_collision call evt%matching%first_event () end if if (.not. settings%hadron_collision .and. settings%isr_active) then call msg_fatal ("?ps_isr_active is only intended for hadron-collisions") end if if (evt%pdf_data%type == STRF_LHAPDF5) then if (settings%isr_active .and. settings%hadron_collision) then call GetQ2max (0, pdftest) if (pdftest < epsilon (pdftest)) then call msg_bug ("ISR QCD shower enabled, but LHAPDF not " // & "initialized," // LF // " aborting simulation") return end if end if else if (evt%pdf_data%type == STRF_PDF_BUILTIN .and. & settings%method == PS_PYTHIA6) then call msg_fatal ("Builtin PDFs cannot be used for PYTHIA showers," & // LF // " aborting simulation") return end if end associate evt%is_first_event = .false. end subroutine evt_shower_first_event @ %def evt_shower_first_event @ Here we take the particle set from the previous event transform (assuming that there is always one) and apply the shower algorithm. The result is stored in the event transform of the current object. We always return a probability of unity as we don't have the analytic weight of the combination of shower, MLM matching and hadronization. A subdivision into multiple event transformations is under construction. Invalid or vetoed events have to be discarded by the caller which is why we mark the particle set as invalid. This procedure directly takes the (MLM) matching into account. <>= procedure :: generate_weighted => evt_shower_generate_weighted <>= subroutine evt_shower_generate_weighted (evt, probability) class(evt_shower_t), intent(inout) :: evt real(default), intent(inout) :: probability logical :: valid, vetoed if (debug_on) call msg_debug (D_TRANSFORMS, "evt_shower_generate_weighted") if (signal_is_pending ()) return evt%particle_set = evt%previous%particle_set valid = .true.; vetoed = .false. if (evt%is_first_event) call evt%first_event () call evt%shower%import_particle_set (evt%particle_set) if (allocated (evt%matching)) then call evt%matching%before_shower (evt%particle_set, vetoed) if (msg_level(D_TRANSFORMS) >= DEBUG) then if (debug_on) call msg_debug (D_TRANSFORMS, "Matching before generate emissions") call evt%matching%write () end if end if if (.not. (vetoed .or. POWHEG_TESTING)) then if (evt%shower%settings%method == PS_PYTHIA6 .or. & evt%shower%settings%hadronization_active) then call assure_heprup (evt%particle_set) end if call evt%shower%generate_emissions (valid) end if probability = 1 evt%particle_set_exists = valid .and. .not. vetoed end subroutine evt_shower_generate_weighted @ %def evt_shower_generate_weighted @ Here, we fill the particle set with the partons from the shower. The factorization parameters are irrelevant. We make a sanity check that the initial energy lands either in the outgoing particles or add to the beam remnant. <>= procedure :: make_particle_set => evt_shower_make_particle_set <>= subroutine evt_shower_make_particle_set & (evt, factorization_mode, keep_correlations, r) class(evt_shower_t), intent(inout) :: evt integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r type(vector4_t) :: sum_vec_in, sum_vec_out, sum_vec_beamrem, & sum_vec_beamrem_before logical :: vetoed, sane if (evt%particle_set_exists) then vetoed = .false. sum_vec_beamrem_before = sum (evt%particle_set%prt%p, & mask=evt%particle_set%prt%get_status () == PRT_BEAM_REMNANT) call evt%shower%make_particle_set (evt%particle_set, & evt%model, evt%model_hadrons) if (allocated (evt%matching)) then call evt%matching%after_shower (evt%particle_set, vetoed) end if if (debug_active (D_TRANSFORMS)) then call msg_debug (D_TRANSFORMS, & "Shower: obtained particle set after shower + matching") call evt%particle_set%write (summary = .true., compressed = .true.) end if sum_vec_in = sum (evt%particle_set%prt%p, & mask=evt%particle_set%prt%get_status () == PRT_INCOMING) sum_vec_out = sum (evt%particle_set%prt%p, & mask=evt%particle_set%prt%get_status () == PRT_OUTGOING) sum_vec_beamrem = sum (evt%particle_set%prt%p, & mask=evt%particle_set%prt%get_status () == PRT_BEAM_REMNANT) sum_vec_beamrem = sum_vec_beamrem - sum_vec_beamrem_before sane = abs(sum_vec_out%p(0) - sum_vec_in%p(0)) < & sum_vec_in%p(0) / 10 .or. & abs((sum_vec_out%p(0) + sum_vec_beamrem%p(0)) - sum_vec_in%p(0)) < & sum_vec_in%p(0) / 10 sane = .true. evt%particle_set_exists = .not. vetoed .and. sane end if end subroutine evt_shower_make_particle_set @ %def event_shower_make_particle_set @ <>= procedure :: contains_powheg_matching => evt_shower_contains_powheg_matching <>= function evt_shower_contains_powheg_matching (evt) result (val) logical :: val class(evt_shower_t), intent(in) :: evt val = .false. if (allocated (evt%matching)) & val = evt%matching%get_method () == "POWHEG" end function evt_shower_contains_powheg_matching @ %def evt_shower_contains_powheg_matching @ <>= procedure :: disable_powheg_matching => evt_shower_disable_powheg_matching <>= subroutine evt_shower_disable_powheg_matching (evt) class(evt_shower_t), intent(inout) :: evt select type (matching => evt%matching) type is (powheg_matching_t) matching%active = .false. class default call msg_fatal ("Trying to disable powheg but no powheg matching is allocated!") end select end subroutine evt_shower_disable_powheg_matching @ %def evt_shower_disable_powheg_matching @ <>= procedure :: enable_powheg_matching => evt_shower_enable_powheg_matching <>= subroutine evt_shower_enable_powheg_matching (evt) class(evt_shower_t), intent(inout) :: evt select type (matching => evt%matching) type is (powheg_matching_t) matching%active = .true. class default call msg_fatal ("Trying to enable powheg but no powheg matching is allocated!") end select end subroutine evt_shower_enable_powheg_matching @ %def evt_shower_enable_powheg_matching @ <>= procedure :: final => evt_shower_final <>= subroutine evt_shower_final (evt) class(evt_shower_t), intent(inout) :: evt call evt%base_final () if (allocated (evt%matching)) call evt%matching%final () end subroutine evt_shower_final @ %def evt_shower_final @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[shower_ut.f90]]>>= <> module shower_ut use unit_tests use shower_uti <> <> contains <> end module shower_ut @ %def shower_ut @ <<[[shower_uti.f90]]>>= <> module shower_uti <> <> use format_utils, only: write_separator use os_interface use sm_qcd use physics_defs, only: BORN use model_data use models use state_matrices, only: FM_IGNORE_HELICITY use process_libraries use rng_base use rng_tao use dispatch_rng, only: dispatch_rng_factory_fallback use mci_base use mci_midpoint use phs_base use phs_single use prc_core_def, only: prc_core_def_t use prc_core use prc_omega use variables use event_transforms use tauola_interface !NODEP! use process, only: process_t use instances, only: process_instance_t use pdf use shower_base use shower_core use dispatch_rng_ut, only: dispatch_rng_factory_tao use shower <> <> contains <> end module shower_uti @ %def shower_uti @ API: driver for the unit tests below. <>= public :: shower_test <>= subroutine shower_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine shower_test @ %def shower_test @ \subsubsection{Testbed} This sequence sets up a two-jet process, ready for generating events. <>= <> @ <>= subroutine setup_testbed & (prefix, os_data, lib, model_list, process, process_instance) type(string_t), intent(in) :: prefix type(os_data_t), intent(out) :: os_data type(process_library_t), intent(out), target :: lib type(model_list_t), intent(out) :: model_list type(model_t), pointer :: model type(model_t), pointer :: model_tmp type(process_t), target, intent(out) :: process type(process_instance_t), target, intent(out) :: process_instance type(var_list_t), pointer :: model_vars type(string_t) :: model_name, libname, procname type(process_def_entry_t), pointer :: entry type(string_t), dimension(:), allocatable :: prt_in, prt_out class(prc_core_t), allocatable :: core_template class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts model_name = "SM" libname = prefix // "_lib" procname = prefix // "p" call os_data%init () dispatch_rng_factory_fallback => dispatch_rng_factory_tao allocate (model_tmp) call model_list%read_model (model_name, model_name // ".mdl", & os_data, model_tmp) model_vars => model_tmp%get_var_list_ptr () call model_vars%set_real (var_str ("me"), 0._default, & is_known = .true.) model => model_tmp call lib%init (libname) allocate (prt_in (2), source = [var_str ("e-"), var_str ("e+")]) allocate (prt_out (2), source = [var_str ("d"), var_str ("dbar")]) allocate (entry) call entry%init (procname, model, n_in = 2, n_components = 1) call omega_make_process_component (entry, 1, & model_name, prt_in, prt_out, & report_progress=.true.) call lib%append (entry) call lib%configure (os_data) call lib%write_makefile (os_data, force = .true., verbose = .false.) call lib%clean (os_data, distclean = .false.) call lib%write_driver (force = .true.) call lib%load (os_data) call process%init (procname, lib, os_data, model) allocate (prc_omega_t :: core_template) allocate (phs_single_config_t :: phs_config_template) call process%setup_cores (dispatch_core_omega_test) call process%init_components (phs_config_template) sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_test_midpoint) call process%setup_terms () call process_instance%init (process) call process_instance%integrate (1, 1, 1000) call process%final_integration (1) call process_instance%setup_event_data (i_core = 1) call process_instance%init_simulation (1) call process_instance%generate_weighted_event (1) call process_instance%evaluate_event_data () end subroutine setup_testbed @ %def setup_testbed @ A minimal dispatcher version that allocates the core object for testing. <>= subroutine dispatch_core_omega_test (core, core_def, model, & helicity_selection, qcd, use_color_factors, has_beam_pol) class(prc_core_t), allocatable, intent(inout) :: core class(prc_core_def_t), intent(in) :: core_def class(model_data_t), intent(in), target, optional :: model type(helicity_selection_t), intent(in), optional :: helicity_selection type(qcd_t), intent(in), optional :: qcd logical, intent(in), optional :: use_color_factors logical, intent(in), optional :: has_beam_pol allocate (prc_omega_t :: core) select type (core) type is (prc_omega_t) call core%set_parameters (model) end select end subroutine dispatch_core_omega_test @ %def dispatch_core_omega_test @ MCI record prepared for midpoint integrator. <>= subroutine dispatch_mci_test_midpoint (mci, var_list, process_id, is_nlo) use variables, only: var_list_t class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo allocate (mci_midpoint_t :: mci) end subroutine dispatch_mci_test_midpoint @ %def dispatch_mci_test_midpoint @ \subsubsection{Trivial Test} We generate a two-jet event and shower it using default settings, i.e. in disabled mode. <>= call test (shower_1, "shower_1", & "disabled shower", & u, results) <>= public :: shower_1 <>= subroutine shower_1 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(process_library_t), target :: lib type(model_list_t) :: model_list class(model_data_t), pointer :: model type(model_t), pointer :: model_hadrons type(process_t), target :: process type(process_instance_t), target :: process_instance type(pdf_data_t) :: pdf_data integer :: factorization_mode logical :: keep_correlations class(evt_t), allocatable, target :: evt_trivial class(evt_t), allocatable, target :: evt_shower type(shower_settings_t) :: settings type(taudec_settings_t) :: taudec_settings write (u, "(A)") "* Test output: shower_1" write (u, "(A)") "* Purpose: Two-jet event with disabled shower" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"), & os_data, model_hadrons) call setup_testbed (var_str ("shower_1"), & os_data, lib, model_list, process, process_instance) write (u, "(A)") "* Set up trivial transform" write (u, "(A)") allocate (evt_trivial_t :: evt_trivial) model => process%get_model_ptr () call evt_trivial%connect (process_instance, model) call evt_trivial%prepare_new_event (1, 1) call evt_trivial%generate_unweighted () factorization_mode = FM_IGNORE_HELICITY keep_correlations = .false. call evt_trivial%make_particle_set (factorization_mode, keep_correlations) select type (evt_trivial) type is (evt_trivial_t) call evt_trivial%write (u) call write_separator (u, 2) end select write (u, "(A)") write (u, "(A)") "* Set up shower event transform" write (u, "(A)") allocate (evt_shower_t :: evt_shower) select type (evt_shower) type is (evt_shower_t) call evt_shower%init (model_hadrons, os_data) allocate (shower_t :: evt_shower%shower) call evt_shower%shower%init (settings, taudec_settings, pdf_data, os_data) call evt_shower%connect (process_instance, model) end select evt_trivial%next => evt_shower evt_shower%previous => evt_trivial call evt_shower%prepare_new_event (1, 1) call evt_shower%generate_unweighted () call evt_shower%make_particle_set (factorization_mode, keep_correlations) select type (evt_shower) type is (evt_shower_t) call evt_shower%write (u) call write_separator (u, 2) end select write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_shower%final () call evt_trivial%final () call process_instance%final () call process%final () call lib%final () call model_hadrons%final () deallocate (model_hadrons) call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: shower_1" end subroutine shower_1 @ %def shower_1 @ \subsubsection{FSR Shower} We generate a two-jet event and shower it with the Whizard FSR shower. <>= call test (shower_2, "shower_2", & "final-state shower", & u, results) <>= public :: shower_2 <>= subroutine shower_2 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(process_library_t), target :: lib type(model_list_t) :: model_list type(model_t), pointer :: model_hadrons class(model_data_t), pointer :: model type(process_t), target :: process type(process_instance_t), target :: process_instance integer :: factorization_mode logical :: keep_correlations type(pdf_data_t) :: pdf_data class(evt_t), allocatable, target :: evt_trivial class(evt_t), allocatable, target :: evt_shower type(shower_settings_t) :: settings type(taudec_settings_t) :: taudec_settings write (u, "(A)") "* Test output: shower_2" write (u, "(A)") "* Purpose: Two-jet event with FSR shower" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"), & os_data, model_hadrons) call setup_testbed (var_str ("shower_2"), & os_data, lib, model_list, process, process_instance) model => process%get_model_ptr () write (u, "(A)") "* Set up trivial transform" write (u, "(A)") allocate (evt_trivial_t :: evt_trivial) call evt_trivial%connect (process_instance, model) call evt_trivial%prepare_new_event (1, 1) call evt_trivial%generate_unweighted () factorization_mode = FM_IGNORE_HELICITY keep_correlations = .false. call evt_trivial%make_particle_set (factorization_mode, keep_correlations) select type (evt_trivial) type is (evt_trivial_t) call evt_trivial%write (u) call write_separator (u, 2) end select write (u, "(A)") write (u, "(A)") "* Set up shower event transform" write (u, "(A)") settings%fsr_active = .true. allocate (evt_shower_t :: evt_shower) select type (evt_shower) type is (evt_shower_t) call evt_shower%init (model_hadrons, os_data) allocate (shower_t :: evt_shower%shower) call evt_shower%shower%init (settings, taudec_settings, pdf_data, os_data) call evt_shower%connect (process_instance, model) end select evt_trivial%next => evt_shower evt_shower%previous => evt_trivial call evt_shower%prepare_new_event (1, 1) call evt_shower%generate_unweighted () call evt_shower%make_particle_set (factorization_mode, keep_correlations) select type (evt_shower) type is (evt_shower_t) call evt_shower%write (u, testflag = .true.) call write_separator (u, 2) end select write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_shower%final () call evt_trivial%final () call process_instance%final () call process%final () call lib%final () call model_hadrons%final () deallocate (model_hadrons) call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: shower_2" end subroutine shower_2 @ %def shower_2 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Fixed Order NLO Events} This section deals with the generation of weighted event samples which take into account next-to-leading order corrections. An approach generating unweighted events is not possible here, because negative weights might occur due to subtraction. Note that the events produced this way are not physical in the sense that they will not keep NLO-accuracy when interfaced to a parton shower. They are rather useful for theoretical consistency checks and a fast estimate of NLO effects.\\ We generate NLO events in the following way: First, the integration is carried out using the complete divergence-subtracted NLO matrix element. In the subsequent simulation, $N$-particle kinematics are generated using $\mathcal{B}+\mathcal{V}+\mathcal{C}$ as weight. After that, the program loops over all singular regions and for each of them generates an event with $N+1$-particle kinematics. The weight for those events corresponds to the real matrix element $\mathcal{R}^\alpha$ evaluated at the $\alpha$-region's emitter's phase space point, multiplied with $S_\alpha$. This procedure is implemented using the [[evt_nlo]] transform. <<[[evt_nlo.f90]]>>= <> module evt_nlo <> <> <> use io_units, only: given_output_unit use constants use lorentz use phs_points, only: phs_point_t use phs_points, only: assignment(=), operator(*), size use diagnostics use numeric_utils, only: nearly_equal use format_utils, only: write_separator use physics_defs, only: BORN, NLO_REAL use sm_qcd use model_data use interactions, only: interaction_t use particles use instances, only: process_instance_t use pcm, only: pcm_nlo_t, pcm_nlo_workspace_t use process_stacks use event_transforms use prc_core, only: prc_core_t use prc_external, only: prc_external_t use quantum_numbers, only: quantum_numbers_t use phs_fks, only: phs_fks_t, phs_fks_generator_t use phs_fks, only: phs_identifier_t, phs_point_set_t use resonances, only: resonance_contributors_t use fks_regions, only: region_data_t <> <> <> <> contains <> end module evt_nlo @ %def evt_nlo @ <>= type :: nlo_event_deps_t logical :: lab_is_cm = .true. type(phs_point_set_t) :: p_born_cms type(phs_point_set_t) :: p_born_lab type(phs_point_set_t) :: p_real_cms type(phs_point_set_t) :: p_real_lab type(resonance_contributors_t), dimension(:), allocatable :: contributors type(phs_identifier_t), dimension(:), allocatable :: phs_identifiers integer, dimension(:), allocatable :: alr_to_i_con integer :: n_phs = 0 end type nlo_event_deps_t @ %def nlo_event_deps_t @ This event transformation is for the generation of fixed-order NLO events. It takes an event with Born kinematics and creates $N_\alpha + 1$ modified weighted events. The first one has Born kinematics and its weight is the sum of Born, virtual, subtraction and, if present, also DGLAP matrix elements. The other $N_\alpha$ events have a weight which is equal to the real matrix element, evaluated with the phase space corresponding to the emitter of the $\alpha$-region. As the NLO event transforms have different kinematics, they also differ in their [[particle_set]]s. The NLO [[event_t]] object carries a single pointer to a [[particle_set]]. To avoid interference between the different NLO [[particle_set]]s, we save the [[particle_set]] of the current $\alpha$-region in the array [[particle_set_nlo]]. Otherwise it would be unretrievable if the usual particle set of the event object was used. <>= integer, parameter, public :: EVT_NLO_UNDEFINED = 0 integer, parameter, public :: EVT_NLO_SEPARATE_BORNLIKE = 1 integer, parameter, public :: EVT_NLO_SEPARATE_REAL = 2 integer, parameter, public :: EVT_NLO_COMBINED = 3 <>= public :: evt_nlo_t <>= type, extends (evt_t) :: evt_nlo_t type(phs_fks_generator_t) :: phs_fks_generator real(default) :: sqme_rad = zero integer :: i_evaluation = 0 type(particle_set_t), dimension(:), allocatable :: particle_set_nlo type(qcd_t) :: qcd type(nlo_event_deps_t) :: event_deps integer :: mode = EVT_NLO_UNDEFINED integer, dimension(:), allocatable :: & i_evaluation_to_i_phs, i_evaluation_to_emitter, & i_evaluation_to_i_term logical :: keep_failed_events = .false. integer :: selected_i_flv = 0 contains <> end type evt_nlo_t @ %def evt_nlo_t @ <>= procedure :: write_name => evt_nlo_write_name <>= subroutine evt_nlo_write_name (evt, unit) class(evt_nlo_t), intent(in) :: evt integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Event transform: NLO" end subroutine evt_nlo_write_name @ %def evt_nlo_write_name @ <>= procedure :: write => evt_nlo_write <>= subroutine evt_nlo_write (evt, unit, verbose, more_verbose, testflag) class(evt_nlo_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, more_verbose, testflag integer :: u, i u = given_output_unit (unit) call write_separator (u, 2) call evt%write_name (u) call write_separator (u) call evt%base_write (u, testflag = testflag, show_set = .true.) write (u,'(A,ES16.9)') "sqme_rad = ", evt%sqme_rad write (u, "(3x,A,I0)") "i_evaluation = ", evt%i_evaluation call write_separator (u) write (u, "(1x,A)") "Radiated particle sets:" do i = 1, size (evt%particle_set_nlo) call evt%particle_set_nlo(i)%write (u, testflag = testflag) call write_separator (u) end do end subroutine evt_nlo_write @ %def evt_nlo_write @ Connects the event transform to the process. Here also the phase space is set up by making [[real_kinematics]] point to the corresponding object in the [[pcm_instance]]. <>= procedure :: connect => evt_nlo_connect <>= subroutine evt_nlo_connect (evt, process_instance, model, process_stack) class(evt_nlo_t), intent(inout), target :: evt type(process_instance_t), intent(in), target :: process_instance class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack if (debug_on) call msg_debug (D_TRANSFORMS, "evt_nlo_connect") call evt%base_connect (process_instance, model, process_stack) select type (pcm_work => process_instance%pcm_work) class is (pcm_nlo_workspace_t) select type (pcm => process_instance%pcm) type is (pcm_nlo_t) call pcm%setup_phs_generator (pcm_work, evt%phs_fks_generator, & process_instance%get_sqrts ()) call evt%set_i_evaluation_mappings (pcm%region_data, & pcm_work%real_kinematics%alr_to_i_phs) end select end select call evt%set_mode (process_instance) call evt%setup_general_event_kinematics (process_instance) if (evt%mode > EVT_NLO_SEPARATE_BORNLIKE) & call evt%setup_real_event_kinematics (process_instance) if (debug_on) call msg_debug2 (D_TRANSFORMS, "evt_nlo_connect: success") end subroutine evt_nlo_connect @ %def evt_nlo_connect @ <>= procedure :: set_i_evaluation_mappings => evt_nlo_set_i_evaluation_mappings <>= subroutine evt_nlo_set_i_evaluation_mappings (evt, reg_data, alr_to_i_phs) class(evt_nlo_t), intent(inout) :: evt type(region_data_t), intent(in) :: reg_data integer, intent(in), dimension(:) :: alr_to_i_phs integer :: n_phs, alr integer :: i_evaluation, i_phs, emitter logical :: checked type :: registered_triple_t integer, dimension(2) :: phs_em type(registered_triple_t), pointer :: next => null () end type registered_triple_t type(registered_triple_t), allocatable, target :: check_list i_evaluation = 1 n_phs = reg_data%n_phs allocate (evt%i_evaluation_to_i_phs (n_phs), source = 0) allocate (evt%i_evaluation_to_emitter (n_phs), source = -1) allocate (evt%i_evaluation_to_i_term (0 : n_phs), source = 0) do alr = 1, reg_data%n_regions i_phs = alr_to_i_phs (alr) emitter = reg_data%regions(alr)%emitter call search_check_list (checked) if (.not. checked) then evt%i_evaluation_to_i_phs (i_evaluation) = i_phs evt%i_evaluation_to_emitter (i_evaluation) = emitter i_evaluation = i_evaluation + 1 end if end do call fill_i_evaluation_to_i_term () if (.not. (all (evt%i_evaluation_to_i_phs > 0) & .and. all (evt%i_evaluation_to_emitter > -1))) then call msg_fatal ("evt_nlo: Inconsistent mappings!") else if (debug2_active (D_TRANSFORMS)) then print *, 'evt_nlo Mappings, i_evaluation -> ' print *, 'i_phs: ', evt%i_evaluation_to_i_phs print *, 'emitter: ', evt%i_evaluation_to_emitter end if end if contains subroutine fill_i_evaluation_to_i_term () integer :: i_term, i_evaluation, term_emitter !!! First find subtraction component i_evaluation = 1 do i_term = 1, evt%process%get_n_terms () if (evt%process_instance%term(i_term)%nlo_type /= NLO_REAL) cycle term_emitter = evt%process_instance%kin(i_term)%emitter if (term_emitter < 0) then evt%i_evaluation_to_i_term (0) = i_term else if (evt%i_evaluation_to_emitter(i_evaluation) == term_emitter) then evt%i_evaluation_to_i_term (i_evaluation) = i_term i_evaluation = i_evaluation + 1 end if end do end subroutine fill_i_evaluation_to_i_term subroutine search_check_list (found) logical, intent(out) :: found type(registered_triple_t), pointer :: current_triple => null () if (allocated (check_list)) then current_triple => check_list do if (all (current_triple%phs_em == [i_phs, emitter])) then found = .true. exit end if if (.not. associated (current_triple%next)) then allocate (current_triple%next) current_triple%next%phs_em = [i_phs, emitter] found = .false. exit else current_triple => current_triple%next end if end do else allocate (check_list) check_list%phs_em = [i_phs, emitter] found = .false. end if end subroutine search_check_list end subroutine evt_nlo_set_i_evaluation_mappings @ %def evt_nlo_set_i_evaluation_mappings @ <>= procedure :: get_i_phs => evt_nlo_get_i_phs <>= function evt_nlo_get_i_phs (evt) result (i_phs) integer :: i_phs class(evt_nlo_t), intent(in) :: evt i_phs = evt%i_evaluation_to_i_phs (evt%i_evaluation) end function evt_nlo_get_i_phs @ %def evt_nlo_get_i_phs @ <>= procedure :: get_emitter => evt_nlo_get_emitter <>= function evt_nlo_get_emitter (evt) result (emitter) integer :: emitter class(evt_nlo_t), intent(in) :: evt emitter = evt%i_evaluation_to_emitter (evt%i_evaluation) end function evt_nlo_get_emitter @ %def evt_nlo_get_emitter @ <>= procedure :: get_i_term => evt_nlo_get_i_term <>= function evt_nlo_get_i_term (evt) result (i_term) integer :: i_term class(evt_nlo_t), intent(in) :: evt if (evt%mode >= EVT_NLO_SEPARATE_REAL) then i_term = evt%i_evaluation_to_i_term (evt%i_evaluation) else i_term = evt%process_instance%get_first_active_i_term () end if end function evt_nlo_get_i_term @ %def evt_nlo_get_i_term @ The event transform has a variable which counts the number of times it has already been called for one generation point. If this variable, [[i_evaluation]], is zero, this means that [[evt_nlo_generate_weighted]] is called for the first time, so that the generation of an $N$-particle event is required. In all other cases, emission events are generated. During a separate integration of the real component, the first event of each event group will become the counterevent. In this case, we return the sum of all subtraction matrix elements. During a combined integration, the first event will be a combination of all Born-like events. To get the sum of their matrix elements, we subtract the sum of all real emissions from the sum of all matrix elements as the real contribution is the only non-Born contribution. Note that the argument named [[probablity]], the use of the routine [[generate_weighted]] and the procedure we use to generate NLO events via an event transformation is an abuse of the interface which should be refactored. <>= procedure :: generate_weighted => evt_nlo_generate_weighted <>= subroutine evt_nlo_generate_weighted (evt, probability) class(evt_nlo_t), intent(inout) :: evt real(default), intent(inout) :: probability real(default) :: sqme call print_debug_info () sqme = probability if (evt%mode > EVT_NLO_SEPARATE_BORNLIKE) then if (evt%i_evaluation == 0) then call evt%reset_phs_identifiers () call evt%evaluate_real_kinematics () if (evt%mode == EVT_NLO_SEPARATE_REAL) then sqme = evt%compute_subtraction_sqmes () else sqme = sqme - evt%compute_all_sqme_rad () end if else call evt%compute_real () sqme = evt%sqme_rad end if end if probability = sqme if (debug_on) call msg_debug (D_TRANSFORMS, "probability (after)", probability) contains function status_code_to_string (mode) result (smode) type(string_t) :: smode integer, intent(in) :: mode select case (mode) case (EVT_NLO_UNDEFINED) smode = var_str ("Undefined") case (EVT_NLO_SEPARATE_BORNLIKE) smode = var_str ("Born-like") case (EVT_NLO_SEPARATE_REAL) smode = var_str ("Real") case (EVT_NLO_COMBINED) smode = var_str ("Combined") end select end function status_code_to_string subroutine print_debug_info () if (debug_on) call msg_debug (D_TRANSFORMS, "evt_nlo_generate_weighted") if (debug_on) call msg_debug (D_TRANSFORMS, char ("mode: " // status_code_to_string (evt%mode))) if (debug_on) call msg_debug (D_TRANSFORMS, "probability (before)", probability) if (debug_on) call msg_debug (D_TRANSFORMS, "evt%i_evaluation", evt%i_evaluation) if (debug2_active (D_TRANSFORMS)) then if (evt%mode > EVT_NLO_SEPARATE_BORNLIKE) then if (evt%i_evaluation == 0) then print *, 'Evaluate subtraction component' else print *, 'Evaluate radiation component' end if end if end if end subroutine print_debug_info end subroutine evt_nlo_generate_weighted @ %def evt_nlo_generate_weighted @ <>= procedure :: reset_phs_identifiers => evt_nlo_reset_phs_identifiers <>= subroutine evt_nlo_reset_phs_identifiers (evt) class(evt_nlo_t), intent(inout) :: evt evt%event_deps%phs_identifiers%evaluated = .false. end subroutine evt_nlo_reset_phs_identifiers @ %def evt_nlo_reset_phs_identifiers @ The routine [[make_factorized_particle_set]] will setup the subevent momenta from the [[connected%matrix]]. Its initial state momenta correspond to the Born process without IS splitting and thus need to be updated with the real momenta from the [[int_hard]] to get correct momenta in the events with real radiation. Ideally the [[int_hard]] and the [[connected]] would be setup with correct [[source_link]]s to real momenta so that we would not need to replace momenta of the [[connected]] here. The parameter [[n_in]] from the [[int_matrix]] is still $0$ as it has been shifted to [[n_vir]]. We thus take [[n_in]] from the [[particle_set]]. <>= procedure :: connected_set_real_IS_momenta => evt_nlo_connected_set_real_IS_momenta <>= subroutine evt_nlo_connected_set_real_IS_momenta (evt) class(evt_nlo_t), intent(inout) :: evt type(vector4_t) :: p_hard, p_beam, p_remn type(interaction_t), pointer :: int_matrix integer :: i, i_term, n_in, i_in_beam, i_in_hard, i_in_remn i_term = evt%get_i_term () int_matrix => evt%process_instance%get_matrix_int_ptr (i_term) n_in = evt%particle_set%get_n_in () do i = 1, n_in i_in_beam = i i_in_hard = n_in + i i_in_remn = 2 * n_in + i p_hard = evt%process_instance%term(i_term)%int_hard%get_momentum (i) p_beam = int_matrix%get_momentum (i_in_beam) p_remn = p_beam - p_hard call int_matrix%set_momentum (p_hard , i_in_hard) call int_matrix%set_momentum (p_remn , i_in_remn) end do end subroutine evt_nlo_connected_set_real_IS_momenta @ %def evt_nlo_connected_set_real_IS_momenta @ <>= procedure :: make_particle_set => evt_nlo_make_particle_set <>= subroutine evt_nlo_make_particle_set & (evt, factorization_mode, keep_correlations, r) class(evt_nlo_t), intent(inout) :: evt integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r if (evt%mode >= EVT_NLO_SEPARATE_BORNLIKE) then call make_factorized_particle_set (evt, factorization_mode, & keep_correlations, r, evt%get_i_term (), & evt%get_selected_quantum_numbers (evt%selected_i_flv)) else call make_factorized_particle_set (evt, factorization_mode, & keep_correlations, r) end if end subroutine evt_nlo_make_particle_set @ %def evt_nlo_make_particle_set @ <>= procedure :: evaluate_real_kinematics => evt_nlo_evaluate_real_kinematics <>= subroutine evt_nlo_evaluate_real_kinematics (evt) class(evt_nlo_t), intent(inout) :: evt integer :: alr, i_phs, i_con, emitter real(default), dimension(3) :: x_rad logical :: use_contributors integer :: n_regions integer :: i_term type(vector4_t), dimension(:), allocatable :: p_real select type (pcm_work => evt%process_instance%pcm_work) class is (pcm_nlo_workspace_t) x_rad = pcm_work%real_kinematics%x_rad associate (event_deps => evt%event_deps) i_term = evt%get_i_term () event_deps%p_born_lab%phs_point(1) = & evt%process_instance%term(i_term)%p_seed event_deps%p_born_cms%phs_point(1) & = evt%boost_to_cms (event_deps%p_born_lab%phs_point(1)) call evt%phs_fks_generator%set_sqrts_hat & (event_deps%p_born_cms%get_energy (1, 1)) use_contributors = allocated (event_deps%contributors) select type (pcm => evt%process_instance%pcm) type is (pcm_nlo_t) n_regions = pcm%region_data%n_regions end select do alr = 1, n_regions i_phs = pcm_work%real_kinematics%alr_to_i_phs(alr) if (event_deps%phs_identifiers(i_phs)%evaluated) cycle emitter = event_deps%phs_identifiers(i_phs)%emitter associate (generator => evt%phs_fks_generator) if (emitter <= evt%process%get_n_in ()) then call generator%prepare_generation (x_rad, i_phs, emitter, & event_deps%p_born_cms%phs_point(1)%get (), & event_deps%phs_identifiers) ! TODO wk 19-02-28: intent of p_real (also below)? p_real = event_deps%p_real_lab%phs_point(i_phs) call generator%generate_isr (i_phs, & event_deps%p_born_lab%phs_point(1)%get (), & p_real) event_deps%p_real_lab%phs_point(i_phs) = p_real event_deps%p_real_cms%phs_point(i_phs) & = evt%boost_to_cms (event_deps%p_real_lab%phs_point(i_phs)) else if (use_contributors) then i_con = event_deps%alr_to_i_con(alr) call generator%prepare_generation (x_rad, i_phs, emitter, & event_deps%p_born_cms%phs_point(1)%get (), & event_deps%phs_identifiers, event_deps%contributors, i_con) p_real = event_deps%p_real_cms%phs_point(i_phs) call generator%generate_fsr (emitter, i_phs, i_con, & event_deps%p_born_cms%phs_point(1)%get (), & p_real) event_deps%p_real_cms%phs_point(i_phs) = p_real else call generator%prepare_generation (x_rad, i_phs, emitter, & event_deps%p_born_cms%phs_point(1)%get (), & event_deps%phs_identifiers) p_real = event_deps%p_real_cms%phs_point(i_phs) call generator%generate_fsr (emitter, i_phs, & event_deps%p_born_cms%phs_point(1)%get (), & p_real) event_deps%p_real_cms%phs_point(i_phs) = p_real end if event_deps%p_real_lab%phs_point(i_phs) & = evt%boost_to_lab (event_deps%p_real_cms%phs_point(i_phs)) end if end associate call pcm_work%set_momenta & (event_deps%p_born_lab%phs_point(1)%get (), & event_deps%p_real_lab%phs_point(i_phs)%get (), & i_phs) call pcm_work%set_momenta & (event_deps%p_born_cms%phs_point(1)%get (), & event_deps%p_real_cms%phs_point(i_phs)%get (), & i_phs, cms = .true.) event_deps%phs_identifiers(i_phs)%evaluated = .true. end do end associate end select end subroutine evt_nlo_evaluate_real_kinematics @ %def evt_nlo_evaluate_real_kinematics @ This routine calls the evaluation of the singular regions only for the subtraction terms. <>= procedure :: compute_subtraction_sqmes => evt_nlo_compute_subtraction_sqmes <>= function evt_nlo_compute_subtraction_sqmes (evt) result (sqme) class(evt_nlo_t), intent(inout) :: evt real(default) :: sqme integer :: i_phs, i_term if (debug_on) call msg_debug (D_TRANSFORMS, "evt_nlo_compute_subtraction_sqmes") sqme = zero associate (event_deps => evt%event_deps) i_phs = 1; i_term = evt%i_evaluation_to_i_term(0) call evt%process_instance%compute_sqme_rad (i_term, i_phs, is_subtraction = .true.) sqme = sqme + evt%process_instance%get_sqme (i_term) end associate end function evt_nlo_compute_subtraction_sqmes @ %def evt_nlo_compute_subtraction_sqmes @ This routine calls the evaluation of the singular regions only for emission matrix elements. <>= procedure :: compute_real => evt_nlo_compute_real <>= subroutine evt_nlo_compute_real (evt) class(evt_nlo_t), intent(inout) :: evt integer :: i_phs, i_term if (debug_on) call msg_debug (D_TRANSFORMS, "evt_nlo_compute_real") i_phs = evt%get_i_phs () i_term = evt%i_evaluation_to_i_term (evt%i_evaluation) associate (event_deps => evt%event_deps) call evt%process_instance%compute_sqme_rad (i_term, i_phs, & is_subtraction = .false.) evt%sqme_rad = evt%process_instance%get_sqme (i_term) end associate end subroutine evt_nlo_compute_real @ %def evt_nlo_compute_real @ This routine calls the evaluation of the singular regions only for all emission matrix elements. This is needed for the combined mode. It returns the sum of all valid real matrix elements. <>= procedure :: compute_all_sqme_rad => evt_nlo_compute_all_sqme_rad <>= function evt_nlo_compute_all_sqme_rad (evt) result (sqme) class(evt_nlo_t), intent(inout) :: evt real(default) :: sqme integer :: i_phs, i_term if (debug_on) call msg_debug (D_TRANSFORMS, "evt_nlo_compute_all_sqme_rad") sqme = zero do i_term = 1, size (evt%process_instance%term) if (evt%is_valid_event (i_term)) then associate (term => evt%process_instance%term(i_term)) if (term%nlo_type == NLO_REAL .and. .not. term%is_subtraction ()) then i_phs = evt%process_instance%kin(i_term)%i_phs call evt%process_instance%compute_sqme_rad ( & i_term, i_phs, is_subtraction = .false.) sqme = sqme + evt%process_instance%get_sqme (i_term) end if end associate end if end do end function evt_nlo_compute_all_sqme_rad @ %def evt_nlo_compute_all_sqme_rad @ Boosts the given four vector [[p_lab]] to the Born or real CMS depending on the number of given momenta. Unfortunately, all boosts available via [[get_boost_to_cms]] are Born-like, so we need to compute the boost to the real CMS here manually. We cannot rely on [[i_term]] in order to determine whether to apply a Born-like or a real boost as we also need a real boost to compute the weights of the Born-like subevents as implemented in [[evt_nlo_generate_weighted]]. <>= procedure :: boost_to_cms => evt_nlo_boost_to_cms <>= function evt_nlo_boost_to_cms (evt, p_lab) result (p_cms) type(phs_point_t), intent(in) :: p_lab type(vector4_t) :: p0, p1 class(evt_nlo_t), intent(in) :: evt type(phs_point_t) :: p_cms type(lorentz_transformation_t) :: lt_lab_to_cms, lt real(default) :: sqrts_hat integer :: i_boost, n_legs_born if (evt%event_deps%lab_is_cm) then lt_lab_to_cms = identity else n_legs_born = size (evt%event_deps%p_born_lab%phs_point(1)) if (size (p_lab) == n_legs_born) then i_boost = evt%get_i_term () lt_lab_to_cms = evt%process_instance%get_boost_to_cms (i_boost) else sqrts_hat = (p_lab%select (1) + p_lab%select (2))**1 p0 = p_lab%select (1) + p_lab%select (2) lt = boost (p0, sqrts_hat) p1 = inverse(lt) * p_lab%select (1) lt_lab_to_cms = inverse (lt * rotation_to_2nd (3, space_part (p1))) end if end if p_cms = lt_lab_to_cms * p_lab end function evt_nlo_boost_to_cms @ %def evt_nlo_boost_to_cms @ Boosts the given four vector [[p_cms]] from the Born CMS to the lab system. It should not be called for ISR as in this case, the Born CMS and the real CMS differ. <>= procedure :: boost_to_lab => evt_nlo_boost_to_lab <>= function evt_nlo_boost_to_lab (evt, p_cms) result (p_lab) type(phs_point_t) :: p_lab class(evt_nlo_t), intent(in) :: evt type(phs_point_t), intent(in) :: p_cms type(lorentz_transformation_t) :: lt_cms_to_lab integer :: i_boost if (evt%event_deps%lab_is_cm) then lt_cms_to_lab = identity else i_boost = evt%get_i_term () lt_cms_to_lab = evt%process_instance%get_boost_to_lab (i_boost) end if p_lab = lt_cms_to_lab * p_cms end function evt_nlo_boost_to_lab @ %def evt_nlo_boost_to_lab @ <>= procedure :: setup_general_event_kinematics => evt_nlo_setup_general_event_kinematics <>= subroutine evt_nlo_setup_general_event_kinematics (evt, process_instance) class(evt_nlo_t), intent(inout) :: evt type(process_instance_t), intent(in) :: process_instance integer :: n_born associate (event_deps => evt%event_deps) event_deps%lab_is_cm = process_instance%lab_is_cm (1) select type (pcm => process_instance%pcm) type is (pcm_nlo_t) n_born = pcm%region_data%n_legs_born end select call event_deps%p_born_cms%init (n_born, 1) call event_deps%p_born_lab%init (n_born, 1) end associate end subroutine evt_nlo_setup_general_event_kinematics @ %def evt_nlo_setup_general_event_kinematics @ <>= procedure :: setup_real_event_kinematics => evt_nlo_setup_real_event_kinematics <>= subroutine evt_nlo_setup_real_event_kinematics (evt, process_instance) class(evt_nlo_t), intent(inout) :: evt type(process_instance_t), intent(in) :: process_instance integer :: n_real, n_phs integer :: i_real associate (event_deps => evt%event_deps) select type (pcm => process_instance%pcm) class is (pcm_nlo_t) n_real = pcm%region_data%n_legs_real end select i_real = evt%process%get_first_real_term () select type (phs => process_instance%kin(i_real)%phs) type is (phs_fks_t) event_deps%phs_identifiers = phs%phs_identifiers end select n_phs = size (event_deps%phs_identifiers) call event_deps%p_real_cms%init (n_real, n_phs) call event_deps%p_real_lab%init (n_real, n_phs) select type (pcm => process_instance%pcm) type is (pcm_nlo_t) if (allocated (pcm%region_data%alr_contributors)) then allocate (event_deps%contributors (size (pcm%region_data%alr_contributors))) event_deps%contributors = pcm%region_data%alr_contributors end if if (allocated (pcm%region_data%alr_to_i_contributor)) then allocate (event_deps%alr_to_i_con & (size (pcm%region_data%alr_to_i_contributor))) event_deps%alr_to_i_con = pcm%region_data%alr_to_i_contributor end if end select end associate end subroutine evt_nlo_setup_real_event_kinematics @ %def evt_nlo_setup_real_event_kinematics @ <>= procedure :: set_mode => evt_nlo_set_mode <>= subroutine evt_nlo_set_mode (evt, process_instance) class(evt_nlo_t), intent(inout) :: evt type(process_instance_t), intent(in) :: process_instance integer :: i_real select type (pcm => process_instance%pcm) type is (pcm_nlo_t) if (pcm%settings%combined_integration) then evt%mode = EVT_NLO_COMBINED else i_real = evt%process%get_first_real_component () if (i_real == evt%process%extract_active_component_mci ()) then evt%mode = EVT_NLO_SEPARATE_REAL else evt%mode = EVT_NLO_SEPARATE_BORNLIKE end if end if end select end subroutine evt_nlo_set_mode @ %def evt_nlo_set_mode @ <>= procedure :: is_valid_event => evt_nlo_is_valid_event <>= function evt_nlo_is_valid_event (evt, i_term) result (valid) logical :: valid class(evt_nlo_t), intent(in) :: evt integer, intent(in) :: i_term valid = evt%process_instance%term(i_term)%passed end function evt_nlo_is_valid_event @ %def evt_nlo_is_valid_event @ Retrieves the actual quantum numbers chosen in [[evt_nlo_prepare_new_event]]. <>= procedure :: get_selected_quantum_numbers => evt_nlo_get_selected_quantum_numbers <>= function evt_nlo_get_selected_quantum_numbers (evt, i_flv) result (qn_select) class(evt_nlo_t), intent(in) :: evt integer, intent(in) :: i_flv type(quantum_numbers_t), dimension(:), allocatable :: qn_select integer :: i_term, index i_term = evt%get_i_term () associate (term => evt%process_instance%term(i_term)) index = term%connected%matrix%get_qn_index (i_flv, i_sub = 0) qn_select = term%connected%matrix%get_quantum_numbers (index) end associate end function evt_nlo_get_selected_quantum_numbers @ %def evt_nlo_get_selected_quantum_numbers @ Selects a flavor structure for Born subevents, such that each possible flavor structure is as probable as its portion of the sum of Born matrix elements over all flavors. For non-Born Born-like subevents, no Born matrix elements are available. We always choose [[i_flv = 1]] in this case. If all terms are active, i.e. in a full NLO calculation, the flavors of Born-like subevents will be distributed according to the Born matrix elements only, to avoid issues with matrix elements of different sign and assure a LO flavor distribution. Likewise, the real-like event flavors are distributed according to the real matrix elements. Here, we need to make sure to not mix matrix elements from different real terms and instead determine the flavor for each subevent based on just the matrix elements for one of the terms. The implementation below assumes that in the sequence of NLO terms, the Born term is immediately followed by all the real terms which are again followed by the subtraction, the virtual and the DGLAP term. Both flavor structures can be determined without correlation as the flavors will only become important for events to be matched to a parton shower and in this case we will only generate either a single Born-like or a single real-like event which are not part of an event group. In case all subevents failed the cuts, all [[sqme]]s were set to $0$ so we cannot determine the flavor in this way. In this case, we always choose the first flavor structure given by the matrix-element generator with [[i_flv = 1]]. Ideally, having to choose a particle set here would not be necessary as it is also chosen in [[particle_set_init_interaction]] which in the current approach is disabled by supplying [[qn_select]] explicitly based on the flavors chosen here. <>= procedure :: prepare_new_event => evt_nlo_prepare_new_event <>= subroutine evt_nlo_prepare_new_event (evt, i_mci, i_term) class(evt_nlo_t), intent(inout) :: evt integer, intent(in) :: i_mci, i_term real(default) :: s, x real(default) :: sqme_total real(default), dimension(:), allocatable :: sqme_flv integer :: i, i_flv, i_core, emitter, n_in logical, save :: warn_once = .true. class(prc_core_t), pointer :: core => null () call evt%reset () call evt%rng%generate (x) do i = 1, size (evt%process_instance%term) associate (term => evt%process_instance%term(i)) if (evt%i_evaluation == 0) then if (term%nlo_type == BORN) then allocate (sqme_flv (term%config%data%n_flv)) exit end if else if (term%nlo_type == NLO_REAL .and. .not. term%is_subtraction()) then allocate (sqme_flv (term%config%data%n_flv)) exit end if end if end associate end do sqme_total = zero sqme_flv = zero i_core = evt%process%get_i_core (i_term) core => evt%process%get_core_ptr (i_core) do i = 1, size (evt%process_instance%term) associate (term => evt%process_instance%term(i)) if (i == evt%i_evaluation + 1 .and. (term%nlo_type == BORN .or. & (term%nlo_type == NLO_REAL .and. .not. term%is_subtraction())) ) then sqme_total = sqme_total + real (sum ( term%connected%matrix%get_matrix_element ())) !!! TODO (VR 2020-02-19) figure out why this select type is needed for prc_omega_t !!! For NLO and prc_omega_t the connected trace seems to be set up incorrectly! !!! (PS 2020-11-05) This leads to real events of processes with structure functions !!! having a wrong flavor distribution if computed with O'Mega. !!! The flavor distributions are identical with and also without the special case !!! for O'Mega and wrong in both cases. !!! However, this case it is not critical as long as O'Mega does not provide matrix elements !!! exclusive in coupling orders and is thus only rarely used for NLO applications anyways select type (core) class is (prc_external_t) do i_flv = 1, size (sqme_flv) sqme_flv(i_flv) = sqme_flv(i_flv) & + real (term%connected%matrix%get_matrix_element ( & term%connected%matrix%get_qn_index (i_flv, i_sub = 0))) end do class default sqme_flv = sqme_flv & + real (term%connected%matrix%get_matrix_element ()) emitter = evt%process_instance%kin(i)%emitter n_in = evt%process_instance%kin(i)%n_in if (warn_once .and. term%nlo_type == NLO_REAL .and. emitter <= n_in) then warn_once = .false. call msg_warning("evt_nlo_prepare_new_event: fNLO flavor& & distributions with O'Mega are wrong.") end if end select end if end associate end do if (debug2_active (D_TRANSFORMS)) then if (.not. nearly_equal(sqme_total, sum (sqme_flv))) then call msg_warning ("evt_nlo_prepare_new_event: & &sum over flavored sqmes does not match total sqme.") end if end if !!! Need absolute values to take into account negative weights x = x * abs (sqme_total) s = abs (sqme_flv (1)) evt%selected_i_flv = 1 if (s < x) then do i_flv = 2, size (sqme_flv) s = s + abs (sqme_flv (i_flv)) if (s > x) then evt%selected_i_flv = i_flv exit end if end do end if if (debug2_active (D_TRANSFORMS)) then call msg_print_color ("Selected i_flv: ", COL_GREEN) print *, evt%selected_i_flv end if end subroutine evt_nlo_prepare_new_event @ %def evt_nlo_prepare_new_event @ \section{Complete Events} This module combines hard processes with decay chains, shower, and hadronization (not implemented yet) to complete events. It also manages the input and output of event records in various formats. <<[[events.f90]]>>= <> module events <> <> <> use constants, only: one use io_units use format_utils, only: pac_fmt, write_separator use format_defs, only: FMT_12, FMT_19 use numeric_utils use diagnostics use variables use expr_base use model_data use state_matrices, only: FM_IGNORE_HELICITY, & FM_SELECT_HELICITY, FM_FACTOR_HELICITY, FM_CORRELATED_HELICITY use particles use subevt_expr use rng_base use process, only: process_t use instances, only: process_instance_t use pcm, only: pcm_nlo_workspace_t use process_stacks use event_base use event_transforms use decays use evt_nlo <> <> <> <> contains <> end module events @ %def events @ \subsection{Event configuration} The parameters govern the transformation of an event to a particle set. The [[safety_factor]] reduces the acceptance probability for unweighting. If greater than one, excess events become less likely, but the reweighting efficiency also drops. The [[sigma]] and [[n]] values, if nontrivial, allow for reweighting the events according to the requested [[norm_mode]]. Various [[parse_node_t]] objects are taken from the SINDARIN input. They encode expressions that apply to the current event. The workspaces for evaluating those expressions are set up in the [[event_expr_t]] objects. Note that these are really pointers, so the actual nodes are not stored inside the event object. <>= type :: event_config_t logical :: unweighted = .false. integer :: norm_mode = NORM_UNDEFINED integer :: factorization_mode = FM_IGNORE_HELICITY logical :: keep_correlations = .false. logical :: colorize_subevt = .false. real(default) :: sigma = 1 integer :: n = 1 real(default) :: safety_factor = 1 class(expr_factory_t), allocatable :: ef_selection class(expr_factory_t), allocatable :: ef_reweight class(expr_factory_t), allocatable :: ef_analysis contains <> end type event_config_t @ %def event_config_t @ Output. <>= procedure :: write => event_config_write <>= subroutine event_config_write (object, unit, show_expressions) class(event_config_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: show_expressions integer :: u u = given_output_unit (unit) write (u, "(3x,A,L1)") "Unweighted = ", object%unweighted write (u, "(3x,A,A)") "Normalization = ", & char (event_normalization_string (object%norm_mode)) write (u, "(3x,A)", advance="no") "Helicity handling = " select case (object%factorization_mode) case (FM_IGNORE_HELICITY) write (u, "(A)") "drop" case (FM_SELECT_HELICITY) write (u, "(A)") "select" case (FM_FACTOR_HELICITY) write (u, "(A)") "factorize" end select write (u, "(3x,A,L1)") "Keep correlations = ", object%keep_correlations if (object%colorize_subevt) then write (u, "(3x,A,L1)") "Colorize subevent = ", object%colorize_subevt end if if (.not. nearly_equal (object%safety_factor, one)) then write (u, "(3x,A," // FMT_12 // ")") & "Safety factor = ", object%safety_factor end if if (present (show_expressions)) then if (show_expressions) then if (allocated (object%ef_selection)) then call write_separator (u) write (u, "(3x,A)") "Event selection expression:" call object%ef_selection%write (u) end if if (allocated (object%ef_reweight)) then call write_separator (u) write (u, "(3x,A)") "Event reweighting expression:" call object%ef_reweight%write (u) end if if (allocated (object%ef_analysis)) then call write_separator (u) write (u, "(3x,A)") "Analysis expression:" call object%ef_analysis%write (u) end if end if end if end subroutine event_config_write @ %def event_config_write @ \subsection{The event type} This is the concrete implementation of the [[generic_event_t]] core that is defined above in the [[event_base]] module. The core manages the main (dressed) particle set pointer and the current values for weights and sqme. The implementation adds configuration data, expressions, process references, and event transforms. Each event refers to a single elementary process. This process may be dressed by a shower, a decay chain etc. We maintain pointers to a process instance. A list of event transforms (class [[evt_t]]) transform the connected interactions of the process instance into the final particle set. In this list, the first transform is always the trivial one, which just factorizes the process instance. Subsequent transforms may apply decays, etc. The [[particle_set]] pointer identifies the particle set that we want to be analyzed and returned by the event, usually the last one. Squared matrix element and weight values: when reading events from file, the [[ref]] value is the number in the file, while the [[prc]] value is the number that we calculate from the momenta in the file, possibly with different parameters. When generating events the first time, or if we do not recalculate, the numbers should coincide. Furthermore, the array of [[alt]] values is copied from an array of alternative event records. These values should represent calculated values. The [[sqme]] and [[weight]] values mirror corresponding values in the [[expr]] subobject. The idea is that when generating or reading events, the event record is filled first, then the [[expr]] object acquires copies. These copies are used for writing events and as targets for pointer variables in the analysis expression. All data that involve user-provided expressions (selection, reweighting, analysis) are handled by the [[expr]] subobject. In particular, evaluating the event-selection expression sets the [[passed]] flag. Furthermore, the [[expr]] subobject collects data that can be used in the analysis and should be written to file, including copies of [[sqme]] and [[weight]]. <>= public :: event_t <>= type, extends (generic_event_t) :: event_t type(event_config_t) :: config type(process_t), pointer :: process => null () type(process_instance_t), pointer :: instance => null () class(rng_t), allocatable :: rng integer :: selected_i_mci = 0 integer :: selected_i_term = 0 integer :: selected_channel = 0 logical :: is_complete = .false. class(evt_t), pointer :: transform_first => null () class(evt_t), pointer :: transform_last => null () type(event_expr_t) :: expr logical :: selection_evaluated = .false. logical :: passed = .false. real(default), allocatable :: alpha_qcd_forced real(default), allocatable :: scale_forced real(default) :: reweight = 1 logical :: analysis_flag = .false. integer :: i_event = 0 contains <> end type event_t @ %def event_t @ <>= procedure :: clone => event_clone <>= subroutine event_clone (event, event_new) class(event_t), intent(in), target :: event class(event_t), intent(out), target:: event_new type(string_t) :: id integer :: num_id event_new%config = event%config event_new%process => event%process event_new%instance => event%instance if (allocated (event%rng)) & allocate(event_new%rng, source=event%rng) event_new%selected_i_mci = event%selected_i_mci event_new%selected_i_term = event%selected_i_term event_new%selected_channel = event%selected_channel event_new%is_complete = event%is_complete event_new%transform_first => event%transform_first event_new%transform_last => event%transform_last event_new%selection_evaluated = event%selection_evaluated event_new%passed = event%passed if (allocated (event%alpha_qcd_forced)) & allocate(event_new%alpha_qcd_forced, source=event%alpha_qcd_forced) if (allocated (event%scale_forced)) & allocate(event_new%scale_forced, source=event%scale_forced) event_new%reweight = event%reweight event_new%analysis_flag = event%analysis_flag event_new%i_event = event%i_event id = event_new%process%get_id () if (id /= "") call event_new%expr%set_process_id (id) num_id = event_new%process%get_num_id () if (num_id /= 0) call event_new%expr%set_process_num_id (num_id) call event_new%expr%setup_vars (event_new%process%get_sqrts ()) call event_new%expr%link_var_list (event_new%process%get_var_list_ptr ()) end subroutine event_clone @ %def event_clone @ Finalizer: the list of event transforms is deleted iteratively. <>= procedure :: final => event_final <>= subroutine event_final (object) class(event_t), intent(inout) :: object class(evt_t), pointer :: evt if (allocated (object%rng)) call object%rng%final () call object%expr%final () do while (associated (object%transform_first)) evt => object%transform_first object%transform_first => evt%next call evt%final () deallocate (evt) end do end subroutine event_final @ %def event_final @ Output. The event index is written in the header, it should coincide with the [[event_index]] variable that can be used in selection and analysis. Particle set: this is a pointer to one of the event transforms, so it should suffice to print the latter. <>= procedure :: write => event_write <>= subroutine event_write (object, unit, show_process, show_transforms, & show_decay, verbose, testflag) class(event_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: show_process, show_transforms, show_decay logical, intent(in), optional :: verbose logical, intent(in), optional :: testflag logical :: prc, trans, dec, verb class(evt_t), pointer :: evt character(len=7) :: fmt integer :: u, i call pac_fmt (fmt, FMT_19, FMT_12, testflag) u = given_output_unit (unit) prc = .true.; if (present (show_process)) prc = show_process trans = .true.; if (present (show_transforms)) trans = show_transforms dec = .true.; if (present (show_decay)) dec = show_decay verb = .false.; if (present (verbose)) verb = verbose call write_separator (u, 2) write (u, "(1x,A)", advance="no") "Event" if (object%has_index ()) then write (u, "(1x,'#',I0)", advance="no") object%get_index () end if if (object%is_complete) then write (u, *) else write (u, "(1x,A)") "[incomplete]" end if call write_separator (u) call object%config%write (u) if (object%sqme_ref_is_known () .or. object%weight_ref_is_known ()) then call write_separator (u) end if if (object%sqme_ref_is_known ()) then write (u, "(3x,A," // fmt // ")") & "Squared matrix el. (ref) = ", object%get_sqme_ref () if (object%sqme_alt_is_known ()) then do i = 1, object%get_n_alt () write (u, "(5x,A," // fmt // ",1x,I0)") & "alternate sqme = ", object%get_sqme_alt(i), i end do end if end if if (object%sqme_prc_is_known ()) & write (u, "(3x,A," // fmt // ")") & "Squared matrix el. (prc) = ", object%get_sqme_prc () if (object%weight_ref_is_known ()) then write (u, "(3x,A," // fmt // ")") & "Event weight (ref) = ", object%get_weight_ref () if (object%weight_alt_is_known ()) then do i = 1, object%get_n_alt () write (u, "(5x,A," // fmt // ",1x,I0)") & "alternate weight = ", object%get_weight_alt(i), i end do end if end if if (object%weight_prc_is_known ()) & write (u, "(3x,A," // fmt // ")") & "Event weight (prc) = ", object%get_weight_prc () if (object%selected_i_mci /= 0) then call write_separator (u) write (u, "(3x,A,I0)") "Selected MCI group = ", object%selected_i_mci write (u, "(3x,A,I0)") "Selected term = ", object%selected_i_term write (u, "(3x,A,I0)") "Selected channel = ", object%selected_channel end if if (object%selection_evaluated) then call write_separator (u) write (u, "(3x,A,L1)") "Passed selection = ", object%passed if (object%passed) then write (u, "(3x,A," // fmt // ")") & "Reweighting factor = ", object%reweight write (u, "(3x,A,L1)") & "Analysis flag = ", object%analysis_flag end if end if if (associated (object%instance)) then if (prc) then if (verb) then call object%instance%write (u, testflag) else call object%instance%write_header (u) end if end if if (trans) then evt => object%transform_first do while (associated (evt)) select type (evt) type is (evt_decay_t) call evt%write (u, verbose = dec, more_verbose = verb, & testflag = testflag) class default call evt%write (u, verbose = verb, testflag = testflag) end select call write_separator (u, 2) evt => evt%next end do else call write_separator (u, 2) end if if (object%expr%subevt_filled) then call object%expr%write (u, pacified = testflag) call write_separator (u, 2) end if else call write_separator (u, 2) write (u, "(1x,A)") "Process instance: [undefined]" call write_separator (u, 2) end if end subroutine event_write @ %def event_write @ \subsection{Initialization} Initialize: set configuration parameters, using a variable list. We do not call this [[init]], because this method name will be used by a type extension. The default normalization is [[NORM_SIGMA]], since the default generation mode is weighted. For unweighted events, we may want to a apply a safety factor to event rejection. (By default, this factor is unity and can be ignored.) We also allocate the trivial event transform, which is always the first one. <>= procedure :: basic_init => event_init <>= subroutine event_init (event, var_list, n_alt) class(event_t), intent(out) :: event type(var_list_t), intent(in), optional :: var_list integer, intent(in), optional :: n_alt type(string_t) :: norm_string, mode_string logical :: polarized_events if (present (n_alt)) then call event%base_init (n_alt) call event%expr%init (n_alt) else call event%base_init (0) end if if (present (var_list)) then event%config%unweighted = var_list%get_lval (& var_str ("?unweighted")) norm_string = var_list%get_sval (& var_str ("$sample_normalization")) event%config%norm_mode = & event_normalization_mode (norm_string, event%config%unweighted) polarized_events = & var_list%get_lval (var_str ("?polarized_events")) if (polarized_events) then mode_string = & var_list%get_sval (var_str ("$polarization_mode")) select case (char (mode_string)) case ("ignore") event%config%factorization_mode = FM_IGNORE_HELICITY case ("helicity") event%config%factorization_mode = FM_SELECT_HELICITY case ("factorized") event%config%factorization_mode = FM_FACTOR_HELICITY case ("correlated") event%config%factorization_mode = FM_CORRELATED_HELICITY case default call msg_fatal ("Polarization mode " & // char (mode_string) // " is undefined") end select else event%config%factorization_mode = FM_IGNORE_HELICITY end if event%config%colorize_subevt = & var_list%get_lval (var_str ("?colorize_subevt")) if (event%config%unweighted) then event%config%safety_factor = var_list%get_rval (& var_str ("safety_factor")) end if else event%config%norm_mode = NORM_SIGMA end if allocate (evt_trivial_t :: event%transform_first) event%transform_last => event%transform_first end subroutine event_init @ %def event_init @ Set the [[sigma]] and [[n]] values in the configuration record that determine non-standard event normalizations. If these numbers are not set explicitly, the default value for both is unity, and event renormalization has no effect. <>= procedure :: set_sigma => event_set_sigma procedure :: set_n => event_set_n <>= elemental subroutine event_set_sigma (event, sigma) class(event_t), intent(inout) :: event real(default), intent(in) :: sigma event%config%sigma = sigma end subroutine event_set_sigma elemental subroutine event_set_n (event, n) class(event_t), intent(inout) :: event integer, intent(in) :: n event%config%n = n end subroutine event_set_n @ %def event_set_n @ Append an event transform (decays, etc.). The transform is not yet connected to a process. The transform is then considered to belong to the event object, and will be finalized together with it. The original pointer is removed. We can assume that the trivial transform is already present in the event object, at least. <>= procedure :: import_transform => event_import_transform <>= subroutine event_import_transform (event, evt) class(event_t), intent(inout) :: event class(evt_t), intent(inout), pointer :: evt event%transform_last%next => evt evt%previous => event%transform_last event%transform_last => evt evt => null () end subroutine event_import_transform @ %def event_import_transform @ We link the event to an existing process instance. This includes the variable list, which is linked to the process variable list. Note that this is not necessarily identical to the variable list used for event initialization. The variable list will contain pointers to [[event]] subobjects, therefore the [[target]] attribute. Once we have a process connected, we can use it to obtain an event generator instance. The model and process stack may be needed by event transforms. The current model setting may be different from the model in the process (regarding unstable particles, etc.). The process stack can be used for assigning extra processes that we need for the event transforms. <>= procedure :: connect => event_connect <>= subroutine event_connect (event, process_instance, model, process_stack) class(event_t), intent(inout), target :: event type(process_instance_t), intent(in), target :: process_instance class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack type(string_t) :: id integer :: num_id class(evt_t), pointer :: evt event%process => process_instance%process event%instance => process_instance id = event%process%get_id () if (id /= "") call event%expr%set_process_id (id) num_id = event%process%get_num_id () if (num_id /= 0) call event%expr%set_process_num_id (num_id) call event%expr%setup_vars (event%process%get_sqrts ()) call event%expr%link_var_list (event%process%get_var_list_ptr ()) call event%process%make_rng (event%rng) evt => event%transform_first do while (associated (evt)) call evt%connect (process_instance, model, process_stack) evt => evt%next end do end subroutine event_connect @ %def event_connect @ Set the parse nodes for the associated expressions, individually. The parse-node pointers may be null. <>= procedure :: set_selection => event_set_selection procedure :: set_reweight => event_set_reweight procedure :: set_analysis => event_set_analysis <>= subroutine event_set_selection (event, ef_selection) class(event_t), intent(inout) :: event class(expr_factory_t), intent(in) :: ef_selection allocate (event%config%ef_selection, source = ef_selection) end subroutine event_set_selection subroutine event_set_reweight (event, ef_reweight) class(event_t), intent(inout) :: event class(expr_factory_t), intent(in) :: ef_reweight allocate (event%config%ef_reweight, source = ef_reweight) end subroutine event_set_reweight subroutine event_set_analysis (event, ef_analysis) class(event_t), intent(inout) :: event class(expr_factory_t), intent(in) :: ef_analysis allocate (event%config%ef_analysis, source = ef_analysis) end subroutine event_set_analysis @ %def event_set_selection @ %def event_set_reweight @ %def event_set_analysis @ Create evaluation trees from the parse trees. The [[target]] attribute is required because the expressions contain pointers to event subobjects. <>= procedure :: setup_expressions => event_setup_expressions <>= subroutine event_setup_expressions (event) class(event_t), intent(inout), target :: event call event%expr%setup_selection (event%config%ef_selection) call event%expr%setup_analysis (event%config%ef_analysis) call event%expr%setup_reweight (event%config%ef_reweight) call event%expr%colorize (event%config%colorize_subevt) end subroutine event_setup_expressions @ %def event_setup_expressions @ \subsection{Evaluation} To fill the [[particle_set]], i.e., the event record proper, we have to apply all event transforms in order. The last transform should fill its associated particle set, factorizing the state matrix according to the current settings. There are several parameters in the event configuration that control this. We always fill the particle set for the first transform (the hard process) and the last transform, if different from the first (the fully dressed process). Each event transform is an event generator of its own. We choose to generate an \emph{unweighted} event for each of them, even if the master event is assumed to be weighted. Thus, the overall event weight is the one of the hard process only. (There may be more options in future extensions.) We can generate the two random numbers that the factorization needs. For testing purpose, we allow for providing them explicitly, as an option. <>= procedure :: evaluate_transforms => event_evaluate_transforms <>= subroutine event_evaluate_transforms (event, r) class(event_t), intent(inout) :: event real(default), dimension(:), intent(in), optional :: r class(evt_t), pointer :: evt real(default) :: weight_over_sqme integer :: i_term, emitter, n_in logical :: failed_but_keep failed_but_keep = .false. if (debug_on) call msg_debug (D_TRANSFORMS, "event_evaluate_transforms") call event%discard_particle_set () call event%check () if (event%instance%is_complete_event ()) then i_term = event%instance%select_i_term () event%selected_i_term = i_term evt => event%transform_first do while (associated (evt)) call evt%prepare_new_event & (event%selected_i_mci, event%selected_i_term) evt => evt%next end do if (debug_on) call msg_debug & (D_TRANSFORMS, "Before event transformations") if (debug_on) call msg_debug & (D_TRANSFORMS, "event%weight_prc", event%weight_prc) if (debug_on) call msg_debug & (D_TRANSFORMS, "event%sqme_prc", event%sqme_prc) evt => event%transform_first do while (associated (evt)) call print_transform_name_if_debug () if (evt%only_weighted_events) then select type (evt) type is (evt_nlo_t) i_term = evt%get_i_term () failed_but_keep = .not. evt%is_valid_event (i_term) & .and. evt%keep_failed_events if (.not. any(evt%process_instance%term%passed .and. evt%process_instance%term%active) & .and. .not. evt%keep_failed_events) return end select if (abs (event%weight_prc) > 0._default) then weight_over_sqme = event%weight_prc / event%sqme_prc call evt%generate_weighted (event%sqme_prc) event%weight_prc = weight_over_sqme * event%sqme_prc select type (evt) type is (evt_nlo_t) if (.not. evt%is_valid_event (i_term)) event%weight_prc = 0 end select else if (.not. failed_but_keep) exit end if else call evt%generate_unweighted () end if if (signal_is_pending ()) return select type (evt) type is (evt_nlo_t) if (evt%i_evaluation > 0) then emitter = evt%process_instance%kin(i_term)%emitter n_in = evt%process_instance%kin(i_term)%n_in if (emitter <= n_in) then call evt%connected_set_real_IS_momenta () end if end if end select call evt%make_particle_set (event%config%factorization_mode, & event%config%keep_correlations) if (signal_is_pending ()) return if (.not. evt%particle_set_exists) exit evt => evt%next end do evt => event%transform_last if ((associated (evt) .and. evt%particle_set_exists) .or. failed_but_keep) then if (event%is_nlo ()) then select type (evt) type is (evt_nlo_t) evt%particle_set_nlo (event%i_event + 1) = evt%particle_set evt%i_evaluation = evt%i_evaluation + 1 call event%link_particle_set & (evt%particle_set_nlo(event%i_event + 1)) end select else call event%link_particle_set (evt%particle_set) end if end if if (debug_on) call msg_debug & (D_TRANSFORMS, "After event transformations") if (debug_on) call msg_debug & (D_TRANSFORMS, "event%weight_prc", event%weight_prc) if (debug_on) call msg_debug & (D_TRANSFORMS, "event%sqme_prc", event%sqme_prc) if (debug_on) call msg_debug & (D_TRANSFORMS, "evt%particle_set_exists", evt%particle_set_exists) end if contains subroutine print_transform_name_if_debug () if (debug_active (D_TRANSFORMS)) then print *, 'Current event transform: ' call evt%write_name () end if end subroutine print_transform_name_if_debug end subroutine event_evaluate_transforms @ %def event_evaluate_transforms @ Set / increment the event index for the current event. There is no condition for this to happen. The event index is actually stored in the subevent expression, because this allows us to access it in subevent expressions as a variable. <>= procedure :: set_index => event_set_index procedure :: increment_index => event_increment_index <>= subroutine event_set_index (event, index) class(event_t), intent(inout) :: event integer, intent(in) :: index call event%expr%set_event_index (index) end subroutine event_set_index subroutine event_increment_index (event, offset) class(event_t), intent(inout) :: event integer, intent(in), optional :: offset call event%expr%increment_event_index (offset) end subroutine event_increment_index @ %def event_set_index @ %def event_increment_index @ Evaluate the event-related expressions, given a valid [[particle_set]]. If [[update_sqme]] is set, we use the process instance for the [[sqme_prc]] value. The [[sqme_ref]] value is always taken from the event record. <>= procedure :: evaluate_expressions => event_evaluate_expressions <>= subroutine event_evaluate_expressions (event) class(event_t), intent(inout) :: event if (event%has_valid_particle_set ()) then call event%expr%fill_subevt (event%get_particle_set_ptr ()) end if if (event%weight_ref_is_known ()) then call event%expr%set (weight_ref = event%get_weight_ref ()) end if if (event%weight_prc_is_known ()) then call event%expr%set (weight_prc = event%get_weight_prc ()) end if if (event%excess_prc_is_known ()) then call event%expr%set (excess_prc = event%get_excess_prc ()) end if if (event%sqme_ref_is_known ()) then call event%expr%set (sqme_ref = event%get_sqme_ref ()) end if if (event%sqme_prc_is_known ()) then call event%expr%set (sqme_prc = event%get_sqme_prc ()) end if if (event%has_valid_particle_set ()) then call event%expr%evaluate & (event%passed, event%reweight, event%analysis_flag) event%selection_evaluated = .true. end if end subroutine event_evaluate_expressions @ %def event_evaluate_expressions @ Report the result of the [[selection]] evaluation. <>= procedure :: passed_selection => event_passed_selection <>= function event_passed_selection (event) result (flag) class(event_t), intent(in) :: event logical :: flag flag = event%passed end function event_passed_selection @ %def event_passed_selection @ Set alternate sqme and weight arrays. This should be merged with the previous routine, if the expressions are allowed to refer to these values. <>= procedure :: store_alt_values => event_store_alt_values <>= subroutine event_store_alt_values (event) class(event_t), intent(inout) :: event if (event%weight_alt_is_known ()) then call event%expr%set (weight_alt = event%get_weight_alt ()) end if if (event%sqme_alt_is_known ()) then call event%expr%set (sqme_alt = event%get_sqme_alt ()) end if end subroutine event_store_alt_values @ %def event_store_alt_values @ <>= procedure :: is_nlo => event_is_nlo <>= function event_is_nlo (event) result (is_nlo) logical :: is_nlo class(event_t), intent(in) :: event if (associated (event%instance)) then select type (pcm_work => event%instance%pcm_work) type is (pcm_nlo_workspace_t) is_nlo = pcm_work%is_fixed_order_nlo_events () class default is_nlo = .false. end select else is_nlo = .false. end if end function event_is_nlo @ %def event_is_nlo @ \subsection{Reset to empty state} Applying this, current event contents are marked as incomplete but are not deleted. In particular, the initialization is kept. The event index is also kept, this can be reset separately. <>= procedure :: reset_contents => event_reset_contents procedure :: reset_index => event_reset_index <>= subroutine event_reset_contents (event) class(event_t), intent(inout) :: event class(evt_t), pointer :: evt call event%base_reset_contents () event%selected_i_mci = 0 event%selected_i_term = 0 event%selected_channel = 0 event%is_complete = .false. call event%expr%reset_contents () event%selection_evaluated = .false. event%passed = .false. event%analysis_flag = .false. if (associated (event%instance)) then call event%instance%reset (reset_mci = .true.) end if if (allocated (event%alpha_qcd_forced)) deallocate (event%alpha_qcd_forced) if (allocated (event%scale_forced)) deallocate (event%scale_forced) evt => event%transform_first do while (associated (evt)) call evt%reset () evt => evt%next end do end subroutine event_reset_contents subroutine event_reset_index (event) class(event_t), intent(inout) :: event call event%expr%reset_event_index () end subroutine event_reset_index @ %def event_reset_contents @ %def event_reset_index @ \subsection{Squared Matrix Element and Weight} Transfer the result of the process instance calculation to the event record header. <>= procedure :: import_instance_results => event_import_instance_results <>= subroutine event_import_instance_results (event) class(event_t), intent(inout) :: event if (associated (event%instance)) then if (event%instance%has_evaluated_trace ()) then call event%set ( & sqme_prc = event%instance%get_sqme (), & weight_prc = event%instance%get_weight (), & excess_prc = event%instance%get_excess (), & n_dropped = event%instance%get_n_dropped () & ) end if end if end subroutine event_import_instance_results @ %def event_import_instance_results @ Duplicate the instance result / the reference result in the event record. <>= procedure :: accept_sqme_ref => event_accept_sqme_ref procedure :: accept_sqme_prc => event_accept_sqme_prc procedure :: accept_weight_ref => event_accept_weight_ref procedure :: accept_weight_prc => event_accept_weight_prc <>= subroutine event_accept_sqme_ref (event) class(event_t), intent(inout) :: event if (event%sqme_ref_is_known ()) then call event%set (sqme_prc = event%get_sqme_ref ()) end if end subroutine event_accept_sqme_ref subroutine event_accept_sqme_prc (event) class(event_t), intent(inout) :: event if (event%sqme_prc_is_known ()) then call event%set (sqme_ref = event%get_sqme_prc ()) end if end subroutine event_accept_sqme_prc subroutine event_accept_weight_ref (event) class(event_t), intent(inout) :: event if (event%weight_ref_is_known ()) then call event%set (weight_prc = event%get_weight_ref ()) end if end subroutine event_accept_weight_ref subroutine event_accept_weight_prc (event) class(event_t), intent(inout) :: event if (event%weight_prc_is_known ()) then call event%set (weight_ref = event%get_weight_prc ()) end if end subroutine event_accept_weight_prc @ %def event_accept_sqme_ref @ %def event_accept_sqme_prc @ %def event_accept_weight_ref @ %def event_accept_weight_prc @ Update the weight normalization, just after generation. Unweighted and weighted events are generated with a different default normalization. The intended normalization is stored in the configuration record. <>= procedure :: update_normalization => event_update_normalization <>= subroutine event_update_normalization (event, mode_ref) class(event_t), intent(inout) :: event integer, intent(in), optional :: mode_ref integer :: mode_old real(default) :: weight, excess if (present (mode_ref)) then mode_old = mode_ref else if (event%config%unweighted) then mode_old = NORM_UNIT else mode_old = NORM_SIGMA end if weight = event%get_weight_prc () call event_normalization_update (weight, & event%config%sigma, event%config%n, & mode_new = event%config%norm_mode, & mode_old = mode_old) call event%set_weight_prc (weight) excess = event%get_excess_prc () call event_normalization_update (excess, & event%config%sigma, event%config%n, & mode_new = event%config%norm_mode, & mode_old = mode_old) call event%set_excess_prc (excess) end subroutine event_update_normalization @ %def event_update_normalization @ The event is complete if it has a particle set plus valid entries for the sqme and weight values. <>= procedure :: check => event_check <>= subroutine event_check (event) class(event_t), intent(inout) :: event event%is_complete = event%has_valid_particle_set () & .and. event%sqme_ref_is_known () & .and. event%sqme_prc_is_known () & .and. event%weight_ref_is_known () & .and. event%weight_prc_is_known () if (event%get_n_alt () /= 0) then event%is_complete = event%is_complete & .and. event%sqme_alt_is_known () & .and. event%weight_alt_is_known () end if end subroutine event_check @ %def event_check @ @ \subsection{Generation} Assuming that we have a valid process associated to the event, we generate an event. We complete the event data, then factorize the spin density matrix and transfer it to the particle set. When done, we retrieve squared matrix element and weight. In case of explicit generation, the reference values coincide with the process values, so we [[accept]] the latter. The explicit random number argument [[r]] should be generated by a random-number generator. It is taken for the factorization algorithm, bypassing the event-specific random-number generator. This is useful for deterministic testing. <>= procedure :: generate => event_generate <>= subroutine event_generate (event, i_mci, r, i_nlo) class(event_t), intent(inout) :: event integer, intent(in) :: i_mci real(default), dimension(:), intent(in), optional :: r integer, intent(in), optional :: i_nlo logical :: generate_new generate_new = .true. if (present (i_nlo)) generate_new = (i_nlo == 1) if (generate_new) call event%reset_contents () event%selected_i_mci = i_mci if (event%config%unweighted) then call event%instance%generate_unweighted_event (i_mci) if (signal_is_pending ()) return call event%instance%evaluate_event_data () call event%instance%normalize_weight () else if (generate_new) & call event%instance%generate_weighted_event (i_mci) if (signal_is_pending ()) return call event%instance%evaluate_event_data () end if event%selected_channel = event%instance%get_channel () call event%import_instance_results () call event%accept_sqme_prc () call event%update_normalization () call event%accept_weight_prc () call event%evaluate_transforms (r) if (signal_is_pending ()) return call event%check () end subroutine event_generate @ %def event_generate @ Get a copy of the particle set belonging to the hard process. <>= procedure :: get_hard_particle_set => event_get_hard_particle_set <>= subroutine event_get_hard_particle_set (event, pset) class(event_t), intent(in) :: event type(particle_set_t), intent(out) :: pset class(evt_t), pointer :: evt evt => event%transform_first pset = evt%particle_set end subroutine event_get_hard_particle_set @ %def event_get_hard_particle_set @ \subsection{Recovering an event} Select MC group, term, and integration channel. <>= procedure :: select => event_select <>= subroutine event_select (event, i_mci, i_term, channel) class(event_t), intent(inout) :: event integer, intent(in) :: i_mci, i_term, channel if (associated (event%instance)) then event%selected_i_mci = i_mci event%selected_i_term = i_term event%selected_channel = channel else event%selected_i_mci = 0 event%selected_i_term = 0 event%selected_channel = 0 end if end subroutine event_select @ %def event_select @ Copy a particle set into the event record. We deliberately use the first (the trivial) transform for this, i.e., the hard process. The event reader may either read in the transformed event separately, or apply all event transforms to the hard particle set to (re)generate a fully dressed event. Since this makes all subsequent event transforms invalid, we call [[reset]] on them. <>= procedure :: set_hard_particle_set => event_set_hard_particle_set <>= subroutine event_set_hard_particle_set (event, particle_set) class(event_t), intent(inout) :: event type(particle_set_t), intent(in) :: particle_set class(evt_t), pointer :: evt evt => event%transform_first call evt%set_particle_set (particle_set, & event%selected_i_mci, event%selected_i_term) call event%link_particle_set (evt%particle_set) evt => evt%next do while (associated (evt)) call evt%reset () evt => evt%next end do end subroutine event_set_hard_particle_set @ %def event_set_hard_particle_set @ Set the $\alpha_s$ value that should be used in a recalculation. This should be called only if we explicitly want to override the QCD setting of the process core. <>= procedure :: set_alpha_qcd_forced => event_set_alpha_qcd_forced <>= subroutine event_set_alpha_qcd_forced (event, alpha_qcd) class(event_t), intent(inout) :: event real(default), intent(in) :: alpha_qcd if (allocated (event%alpha_qcd_forced)) then event%alpha_qcd_forced = alpha_qcd else allocate (event%alpha_qcd_forced, source = alpha_qcd) end if end subroutine event_set_alpha_qcd_forced @ %def event_set_alpha_qcd_forced @ Analogously, for the common scale. This forces also renormalization and factorization scale. <>= procedure :: set_scale_forced => event_set_scale_forced <>= subroutine event_set_scale_forced (event, scale) class(event_t), intent(inout) :: event real(default), intent(in) :: scale if (allocated (event%scale_forced)) then event%scale_forced = scale else allocate (event%scale_forced, source = scale) end if end subroutine event_set_scale_forced @ %def event_set_scale_forced @ Here we try to recover an event from the [[particle_set]] subobject and recalculate the structure functions and matrix elements. We have the appropriate [[process]] object and an initialized [[process_instance]] at hand, so beam and configuration data are known. From the [[particle_set]], we get the momenta. The quantum-number information may be incomplete, e.g., helicity information may be partial or absent. We recover the event just from the momentum configuration. We do not transfer the matrix element from the process instance to the event record, as we do when generating an event. The event record may contain the matrix element as read from file, and the current calculation may use different parameters. We thus can compare old and new values. The event [[weight]] may also be known already. If yes, we pass it to the [[evaluate_event_data]] procedure. It should already be normalized. If we have a [[weight_factor]] value, we obtain the event weight by multiplying the computed [[sqme]] by this factor. Otherwise, we make use of the MCI setup (which should be valid then) to compute the event weight, and we should normalize the result just as when generating events. Evaluating event expressions must also be done separately. If [[recover_phs]] is set (and false), do not attempt any phase-space calculation, including MCI evaluation. Useful if we need only matrix elements. <>= procedure :: recalculate => event_recalculate <>= subroutine event_recalculate (event, update_sqme, weight_factor, & recover_beams, recover_phs, check_match, success) class(event_t), intent(inout) :: event logical, intent(in) :: update_sqme real(default), intent(in), optional :: weight_factor logical, intent(in), optional :: recover_beams logical, intent(in), optional :: recover_phs logical, intent(in), optional :: check_match logical, intent(out), optional :: success type(particle_set_t), pointer :: particle_set integer :: i_mci, i_term, channel logical :: rec_phs_mci rec_phs_mci = .true.; if (present (recover_phs)) rec_phs_mci = recover_phs if (present (success)) success = .false. if (event%has_valid_particle_set ()) then particle_set => event%get_particle_set_ptr () i_mci = event%selected_i_mci i_term = event%selected_i_term channel = event%selected_channel if (i_mci == 0 .or. i_term == 0 .or. channel == 0) then call msg_bug ("Event: recalculate: undefined selection parameters") end if call event%instance%choose_mci (i_mci) call event%instance%set_trace & (particle_set, i_term, recover_beams, check_match, success) if (present (success)) then if (.not. success) return end if if (allocated (event%alpha_qcd_forced)) then call event%instance%set_alpha_qcd_forced & (i_term, event%alpha_qcd_forced) end if call event%instance%recover (channel, i_term, & update_sqme, rec_phs_mci, event%scale_forced) if (signal_is_pending ()) return if (update_sqme .and. present (weight_factor)) then call event%instance%evaluate_event_data & (weight = event%instance%get_sqme () * weight_factor) else if (event%weight_ref_is_known ()) then call event%instance%evaluate_event_data & (weight = event%get_weight_ref ()) else if (rec_phs_mci) then call event%instance%recover_event () if (signal_is_pending ()) return call event%instance%evaluate_event_data () if (event%config%unweighted) then call event%instance%normalize_weight () end if end if if (signal_is_pending ()) return if (update_sqme) then call event%import_instance_results () else call event%accept_sqme_ref () call event%accept_weight_ref () end if else call msg_bug ("Event: can't recalculate, particle set is undefined") end if end subroutine event_recalculate @ %def event_recalculate @ \subsection{Access content} Pointer to the associated process object (the associated model). <>= procedure :: get_process_ptr => event_get_process_ptr procedure :: get_process_instance_ptr => event_get_process_instance_ptr procedure :: get_model_ptr => event_get_model_ptr <>= function event_get_process_ptr (event) result (ptr) class(event_t), intent(in) :: event type(process_t), pointer :: ptr ptr => event%process end function event_get_process_ptr function event_get_process_instance_ptr (event) result (ptr) class(event_t), intent(in) :: event type(process_instance_t), pointer :: ptr ptr => event%instance end function event_get_process_instance_ptr function event_get_model_ptr (event) result (model) class(event_t), intent(in) :: event class(model_data_t), pointer :: model if (associated (event%process)) then model => event%process%get_model_ptr () else model => null () end if end function event_get_model_ptr @ %def event_get_process_ptr @ %def event_get_process_instance_ptr @ %def event_get_model_ptr @ Return the current values of indices: the MCI group of components, the term index (different terms corresponding, potentially, to different effective kinematics), and the MC integration channel. The [[i_mci]] call is delegated to the current process instance. <>= procedure :: get_i_mci => event_get_i_mci procedure :: get_i_term => event_get_i_term procedure :: get_channel => event_get_channel <>= function event_get_i_mci (event) result (i_mci) class(event_t), intent(in) :: event integer :: i_mci i_mci = event%selected_i_mci end function event_get_i_mci function event_get_i_term (event) result (i_term) class(event_t), intent(in) :: event integer :: i_term i_term = event%selected_i_term end function event_get_i_term function event_get_channel (event) result (channel) class(event_t), intent(in) :: event integer :: channel channel = event%selected_channel end function event_get_channel @ %def event_get_i_mci @ %def event_get_i_term @ %def event_get_channel @ This flag tells us whether the event consists just of a hard process (i.e., holds at most the first, trivial transform), or is a dressed events with additional transforms. <>= procedure :: has_transform => event_has_transform <>= function event_has_transform (event) result (flag) class(event_t), intent(in) :: event logical :: flag if (associated (event%transform_first)) then flag = associated (event%transform_first%next) else flag = .false. end if end function event_has_transform @ %def event_has_transform @ Return the currently selected normalization mode, or alternate normalization mode. <>= procedure :: get_norm_mode => event_get_norm_mode <>= elemental function event_get_norm_mode (event) result (norm_mode) class(event_t), intent(in) :: event integer :: norm_mode norm_mode = event%config%norm_mode end function event_get_norm_mode @ %def event_get_norm_mode @ Return the kinematical weight, defined as the ratio of event weight and squared matrix element. <>= procedure :: get_kinematical_weight => event_get_kinematical_weight <>= function event_get_kinematical_weight (event) result (f) class(event_t), intent(in) :: event real(default) :: f if (event%sqme_ref_is_known () .and. event%weight_ref_is_known () & .and. abs (event%get_sqme_ref ()) > 0) then f = event%get_weight_ref () / event%get_sqme_ref () else f = 0 end if end function event_get_kinematical_weight @ %def event_get_kinematical_weight @ Return data used by external event formats. <>= procedure :: has_index => event_has_index procedure :: get_index => event_get_index procedure :: get_fac_scale => event_get_fac_scale procedure :: get_alpha_s => event_get_alpha_s procedure :: get_sqrts => event_get_sqrts procedure :: get_polarization => event_get_polarization procedure :: get_beam_file => event_get_beam_file procedure :: get_process_name => event_get_process_name <>= function event_has_index (event) result (flag) class(event_t), intent(in) :: event logical :: flag flag = event%expr%has_event_index () end function event_has_index function event_get_index (event) result (index) class(event_t), intent(in) :: event integer :: index index = event%expr%get_event_index () end function event_get_index function event_get_fac_scale (event) result (fac_scale) class(event_t), intent(in) :: event real(default) :: fac_scale fac_scale = event%instance%get_fac_scale (event%selected_i_term) end function event_get_fac_scale function event_get_alpha_s (event) result (alpha_s) class(event_t), intent(in) :: event real(default) :: alpha_s alpha_s = event%instance%get_alpha_s (event%selected_i_term) end function event_get_alpha_s function event_get_sqrts (event) result (sqrts) class(event_t), intent(in) :: event real(default) :: sqrts sqrts = event%instance%get_sqrts () end function event_get_sqrts function event_get_polarization (event) result (pol) class(event_t), intent(in) :: event real(default), dimension(:), allocatable :: pol pol = event%instance%get_polarization () end function event_get_polarization function event_get_beam_file (event) result (file) class(event_t), intent(in) :: event type(string_t) :: file file = event%instance%get_beam_file () end function event_get_beam_file function event_get_process_name (event) result (name) class(event_t), intent(in) :: event type(string_t) :: name name = event%instance%get_process_name () end function event_get_process_name @ %def event_get_index @ %def event_get_fac_scale @ %def event_get_alpha_s @ %def event_get_sqrts @ %def event_get_polarization @ %def event_get_beam_file @ %def event_get_process_name @ Return the actual number of calls, as stored in the process instance. <>= procedure :: get_actual_calls_total => event_get_actual_calls_total <>= elemental function event_get_actual_calls_total (event) result (n) class(event_t), intent(in) :: event integer :: n if (associated (event%instance)) then n = event%instance%get_actual_calls_total () else n = 0 end if end function event_get_actual_calls_total @ %def event_get_actual_calls_total @ Eliminate numerical noise in the [[subevt]] expression and in the event transforms (which includes associated process instances). <>= public :: pacify <>= interface pacify module procedure pacify_event end interface pacify <>= subroutine pacify_event (event) class(event_t), intent(inout) :: event class(evt_t), pointer :: evt call event%pacify_particle_set () if (event%expr%subevt_filled) call pacify (event%expr) evt => event%transform_first do while (associated (evt)) select type (evt) type is (evt_decay_t); call pacify (evt) end select evt => evt%next end do end subroutine pacify_event @ %def pacify @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[events_ut.f90]]>>= <> module events_ut use unit_tests use events_uti <> <> contains <> end module events_ut @ %def events_ut @ <<[[events_uti.f90]]>>= <> module events_uti <> <> use os_interface use model_data use particles use process_libraries use process_stacks use event_transforms use decays use decays_ut, only: prepare_testbed use process, only: process_t use instances, only: process_instance_t use events <> <> contains <> end module events_uti @ %def events_uti @ API: driver for the unit tests below. <>= public :: events_test <>= subroutine events_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine events_test @ %def events_test @ \subsubsection{Empty event record} <>= call test (events_1, "events_1", & "empty event record", & u, results) <>= public :: events_1 <>= subroutine events_1 (u) integer, intent(in) :: u type(event_t), target :: event write (u, "(A)") "* Test output: events_1" write (u, "(A)") "* Purpose: display an empty event object" write (u, "(A)") call event%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: events_1" end subroutine events_1 @ %def events_1 @ \subsubsection{Simple event} <>= call test (events_2, "events_2", & "generate event", & u, results) <>= public :: events_2 <>= subroutine events_2 (u) use processes_ut, only: prepare_test_process, cleanup_test_process integer, intent(in) :: u type(event_t), allocatable, target :: event type(process_t), allocatable, target :: process type(process_instance_t), allocatable, target :: process_instance type(model_data_t), target :: model write (u, "(A)") "* Test output: events_2" write (u, "(A)") "* Purpose: generate and display an event" write (u, "(A)") call model%init_test () write (u, "(A)") "* Generate test process event" allocate (process) allocate (process_instance) call prepare_test_process (process, process_instance, model) call process_instance%setup_event_data () write (u, "(A)") write (u, "(A)") "* Initialize event object" allocate (event) call event%basic_init () call event%connect (process_instance, process%get_model_ptr ()) write (u, "(A)") write (u, "(A)") "* Generate test process event" call process_instance%generate_weighted_event (1) write (u, "(A)") write (u, "(A)") "* Fill event object" write (u, "(A)") call event%generate (1, [0.4_default, 0.4_default]) call event%increment_index () call event%evaluate_expressions () call event%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call event%final () deallocate (event) call cleanup_test_process (process, process_instance) deallocate (process_instance) deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: events_2" end subroutine events_2 @ %def events_2 @ \subsubsection{Recovering an event} Generate an event and store the particle set. Then reset the event record, recall the particle set, and recover the event from that. <>= call test (events_4, "events_4", & "recover event", & u, results) <>= public :: events_4 <>= subroutine events_4 (u) use processes_ut, only: prepare_test_process, cleanup_test_process integer, intent(in) :: u type(event_t), allocatable, target :: event type(process_t), allocatable, target :: process type(process_instance_t), allocatable, target :: process_instance type(process_t), allocatable, target :: process2 type(process_instance_t), allocatable, target :: process2_instance type(particle_set_t) :: particle_set type(model_data_t), target :: model write (u, "(A)") "* Test output: events_4" write (u, "(A)") "* Purpose: generate and recover an event" write (u, "(A)") call model%init_test () write (u, "(A)") "* Generate test process event and save particle set" write (u, "(A)") allocate (process) allocate (process_instance) call prepare_test_process (process, process_instance, model) call process_instance%setup_event_data () allocate (event) call event%basic_init () call event%connect (process_instance, process%get_model_ptr ()) call event%generate (1, [0.4_default, 0.4_default]) call event%increment_index () call event%evaluate_expressions () call event%write (u) particle_set = event%get_particle_set_ptr () ! NB: 'particle_set' contains pointers to the model within 'process' call event%final () deallocate (event) write (u, "(A)") write (u, "(A)") "* Recover event from particle set" write (u, "(A)") allocate (process2) allocate (process2_instance) call prepare_test_process (process2, process2_instance, model) call process2_instance%setup_event_data () allocate (event) call event%basic_init () call event%connect (process2_instance, process2%get_model_ptr ()) call event%select (1, 1, 1) call event%set_hard_particle_set (particle_set) call event%recalculate (update_sqme = .true.) call event%write (u) write (u, "(A)") write (u, "(A)") "* Transfer sqme and evaluate expressions" write (u, "(A)") call event%accept_sqme_prc () call event%accept_weight_prc () call event%check () call event%set_index (1) call event%evaluate_expressions () call event%write (u) write (u, "(A)") write (u, "(A)") "* Reset contents" write (u, "(A)") call event%reset_contents () call event%reset_index () event%transform_first%particle_set_exists = .false. call event%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call particle_set%final () call event%final () deallocate (event) call cleanup_test_process (process2, process2_instance) deallocate (process2_instance) deallocate (process2) call cleanup_test_process (process, process_instance) deallocate (process_instance) deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: events_4" end subroutine events_4 @ %def events_4 @ \subsubsection{Partially Recovering an event} Generate an event and store the particle set. Then reset the event record, recall the particle set, and recover the event as far as possible without recomputing the squared matrix element. <>= call test (events_5, "events_5", & "partially recover event", & u, results) <>= public :: events_5 <>= subroutine events_5 (u) use processes_ut, only: prepare_test_process, cleanup_test_process integer, intent(in) :: u type(event_t), allocatable, target :: event type(process_t), allocatable, target :: process type(process_instance_t), allocatable, target :: process_instance type(process_t), allocatable, target :: process2 type(process_instance_t), allocatable, target :: process2_instance type(particle_set_t) :: particle_set real(default) :: sqme, weight type(model_data_t), target :: model write (u, "(A)") "* Test output: events_5" write (u, "(A)") "* Purpose: generate and recover an event" write (u, "(A)") call model%init_test () write (u, "(A)") "* Generate test process event and save particle set" write (u, "(A)") allocate (process) allocate (process_instance) call prepare_test_process (process, process_instance, model) call process_instance%setup_event_data () allocate (event) call event%basic_init () call event%connect (process_instance, process%get_model_ptr ()) call event%generate (1, [0.4_default, 0.4_default]) call event%increment_index () call event%evaluate_expressions () call event%write (u) particle_set = event%get_particle_set_ptr () sqme = event%get_sqme_ref () weight = event%get_weight_ref () call event%final () deallocate (event) write (u, "(A)") write (u, "(A)") "* Recover event from particle set" write (u, "(A)") allocate (process2) allocate (process2_instance) call prepare_test_process (process2, process2_instance, model) call process2_instance%setup_event_data () allocate (event) call event%basic_init () call event%connect (process2_instance, process2%get_model_ptr ()) call event%select (1, 1, 1) call event%set_hard_particle_set (particle_set) call event%recalculate (update_sqme = .false.) call event%write (u) write (u, "(A)") write (u, "(A)") "* Manually set sqme and evaluate expressions" write (u, "(A)") call event%set (sqme_ref = sqme, weight_ref = weight) call event%accept_sqme_ref () call event%accept_weight_ref () call event%set_index (1) call event%evaluate_expressions () call event%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call particle_set%final () call event%final () deallocate (event) call cleanup_test_process (process2, process2_instance) deallocate (process2_instance) deallocate (process2) call cleanup_test_process (process, process_instance) deallocate (process_instance) deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: events_5" end subroutine events_5 @ %def events_5 @ \subsubsection{Decays} Generate an event with subsequent decays. <>= call test (events_6, "events_6", & "decays", & u, results) <>= public :: events_6 <>= subroutine events_6 (u) integer, intent(in) :: u type(os_data_t) :: os_data class(model_data_t), pointer :: model type(string_t) :: prefix, procname1, procname2 type(process_library_t), target :: lib type(process_stack_t) :: process_stack class(evt_t), pointer :: evt_decay type(event_t), allocatable, target :: event type(process_t), pointer :: process type(process_instance_t), allocatable, target :: process_instance write (u, "(A)") "* Test output: events_6" write (u, "(A)") "* Purpose: generate an event with subsequent decays" write (u, "(A)") write (u, "(A)") "* Generate test process and decay" write (u, "(A)") call os_data%init () prefix = "events_6" procname1 = prefix // "_p" procname2 = prefix // "_d" call prepare_testbed & (lib, process_stack, prefix, os_data, & scattering=.true., decay=.true.) write (u, "(A)") "* Initialize decay process" process => process_stack%get_process_ptr (procname1) model => process%get_model_ptr () call model%set_unstable (25, [procname2]) allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data () call process_instance%init_simulation (1) write (u, "(A)") write (u, "(A)") "* Initialize event transform: decay" allocate (evt_decay_t :: evt_decay) call evt_decay%connect (process_instance, model, process_stack) write (u, "(A)") write (u, "(A)") "* Initialize event object" write (u, "(A)") allocate (event) call event%basic_init () call event%connect (process_instance, model) call event%import_transform (evt_decay) call event%write (u, show_decay = .true.) write (u, "(A)") write (u, "(A)") "* Generate event" write (u, "(A)") call event%generate (1, [0.4_default, 0.4_default]) call event%increment_index () call event%evaluate_expressions () call event%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call event%final () deallocate (event) call process_instance%final () deallocate (process_instance) call process_stack%final () write (u, "(A)") write (u, "(A)") "* Test output end: events_6" end subroutine events_6 @ %def events_6 @ \subsubsection{Decays} Generate a decay event with varying options. <>= call test (events_7, "events_7", & "decay options", & u, results) <>= public :: events_7 <>= subroutine events_7 (u) integer, intent(in) :: u type(os_data_t) :: os_data class(model_data_t), pointer :: model type(string_t) :: prefix, procname2 type(process_library_t), target :: lib type(process_stack_t) :: process_stack type(process_t), pointer :: process type(process_instance_t), allocatable, target :: process_instance write (u, "(A)") "* Test output: events_7" write (u, "(A)") "* Purpose: check decay options" write (u, "(A)") write (u, "(A)") "* Prepare test process" write (u, "(A)") call os_data%init () prefix = "events_7" procname2 = prefix // "_d" call prepare_testbed & (lib, process_stack, prefix, os_data, & scattering=.false., decay=.true.) write (u, "(A)") "* Generate decay event, default options" write (u, "(A)") process => process_stack%get_process_ptr (procname2) model => process%get_model_ptr () call model%set_unstable (25, [procname2]) allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data (model) call process_instance%init_simulation (1) call process_instance%generate_weighted_event (1) call process_instance%write (u) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Generate decay event, helicity-diagonal decay" write (u, "(A)") process => process_stack%get_process_ptr (procname2) model => process%get_model_ptr () call model%set_unstable (25, [procname2], diagonal = .true.) allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data (model) call process_instance%init_simulation (1) call process_instance%generate_weighted_event (1) call process_instance%write (u) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Generate decay event, isotropic decay, & &polarized final state" write (u, "(A)") process => process_stack%get_process_ptr (procname2) model => process%get_model_ptr () call model%set_unstable (25, [procname2], isotropic = .true.) call model%set_polarized (6) call model%set_polarized (-6) allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data (model) call process_instance%init_simulation (1) call process_instance%generate_weighted_event (1) call process_instance%write (u) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Cleanup" call process_stack%final () write (u, "(A)") write (u, "(A)") "* Test output end: events_7" end subroutine events_7 @ %def events_7 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Raw Event I/O} The raw format is for internal use only. All data are stored unformatted, so they can be efficiently be re-read on the same machine, but not necessarily on another machine. This module explicitly depends on the [[events]] module which provides the concrete implementation of [[event_base]]. The other I/O formats access only the methods that are defined in [[event_base]]. <<[[eio_raw.f90]]>>= <> module eio_raw <> <> use io_units use diagnostics use model_data use particles use event_base use event_handles, only: event_handle_t use eio_data use eio_base use events <> <> <> <> contains <> end module eio_raw @ %def eio_raw @ \subsection{File Format Version} This is the current default file version. <>= integer, parameter :: CURRENT_FILE_VERSION = 2 @ %def CURRENT_FILE_VERSION @ The user may change this number; this should force some compatibility mode for reading and writing. In any case, the file version stored in a event file that we read has to match the expected file version. History of version numbers: \begin{enumerate} \item Format for WHIZARD 2.2.0 to 2.2.3. No version number stored in the raw file. \item Format from 2.2.4 on. File contains version number. The file contains the transformed particle set (if applicable) after the hard-process particle set. \end{enumerate} @ \subsection{Type} Note the file version number. The default may be reset during initialization, which should enforce some compatibility mode. <>= public :: eio_raw_t <>= type, extends (eio_t) :: eio_raw_t logical :: reading = .false. logical :: writing = .false. integer :: unit = 0 integer :: norm_mode = NORM_UNDEFINED real(default) :: sigma = 1 integer :: n = 1 integer :: n_alt = 0 logical :: check = .false. logical :: use_alphas_from_file = .false. logical :: use_scale_from_file = .false. logical :: fixed_order_nlo = .false. integer :: file_version = CURRENT_FILE_VERSION contains <> end type eio_raw_t @ %def eio_raw_t @ Output. This is not the actual event format, but a readable account of the current object status. <>= procedure :: write => eio_raw_write <>= subroutine eio_raw_write (object, unit) class(eio_raw_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Raw event stream:" write (u, "(3x,A,L1)") "Check MD5 sum = ", object%check if (object%n_alt > 0) then write (u, "(3x,A,I0)") "Alternate weights = ", object%n_alt end if write (u, "(3x,A,L1)") "Alpha_s from file = ", & object%use_alphas_from_file write (u, "(3x,A,L1)") "Scale from file = ", & object%use_scale_from_file write (u, "(3x,A,L1)") "Events for fNLO = ", & object%fixed_order_nlo if (object%reading) then write (u, "(3x,A,A)") "Reading from file = ", char (object%filename) else if (object%writing) then write (u, "(3x,A,A)") "Writing to file = ", char (object%filename) else write (u, "(3x,A)") "[closed]" end if end subroutine eio_raw_write @ %def eio_raw_write @ Finalizer: close any open file. <>= procedure :: final => eio_raw_final <>= subroutine eio_raw_final (object) class(eio_raw_t), intent(inout) :: object if (object%reading .or. object%writing) then write (msg_buffer, "(A,A,A)") "Events: closing raw file '", & char (object%filename), "'" call msg_message () close (object%unit) object%reading = .false. object%writing = .false. end if end subroutine eio_raw_final @ %def eio_raw_final @ Set the [[check]] flag which determines whether we compare checksums on input. <>= procedure :: set_parameters => eio_raw_set_parameters <>= subroutine eio_raw_set_parameters (eio, check, use_alphas_from_file, & use_scale_from_file, fixed_order_nlo, version_string, extension) class(eio_raw_t), intent(inout) :: eio logical, intent(in), optional :: check, use_alphas_from_file, & use_scale_from_file, fixed_order_nlo type(string_t), intent(in), optional :: version_string type(string_t), intent(in), optional :: extension if (present (check)) eio%check = check if (present (use_alphas_from_file)) eio%use_alphas_from_file = & use_alphas_from_file if (present (use_scale_from_file)) eio%use_scale_from_file = & use_scale_from_file if (present (fixed_order_nlo)) eio%fixed_order_nlo = & fixed_order_nlo if (present (version_string)) then select case (char (version_string)) case ("", "2.2.4") eio%file_version = CURRENT_FILE_VERSION case ("2.2") eio%file_version = 1 case default call msg_fatal ("Raw event I/O: unsupported version '" & // char (version_string) // "'") eio%file_version = 0 end select end if if (present (extension)) then eio%extension = extension else eio%extension = "evx" end if end subroutine eio_raw_set_parameters @ %def eio_raw_set_parameters @ Initialize event writing. <>= procedure :: init_out => eio_raw_init_out <>= subroutine eio_raw_init_out (eio, sample, data, success, extension) class(eio_raw_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(event_sample_data_t), intent(in), optional :: data logical, intent(out), optional :: success type(string_t), intent(in), optional :: extension character(32) :: md5sum_prc, md5sum_cfg character(32), dimension(:), allocatable :: md5sum_alt integer :: i if (present (extension)) then eio%extension = extension else eio%extension = "evx" end if eio%filename = sample // "." // eio%extension eio%unit = free_unit () write (msg_buffer, "(A,A,A)") "Events: writing to raw file '", & char (eio%filename), "'" call msg_message () eio%writing = .true. if (present (data)) then md5sum_prc = data%md5sum_prc md5sum_cfg = data%md5sum_cfg eio%norm_mode = data%norm_mode eio%sigma = data%total_cross_section eio%n = data%n_evt eio%n_alt = data%n_alt if (eio%n_alt > 0) then !!! !!! !!! Workaround for gfortran 5.0 ICE allocate (md5sum_alt (data%n_alt)) md5sum_alt = data%md5sum_alt !!! allocate (md5sum_alt (data%n_alt), source = data%md5sum_alt) end if else md5sum_prc = "" md5sum_cfg = "" end if open (eio%unit, file = char (eio%filename), form = "unformatted", & action = "write", status = "replace") select case (eio%file_version) case (2:); write (eio%unit) eio%file_version end select write (eio%unit) md5sum_prc write (eio%unit) md5sum_cfg write (eio%unit) eio%norm_mode write (eio%unit) eio%n_alt if (allocated (md5sum_alt)) then do i = 1, eio%n_alt write (eio%unit) md5sum_alt(i) end do end if if (present (success)) success = .true. end subroutine eio_raw_init_out @ %def eio_raw_init_out @ Initialize event reading. <>= procedure :: init_in => eio_raw_init_in <>= subroutine eio_raw_init_in (eio, sample, data, success, extension) class(eio_raw_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(event_sample_data_t), intent(inout), optional :: data logical, intent(out), optional :: success type(string_t), intent(in), optional :: extension character(32) :: md5sum_prc, md5sum_cfg character(32), dimension(:), allocatable :: md5sum_alt integer :: i, file_version if (present (success)) success = .true. if (present (extension)) then eio%extension = extension else eio%extension = "evx" end if eio%filename = sample // "." // eio%extension eio%unit = free_unit () if (present (data)) then eio%sigma = data%total_cross_section eio%n = data%n_evt end if write (msg_buffer, "(A,A,A)") "Events: reading from raw file '", & char (eio%filename), "'" call msg_message () eio%reading = .true. open (eio%unit, file = char (eio%filename), form = "unformatted", & action = "read", status = "old") select case (eio%file_version) case (2:); read (eio%unit) file_version case default; file_version = 1 end select if (file_version /= eio%file_version) then call msg_error ("Reading event file: raw-file version mismatch.") if (present (success)) success = .false. return else if (file_version /= CURRENT_FILE_VERSION) then call msg_warning ("Reading event file: compatibility mode.") end if read (eio%unit) md5sum_prc read (eio%unit) md5sum_cfg read (eio%unit) eio%norm_mode read (eio%unit) eio%n_alt if (present (data)) then if (eio%n_alt /= data%n_alt) then if (present (success)) success = .false. return end if end if allocate (md5sum_alt (eio%n_alt)) do i = 1, eio%n_alt read (eio%unit) md5sum_alt(i) end do if (present (success)) then if (present (data)) then if (eio%check) then if (data%md5sum_prc /= "") then success = success .and. md5sum_prc == data%md5sum_prc end if if (data%md5sum_cfg /= "") then success = success .and. md5sum_cfg == data%md5sum_cfg end if do i = 1, eio%n_alt if (data%md5sum_alt(i) /= "") then success = success .and. md5sum_alt(i) == data%md5sum_alt(i) end if end do else call msg_warning ("Reading event file: MD5 sum check disabled") end if end if end if end subroutine eio_raw_init_in @ %def eio_raw_init_in @ Switch from input to output: reopen the file for reading. <>= procedure :: switch_inout => eio_raw_switch_inout <>= subroutine eio_raw_switch_inout (eio, success) class(eio_raw_t), intent(inout) :: eio logical, intent(out), optional :: success write (msg_buffer, "(A,A,A)") "Events: appending to raw file '", & char (eio%filename), "'" call msg_message () close (eio%unit, status = "keep") eio%reading = .false. open (eio%unit, file = char (eio%filename), form = "unformatted", & action = "write", position = "append", status = "old") eio%writing = .true. if (present (success)) success = .true. end subroutine eio_raw_switch_inout @ %def eio_raw_switch_inout @ Output an event. Write first the event indices, then weight and squared matrix element, then the particle set. We always write the particle set of the hard process. (Note: this should be reconsidered.) We do make a physical copy. On output, we write the [[prc]] values for weight and sqme, since these are the values just computed. On input, we store the values as [[ref]] values. The caller can then decide whether to recompute values and thus obtain distinct [[prc]] values, or just accept them. The [[passed]] flag is not written. This allow us to apply different selection criteria upon rereading. <>= procedure :: output => eio_raw_output <>= subroutine eio_raw_output & (eio, event, i_prc, reading, passed, pacify, event_handle) class(eio_raw_t), intent(inout) :: eio class(generic_event_t), intent(in), target :: event logical, intent(in), optional :: reading, passed, pacify class(event_handle_t), intent(inout), optional :: event_handle integer, intent(in) :: i_prc type(particle_set_t), pointer :: pset integer :: i if (eio%writing) then if (event%has_valid_particle_set ()) then select type (event) type is (event_t) write (eio%unit) i_prc write (eio%unit) event%get_index () write (eio%unit) event%get_i_mci () write (eio%unit) event%get_i_term () write (eio%unit) event%get_channel () write (eio%unit) event%expr%weight_prc write (eio%unit) event%expr%excess_prc write (eio%unit) event%get_n_dropped () write (eio%unit) event%expr%sqme_prc do i = 1, eio%n_alt write (eio%unit) event%expr%weight_alt(i) write (eio%unit) event%expr%sqme_alt(i) end do allocate (pset) call event%get_hard_particle_set (pset) call pset%write_raw (eio%unit) call pset%final () deallocate (pset) select case (eio%file_version) case (2:) if (event%has_transform ()) then write (eio%unit) .true. pset => event%get_particle_set_ptr () call pset%write_raw (eio%unit) else write (eio%unit) .false. end if end select class default call msg_bug ("Event: write raw: defined only for full event_t") end select else call msg_bug ("Event: write raw: particle set is undefined") end if else call eio%write () call msg_fatal ("Raw event file is not open for writing") end if end subroutine eio_raw_output @ %def eio_raw_output @ Input an event. Note: the particle set is physically copied. If there is a performance issue, we might choose to pointer-assign it instead, with a different version of [[event%set_hard_particle_set]]. <>= procedure :: input_i_prc => eio_raw_input_i_prc procedure :: input_event => eio_raw_input_event <>= subroutine eio_raw_input_i_prc (eio, i_prc, iostat) class(eio_raw_t), intent(inout) :: eio integer, intent(out) :: i_prc integer, intent(out) :: iostat if (eio%reading) then read (eio%unit, iostat = iostat) i_prc else call eio%write () call msg_fatal ("Raw event file is not open for reading") end if end subroutine eio_raw_input_i_prc subroutine eio_raw_input_event (eio, event, iostat, event_handle) class(eio_raw_t), intent(inout) :: eio class(generic_event_t), intent(inout), target :: event integer, intent(out) :: iostat class(event_handle_t), intent(inout), optional :: event_handle integer :: event_index, i_mci, i_term, channel, i real(default) :: weight, excess, sqme integer :: n_dropped real(default), dimension(:), allocatable :: weight_alt, sqme_alt logical :: has_transform type(particle_set_t), pointer :: pset class(model_data_t), pointer :: model if (eio%reading) then select type (event) type is (event_t) read (eio%unit, iostat = iostat) event_index if (iostat /= 0) return read (eio%unit, iostat = iostat) i_mci if (iostat /= 0) return read (eio%unit, iostat = iostat) i_term if (iostat /= 0) return read (eio%unit, iostat = iostat) channel if (iostat /= 0) return read (eio%unit, iostat = iostat) weight if (iostat /= 0) return read (eio%unit, iostat = iostat) excess if (iostat /= 0) return read (eio%unit, iostat = iostat) n_dropped if (iostat /= 0) return read (eio%unit, iostat = iostat) sqme if (iostat /= 0) return call event%reset_contents () call event%set_index (event_index) call event%select (i_mci, i_term, channel) if (eio%norm_mode /= NORM_UNDEFINED) then call event_normalization_update (weight, & eio%sigma, eio%n, event%get_norm_mode (), eio%norm_mode) call event_normalization_update (excess, & eio%sigma, eio%n, event%get_norm_mode (), eio%norm_mode) end if call event%set (sqme_ref = sqme, weight_ref = weight, & excess_prc = excess, & n_dropped = n_dropped) if (eio%n_alt /= 0) then allocate (sqme_alt (eio%n_alt), weight_alt (eio%n_alt)) do i = 1, eio%n_alt read (eio%unit, iostat = iostat) weight_alt(i) if (iostat /= 0) return read (eio%unit, iostat = iostat) sqme_alt(i) if (iostat /= 0) return end do call event%set (sqme_alt = sqme_alt, weight_alt = weight_alt) end if model => null () if (associated (event%process)) then model => event%process%get_model_ptr () end if allocate (pset) call pset%read_raw (eio%unit, iostat) if (iostat /= 0) return if (associated (model)) call pset%set_model (model) call event%set_hard_particle_set (pset) if (eio%use_alphas_from_file .or. eio%use_scale_from_file) then call event%recalculate (update_sqme = .true.) if (eio%fixed_order_nlo) then if (event%weight_prc /= event%weight_ref .and. & event%weight_prc == 0) then event%weight_prc = event%weight_ref end if end if end if call pset%final () deallocate (pset) select case (eio%file_version) case (2:) read (eio%unit, iostat = iostat) has_transform if (iostat /= 0) return if (has_transform) then allocate (pset) call pset%read_raw (eio%unit, iostat) if (iostat /= 0) return if (associated (model)) & call pset%set_model (model) call event%link_particle_set (pset) end if end select class default call msg_bug ("Event: read raw: defined only for full event_t") end select else call eio%write () call msg_fatal ("Raw event file is not open for reading") end if end subroutine eio_raw_input_event @ %def eio_raw_input_i_prc @ %def eio_raw_input_event @ <>= procedure :: skip => eio_raw_skip <>= subroutine eio_raw_skip (eio, iostat) class(eio_raw_t), intent(inout) :: eio integer, intent(out) :: iostat if (eio%reading) then read (eio%unit, iostat = iostat) else call eio%write () call msg_fatal ("Raw event file is not open for reading") end if end subroutine eio_raw_skip @ %def eio_raw_skip @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[eio_raw_ut.f90]]>>= <> module eio_raw_ut use unit_tests use eio_raw_uti <> <> contains <> end module eio_raw_ut @ %def eio_raw_ut @ <<[[eio_raw_uti.f90]]>>= <> module eio_raw_uti <> <> use model_data use variables use events use eio_data use eio_base use eio_raw use process, only: process_t use instances, only: process_instance_t <> <> contains <> end module eio_raw_uti @ %def eio_raw_uti @ API: driver for the unit tests below. <>= public :: eio_raw_test <>= subroutine eio_raw_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine eio_raw_test @ %def eio_raw_test @ \subsubsection{Test I/O methods} We test the implementation of all I/O methods. <>= call test (eio_raw_1, "eio_raw_1", & "read and write event contents", & u, results) <>= public :: eio_raw_1 <>= subroutine eio_raw_1 (u) use processes_ut, only: prepare_test_process, cleanup_test_process integer, intent(in) :: u type(model_data_t), target :: model type(event_t), allocatable, target :: event type(process_t), allocatable, target :: process type(process_instance_t), allocatable, target :: process_instance class(eio_t), allocatable :: eio integer :: i_prc, iostat type(string_t) :: sample write (u, "(A)") "* Test output: eio_raw_1" write (u, "(A)") "* Purpose: generate and read/write an event" write (u, "(A)") write (u, "(A)") "* Initialize test process" call model%init_test () allocate (process) allocate (process_instance) call prepare_test_process (process, process_instance, model, & run_id = var_str ("run_test")) call process_instance%setup_event_data () allocate (event) call event%basic_init () call event%connect (process_instance, process%get_model_ptr ()) write (u, "(A)") write (u, "(A)") "* Generate and write an event" write (u, "(A)") sample = "eio_raw_1" allocate (eio_raw_t :: eio) call eio%init_out (sample) call event%generate (1, [0._default, 0._default]) call event%increment_index () call event%evaluate_expressions () call event%write (u) write (u, "(A)") call eio%output (event, i_prc = 42) call eio%write (u) call eio%final () call event%final () deallocate (event) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Re-read the event" write (u, "(A)") call eio%init_in (sample) allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data () allocate (event) call event%basic_init () call event%connect (process_instance, process%get_model_ptr ()) call eio%input_i_prc (i_prc, iostat) if (iostat /= 0) write (u, "(A,I0)") "I/O error (i_prc):", iostat call eio%input_event (event, iostat) if (iostat /= 0) write (u, "(A,I0)") "I/O error (event):", iostat call eio%write (u) write (u, "(A)") write (u, "(1x,A,I0)") "i_prc = ", i_prc write (u, "(A)") call event%write (u) write (u, "(A)") write (u, "(A)") "* Generate and append another event" write (u, "(A)") call eio%switch_inout () call event%generate (1, [0._default, 0._default]) call event%increment_index () call event%evaluate_expressions () call event%write (u) write (u, "(A)") call eio%output (event, i_prc = 5) call eio%write (u) call eio%final () call event%final () deallocate (event) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Re-read both events" write (u, "(A)") call eio%init_in (sample) allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data () allocate (event) call event%basic_init () call event%connect (process_instance, process%get_model_ptr ()) call eio%input_i_prc (i_prc, iostat) if (iostat /= 0) write (u, "(A,I0)") "I/O error (i_prc/1):", iostat call eio%input_event (event, iostat) if (iostat /= 0) write (u, "(A,I0)") "I/O error (event/1):", iostat call eio%input_i_prc (i_prc, iostat) if (iostat /= 0) write (u, "(A,I0)") "I/O error (i_prc/2):", iostat call eio%input_event (event, iostat) if (iostat /= 0) write (u, "(A,I0)") "I/O error (event/2):", iostat call eio%write (u) write (u, "(A)") write (u, "(1x,A,I0)") "i_prc = ", i_prc write (u, "(A)") call event%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio%final () deallocate (eio) call event%final () deallocate (event) call cleanup_test_process (process, process_instance) deallocate (process_instance) deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: eio_raw_1" end subroutine eio_raw_1 @ %def eio_raw_1 @ \subsubsection{Test I/O methods} We test the implementation of all I/O methods. <>= call test (eio_raw_2, "eio_raw_2", & "handle multiple weights", & u, results) <>= public :: eio_raw_2 <>= subroutine eio_raw_2 (u) use processes_ut, only: prepare_test_process, cleanup_test_process integer, intent(in) :: u type(model_data_t), target :: model type(var_list_t) :: var_list type(event_t), allocatable, target :: event type(process_t), allocatable, target :: process type(process_instance_t), allocatable, target :: process_instance type(event_sample_data_t) :: data class(eio_t), allocatable :: eio integer :: i_prc, iostat type(string_t) :: sample write (u, "(A)") "* Test output: eio_raw_2" write (u, "(A)") "* Purpose: generate and read/write an event" write (u, "(A)") "* with multiple weights" write (u, "(A)") call model%init_test () write (u, "(A)") "* Initialize test process" allocate (process) allocate (process_instance) call prepare_test_process (process, process_instance, model, & run_id = var_str ("run_test")) call process_instance%setup_event_data () call data%init (n_proc = 1, n_alt = 2) - call var_list_append_log (var_list, var_str ("?unweighted"), .false., & + call var_list%append_log (var_str ("?unweighted"), .false., & intrinsic = .true.) - call var_list_append_string (var_list, var_str ("$sample_normalization"), & + call var_list%append_string (var_str ("$sample_normalization"), & var_str ("auto"), intrinsic = .true.) - call var_list_append_real (var_list, var_str ("safety_factor"), & + call var_list%append_real (var_str ("safety_factor"), & 1._default, intrinsic = .true.) allocate (event) call event%basic_init (var_list, n_alt = 2) call event%connect (process_instance, process%get_model_ptr ()) write (u, "(A)") write (u, "(A)") "* Generate and write an event" write (u, "(A)") sample = "eio_raw_2" allocate (eio_raw_t :: eio) call eio%init_out (sample, data) call event%generate (1, [0._default, 0._default]) call event%increment_index () call event%evaluate_expressions () call event%set (sqme_alt = [2._default, 3._default]) call event%set (weight_alt = & [2 * event%get_weight_ref (), 3 * event%get_weight_ref ()]) call event%store_alt_values () call event%check () call event%write (u) write (u, "(A)") call eio%output (event, i_prc = 42) call eio%write (u) call eio%final () call event%final () deallocate (event) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Re-read the event" write (u, "(A)") call eio%init_in (sample, data) allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data () allocate (event) call event%basic_init (var_list, n_alt = 2) call event%connect (process_instance, process%get_model_ptr ()) call eio%input_i_prc (i_prc, iostat) if (iostat /= 0) write (u, "(A,I0)") "I/O error (i_prc):", iostat call eio%input_event (event, iostat) if (iostat /= 0) write (u, "(A,I0)") "I/O error (event):", iostat call eio%write (u) write (u, "(A)") write (u, "(1x,A,I0)") "i_prc = ", i_prc write (u, "(A)") call event%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio%final () deallocate (eio) call event%final () deallocate (event) call cleanup_test_process (process, process_instance) deallocate (process_instance) deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: eio_raw_2" end subroutine eio_raw_2 @ %def eio_raw_2 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Dispatch} An event transform is responsible for dressing a partonic event. Since event transforms are not mutually exclusive but are concatenated, we provide individual dispatchers for each of them. <<[[dispatch_transforms.f90]]>>= <> module dispatch_transforms <> <> use process use variables use system_defs, only: LF use system_dependencies, only: LHAPDF6_AVAILABLE use sf_lhapdf, only: lhapdf_initialize use diagnostics use models use os_interface use beam_structures use resonances, only: resonance_history_set_t use instances, only: process_instance_t, process_instance_hook_t use event_base, only: event_callback_t, event_callback_nop_t use hepmc_interface, only: HEPMC3_MODE_HEPMC2, HEPMC3_MODE_HEPMC3 use hepmc_interface, only: HEPMC3_MODE_ROOT, HEPMC3_MODE_ROOTTREE use hepmc_interface, only: HEPMC3_MODE_HEPEVT use eio_base use eio_raw use eio_checkpoints use eio_callback use eio_lhef use eio_hepmc use eio_lcio use eio_stdhep use eio_ascii use eio_weights use eio_dump use event_transforms use resonance_insertion use isr_epa_handler use decays use shower_base use shower_core use shower use shower_pythia6 use shower_pythia8 use hadrons use mlm_matching use powheg_matching use ckkw_matching use tauola_interface !NODEP! use evt_nlo <> <> contains <> end module dispatch_transforms @ %def dispatch_transforms @ <>= public :: dispatch_evt_nlo <>= subroutine dispatch_evt_nlo (evt, keep_failed_events) class(evt_t), intent(out), pointer :: evt logical, intent(in) :: keep_failed_events call msg_message ("Simulate: activating fixed-order NLO events") allocate (evt_nlo_t :: evt) evt%only_weighted_events = .true. select type (evt) type is (evt_nlo_t) evt%i_evaluation = 0 evt%keep_failed_events = keep_failed_events end select end subroutine dispatch_evt_nlo @ %def dispatch_evt_nlo @ <>= public :: dispatch_evt_resonance <>= subroutine dispatch_evt_resonance (evt, var_list, res_history_set, libname) class(evt_t), intent(out), pointer :: evt type(var_list_t), intent(in) :: var_list type(resonance_history_set_t), dimension(:), intent(in) :: res_history_set type(string_t), intent(in) :: libname logical :: resonance_history resonance_history = var_list%get_lval (var_str ("?resonance_history")) if (resonance_history) then allocate (evt_resonance_t :: evt) call msg_message ("Simulate: activating resonance insertion") select type (evt) type is (evt_resonance_t) call evt%set_resonance_data (res_history_set) call evt%set_library (libname) end select else evt => null () end if end subroutine dispatch_evt_resonance @ %def dispatch_evt_resonance @ Initialize the ISR/EPA handler, depending on active settings. The activation is independent for both handlers, since only one may be needed at a time. However, if both handlers are active, the current implementation requires the handler modes of ISR and EPA to coincide. <>= public :: dispatch_evt_isr_epa_handler <>= subroutine dispatch_evt_isr_epa_handler (evt, var_list) class(evt_t), intent(out), pointer :: evt type(var_list_t), intent(in) :: var_list logical :: isr_recoil logical :: epa_recoil logical :: isr_handler_active logical :: epa_handler_active type(string_t) :: isr_handler_mode type(string_t) :: epa_handler_mode logical :: isr_keep_mass real(default) :: sqrts real(default) :: isr_q_max real(default) :: epa_q_max real(default) :: isr_mass real(default) :: epa_mass isr_handler_active = var_list%get_lval (var_str ("?isr_handler")) if (isr_handler_active) then call msg_message ("Simulate: activating ISR handler") isr_recoil = & var_list%get_lval (var_str ("?isr_recoil")) isr_handler_mode = & var_list%get_sval (var_str ("$isr_handler_mode")) isr_keep_mass = & var_list%get_lval (var_str ("?isr_handler_keep_mass")) if (isr_recoil) then call msg_fatal ("Simulate: ISR handler is incompatible & &with ?isr_recoil=true") end if end if epa_handler_active = var_list%get_lval (var_str ("?epa_handler")) if (epa_handler_active) then call msg_message ("Simulate: activating EPA handler") epa_recoil = var_list%get_lval (var_str ("?epa_recoil")) epa_handler_mode = var_list%get_sval (var_str ("$epa_handler_mode")) if (epa_recoil) then call msg_fatal ("Simulate: EPA handler is incompatible & &with ?epa_recoil=true") end if end if if (isr_handler_active .and. epa_handler_active) then if (isr_handler_mode /= epa_handler_mode) then call msg_fatal ("Simulate: ISR/EPA handler: modes must coincide") end if end if if (isr_handler_active .or. epa_handler_active) then allocate (evt_isr_epa_t :: evt) select type (evt) type is (evt_isr_epa_t) if (isr_handler_active) then call evt%set_mode_string (isr_handler_mode) else call evt%set_mode_string (epa_handler_mode) end if sqrts = var_list%get_rval (var_str ("sqrts")) if (isr_handler_active) then isr_q_max = var_list%get_rval (var_str ("isr_q_max")) isr_mass = var_list%get_rval (var_str ("isr_mass")) call evt%set_data_isr (sqrts, isr_q_max, isr_mass, isr_keep_mass) end if if (epa_handler_active) then epa_q_max = var_list%get_rval (var_str ("epa_q_max")) epa_mass = var_list%get_rval (var_str ("epa_mass")) call evt%set_data_epa (sqrts, epa_q_max, epa_mass) end if call msg_message ("Simulate: ISR/EPA handler mode: " & // char (evt%get_mode_string ())) end select else evt => null () end if end subroutine dispatch_evt_isr_epa_handler @ %def dispatch_evt_isr_epa_handler @ <>= public :: dispatch_evt_decay <>= subroutine dispatch_evt_decay (evt, var_list) class(evt_t), intent(out), pointer :: evt type(var_list_t), intent(in), target :: var_list logical :: allow_decays allow_decays = var_list%get_lval (var_str ("?allow_decays")) if (allow_decays) then allocate (evt_decay_t :: evt) call msg_message ("Simulate: activating decays") select type (evt) type is (evt_decay_t) call evt%set_var_list (var_list) end select else evt => null () end if end subroutine dispatch_evt_decay @ %def dispatch_evt_decay @ <>= public :: dispatch_evt_shower <>= subroutine dispatch_evt_shower (evt, var_list, model, fallback_model, & os_data, beam_structure, process) class(evt_t), intent(out), pointer :: evt type(var_list_t), intent(in) :: var_list type(model_t), pointer, intent(in) :: model, fallback_model type(os_data_t), intent(in) :: os_data type(beam_structure_t), intent(in) :: beam_structure type(process_t), intent(in), optional :: process type(string_t) :: lhapdf_file, lhapdf_dir, process_name integer :: lhapdf_member type(shower_settings_t) :: settings type(taudec_settings_t) :: taudec_settings call msg_message ("Simulate: activating parton shower") allocate (evt_shower_t :: evt) call settings%init (var_list) if (associated (model)) then call taudec_settings%init (var_list, model) else call taudec_settings%init (var_list, fallback_model) end if if (present (process)) then process_name = process%get_id () else process_name = 'dispatch_testing' end if select type (evt) type is (evt_shower_t) call evt%init (fallback_model, os_data) lhapdf_member = & var_list%get_ival (var_str ("lhapdf_member")) if (LHAPDF6_AVAILABLE) then lhapdf_dir = & var_list%get_sval (var_str ("$lhapdf_dir")) lhapdf_file = & var_list%get_sval (var_str ("$lhapdf_file")) call lhapdf_initialize & (1, lhapdf_dir, lhapdf_file, lhapdf_member, evt%pdf_data%pdf) end if if (present (process)) call evt%pdf_data%setup ("Shower", & beam_structure, lhapdf_member, process%get_pdf_set ()) select case (settings%method) case (PS_WHIZARD) allocate (shower_t :: evt%shower) case (PS_PYTHIA6) allocate (shower_pythia6_t :: evt%shower) case (PS_PYTHIA8) allocate (shower_pythia8_t :: evt%shower) case default call msg_fatal ('Shower: Method ' // & char (var_list%get_sval (var_str ("$shower_method"))) // & 'not implemented!') end select call evt%shower%init (settings, taudec_settings, evt%pdf_data, os_data) end select call dispatch_matching (evt, settings, var_list, process_name) end subroutine dispatch_evt_shower @ %def dispatch_evt_shower @ <>= public :: dispatch_evt_shower_hook <>= subroutine dispatch_evt_shower_hook (hook, var_list, process_instance) class(process_instance_hook_t), pointer, intent(out) :: hook type(var_list_t), intent(in) :: var_list class(process_instance_t), intent(in), target :: process_instance if (var_list%get_lval (var_str ('?powheg_matching'))) then call msg_message ("Integration hook: add POWHEG hook") allocate (powheg_matching_hook_t :: hook) call hook%init (var_list, process_instance) else hook => null () end if end subroutine dispatch_evt_shower_hook @ %def dispatch_evt_shower_hook @ <>= public :: dispatch_matching <>= subroutine dispatch_matching (evt, settings, var_list, process_name) class(evt_t), intent(inout) :: evt type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_name type(shower_settings_t), intent(in) :: settings select type (evt) type is (evt_shower_t) if (settings%mlm_matching .and. settings%ckkw_matching) then call msg_fatal ("Both MLM and CKKW matching activated," // & LF // " aborting simulation") end if if (settings%powheg_matching) then call msg_message ("Simulate: applying POWHEG matching") allocate (powheg_matching_t :: evt%matching) end if if (settings%mlm_matching) then call msg_message ("Simulate: applying MLM matching") allocate (mlm_matching_t :: evt%matching) end if if (settings%ckkw_matching) then call msg_warning ("Simulate: CKKW(-L) matching not yet supported") allocate (ckkw_matching_t :: evt%matching) end if if (allocated (evt%matching)) & call evt%matching%init (var_list, process_name) end select end subroutine dispatch_matching @ %def dispatch_matching @ <>= public :: dispatch_evt_hadrons <>= subroutine dispatch_evt_hadrons (evt, var_list, fallback_model) class(evt_t), intent(out), pointer :: evt type(var_list_t), intent(in) :: var_list type(model_t), pointer, intent(in) :: fallback_model type(shower_settings_t) :: shower_settings type(hadron_settings_t) :: hadron_settings allocate (evt_hadrons_t :: evt) call msg_message ("Simulate: activating hadronization") call shower_settings%init (var_list) call hadron_settings%init (var_list) select type (evt) type is (evt_hadrons_t) call evt%init (fallback_model) select case (hadron_settings%method) case (HADRONS_WHIZARD) allocate (hadrons_hadrons_t :: evt%hadrons) case (HADRONS_PYTHIA6) allocate (hadrons_pythia6_t :: evt%hadrons) case (HADRONS_PYTHIA8) allocate (hadrons_pythia8_t :: evt%hadrons) case default call msg_fatal ('Hadronization: Method ' // & char (var_list%get_sval (var_str ("hadronization_method"))) // & 'not implemented!') end select call evt%hadrons%init & (shower_settings, hadron_settings, fallback_model) end select end subroutine dispatch_evt_hadrons @ %def dispatch_evt_hadrons @ We cannot put this in the [[events]] subdir due to [[eio_raw_t]], which is defined here. <>= public :: dispatch_eio <>= subroutine dispatch_eio (eio, method, var_list, fallback_model, & event_callback) class(eio_t), allocatable, intent(inout) :: eio type(string_t), intent(in) :: method type(var_list_t), intent(in) :: var_list type(model_t), target, intent(in) :: fallback_model class(event_callback_t), allocatable, intent(in) :: event_callback logical :: check, keep_beams, keep_remnants, recover_beams logical :: use_alphas_from_file, use_scale_from_file logical :: fixed_order_nlo_events logical :: write_sqme_prc, write_sqme_ref, write_sqme_alt logical :: output_cross_section, ensure_order type(string_t) :: lhef_version, lhef_extension, raw_version type(string_t) :: extension_default, debug_extension, dump_extension, & extension_hepmc, & extension_lha, extension_hepevt, extension_ascii_short, & extension_ascii_long, extension_athena, extension_mokka, & extension_stdhep, extension_stdhep_up, extension_stdhep_ev4, & extension_raw, extension_hepevt_verb, extension_lha_verb, & extension_lcio integer :: checkpoint integer :: lcio_run_id, hepmc3_mode logical :: show_process, show_transforms, show_decay, verbose, pacified logical :: dump_weights, dump_compressed, dump_summary, dump_screen logical :: proc_as_run_id, hepmc3_write_flows keep_beams = & var_list%get_lval (var_str ("?keep_beams")) keep_remnants = & var_list%get_lval (var_str ("?keep_remnants")) ensure_order = & var_list%get_lval (var_str ("?hepevt_ensure_order")) recover_beams = & var_list%get_lval (var_str ("?recover_beams")) use_alphas_from_file = & var_list%get_lval (var_str ("?use_alphas_from_file")) use_scale_from_file = & var_list%get_lval (var_str ("?use_scale_from_file")) fixed_order_nlo_events = & var_list%get_lval (var_str ("?fixed_order_nlo_events")) select case (char (method)) case ("raw") allocate (eio_raw_t :: eio) select type (eio) type is (eio_raw_t) check = & var_list%get_lval (var_str ("?check_event_file")) raw_version = & var_list%get_sval (var_str ("$event_file_version")) extension_raw = & var_list%get_sval (var_str ("$extension_raw")) call eio%set_parameters (check, use_alphas_from_file, & use_scale_from_file, fixed_order_nlo_events, & raw_version, extension_raw) end select case ("checkpoint") allocate (eio_checkpoints_t :: eio) select type (eio) type is (eio_checkpoints_t) checkpoint = & var_list%get_ival (var_str ("checkpoint")) pacified = & var_list%get_lval (var_str ("?pacify")) call eio%set_parameters (checkpoint, blank = pacified) end select case ("callback") allocate (eio_callback_t :: eio) select type (eio) type is (eio_callback_t) checkpoint = & var_list%get_ival (var_str ("event_callback_interval")) if (allocated (event_callback)) then call eio%set_parameters (event_callback, checkpoint) else call eio%set_parameters (event_callback_nop_t (), 0) end if end select case ("lhef") allocate (eio_lhef_t :: eio) select type (eio) type is (eio_lhef_t) lhef_version = & var_list%get_sval (var_str ("$lhef_version")) lhef_extension = & var_list%get_sval (var_str ("$lhef_extension")) write_sqme_prc = & var_list%get_lval (var_str ("?lhef_write_sqme_prc")) write_sqme_ref = & var_list%get_lval (var_str ("?lhef_write_sqme_ref")) write_sqme_alt = & var_list%get_lval (var_str ("?lhef_write_sqme_alt")) call eio%set_parameters ( & keep_beams, keep_remnants, recover_beams, & use_alphas_from_file, use_scale_from_file, & char (lhef_version), lhef_extension, & write_sqme_ref, write_sqme_prc, write_sqme_alt) end select case ("hepmc") allocate (eio_hepmc_t :: eio) select type (eio) type is (eio_hepmc_t) output_cross_section = & var_list%get_lval (var_str ("?hepmc_output_cross_section")) extension_hepmc = & var_list%get_sval (var_str ("$extension_hepmc")) hepmc3_write_flows = & var_list%get_lval (var_str ("?hepmc3_write_flows")) select case (char (var_list%get_sval (var_str ("$hepmc3_mode")))) case ("HepMC2") hepmc3_mode = HEPMC3_MODE_HEPMC2 case ("HepMC3") hepmc3_mode = HEPMC3_MODE_HEPMC3 case ("Root") hepmc3_mode = HEPMC3_MODE_ROOT if (extension_hepmc /= "root") then call msg_message ("Events: HepMC3 Root mode, using " // & "event sample extension 'root'") extension_hepmc = "root" end if case ("RootTree") hepmc3_mode = HEPMC3_MODE_ROOTTREE if (extension_hepmc /= "root") then call msg_message ("Events: HepMC3 RootTree mode, using " // & "event sample extension 'root'") extension_hepmc = "root" end if case ("HepEVT") hepmc3_mode = HEPMC3_MODE_HEPEVT case default call msg_fatal ("Only supported HepMC3 modes are: 'HepMC2', " // & "'HepMC3', 'HepEVT', 'Root', and 'RootTree'.") end select call eio%set_parameters (recover_beams, & use_alphas_from_file, use_scale_from_file, & extension = extension_hepmc, & output_cross_section = output_cross_section, & hepmc3_mode = hepmc3_mode, & hepmc3_write_flows = hepmc3_write_flows) end select case ("lcio") allocate (eio_lcio_t :: eio) select type (eio) type is (eio_lcio_t) extension_lcio = & var_list%get_sval (var_str ("$extension_lcio")) proc_as_run_id = & var_list%get_lval (var_str ("?proc_as_run_id")) lcio_run_id = & var_list%get_ival (var_str ("lcio_run_id")) call eio%set_parameters (recover_beams, & use_alphas_from_file, use_scale_from_file, & extension_lcio, proc_as_run_id = proc_as_run_id, & lcio_run_id = lcio_run_id) end select case ("stdhep") allocate (eio_stdhep_hepevt_t :: eio) select type (eio) type is (eio_stdhep_hepevt_t) extension_stdhep = & var_list%get_sval (var_str ("$extension_stdhep")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, recover_beams, & use_alphas_from_file, use_scale_from_file, extension_stdhep) end select case ("stdhep_up") allocate (eio_stdhep_hepeup_t :: eio) select type (eio) type is (eio_stdhep_hepeup_t) extension_stdhep_up = & var_list%get_sval (var_str ("$extension_stdhep_up")) call eio%set_parameters (keep_beams, keep_remnants, ensure_order, & recover_beams, use_alphas_from_file, & use_scale_from_file, extension_stdhep_up) end select case ("stdhep_ev4") allocate (eio_stdhep_hepev4_t :: eio) select type (eio) type is (eio_stdhep_hepev4_t) extension_stdhep_ev4 = & var_list%get_sval (var_str ("$extension_stdhep_ev4")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, recover_beams, & use_alphas_from_file, use_scale_from_file, extension_stdhep_ev4) end select case ("ascii") allocate (eio_ascii_ascii_t :: eio) select type (eio) type is (eio_ascii_ascii_t) extension_default = & var_list%get_sval (var_str ("$extension_default")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, extension_default) end select case ("athena") allocate (eio_ascii_athena_t :: eio) select type (eio) type is (eio_ascii_athena_t) extension_athena = & var_list%get_sval (var_str ("$extension_athena")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, extension_athena) end select case ("debug") allocate (eio_ascii_debug_t :: eio) select type (eio) type is (eio_ascii_debug_t) debug_extension = & var_list%get_sval (var_str ("$debug_extension")) show_process = & var_list%get_lval (var_str ("?debug_process")) show_transforms = & var_list%get_lval (var_str ("?debug_transforms")) show_decay = & var_list%get_lval (var_str ("?debug_decay")) verbose = & var_list%get_lval (var_str ("?debug_verbose")) call eio%set_parameters ( & extension = debug_extension, & show_process = show_process, & show_transforms = show_transforms, & show_decay = show_decay, & verbose = verbose) end select case ("dump") allocate (eio_dump_t :: eio) select type (eio) type is (eio_dump_t) dump_extension = & var_list%get_sval (var_str ("$dump_extension")) pacified = & var_list%get_lval (var_str ("?pacify")) dump_weights = & var_list%get_lval (var_str ("?dump_weights")) dump_compressed = & var_list%get_lval (var_str ("?dump_compressed")) dump_summary = & var_list%get_lval (var_str ("?dump_summary")) dump_screen = & var_list%get_lval (var_str ("?dump_screen")) call eio%set_parameters ( & extension = dump_extension, & pacify = pacified, & weights = dump_weights, & compressed = dump_compressed, & summary = dump_summary, & screen = dump_screen) end select case ("hepevt") allocate (eio_ascii_hepevt_t :: eio) select type (eio) type is (eio_ascii_hepevt_t) extension_hepevt = & var_list%get_sval (var_str ("$extension_hepevt")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, extension_hepevt) end select case ("hepevt_verb") allocate (eio_ascii_hepevt_verb_t :: eio) select type (eio) type is (eio_ascii_hepevt_verb_t) extension_hepevt_verb = & var_list%get_sval (var_str ("$extension_hepevt_verb")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, extension_hepevt_verb) end select case ("lha") allocate (eio_ascii_lha_t :: eio) select type (eio) type is (eio_ascii_lha_t) extension_lha = & var_list%get_sval (var_str ("$extension_lha")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, extension_lha) end select case ("lha_verb") allocate (eio_ascii_lha_verb_t :: eio) select type (eio) type is (eio_ascii_lha_verb_t) extension_lha_verb = var_list%get_sval ( & var_str ("$extension_lha_verb")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, extension_lha_verb) end select case ("long") allocate (eio_ascii_long_t :: eio) select type (eio) type is (eio_ascii_long_t) extension_ascii_long = & var_list%get_sval (var_str ("$extension_ascii_long")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, extension_ascii_long) end select case ("mokka") allocate (eio_ascii_mokka_t :: eio) select type (eio) type is (eio_ascii_mokka_t) extension_mokka = & var_list%get_sval (var_str ("$extension_mokka")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, extension_mokka) end select case ("short") allocate (eio_ascii_short_t :: eio) select type (eio) type is (eio_ascii_short_t) extension_ascii_short = & var_list%get_sval (var_str ("$extension_ascii_short")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, extension_ascii_short) end select case ("weight_stream") allocate (eio_weights_t :: eio) select type (eio) type is (eio_weights_t) pacified = & var_list%get_lval (var_str ("?pacify")) call eio%set_parameters (pacify = pacified) end select case default call msg_fatal ("Event I/O method '" // char (method) & // "' not implemented") end select call eio%set_fallback_model (fallback_model) end subroutine dispatch_eio @ %def dispatch_eio @ @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[dispatch_transforms_ut.f90]]>>= <> module dispatch_transforms_ut use unit_tests use dispatch_transforms_uti <> <> contains <> end module dispatch_transforms_ut @ %def dispatch_transforms_ut @ <<[[dispatch_transforms_uti.f90]]>>= <> module dispatch_transforms_uti <> <> use format_utils, only: write_separator use variables use event_base, only: event_callback_t use models, only: model_t, model_list_t use models, only: syntax_model_file_init, syntax_model_file_final use resonances, only: resonance_history_set_t use beam_structures, only: beam_structure_t use eio_base, only: eio_t use os_interface, only: os_data_t use event_transforms, only: evt_t use dispatch_transforms <> <> contains <> end module dispatch_transforms_uti @ %def dispatch_transforms_uti @ API: driver for the unit tests below. <>= public ::dispatch_transforms_test <>= subroutine dispatch_transforms_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine dispatch_transforms_test @ %def dispatch_transforms_test @ \subsubsection{Event I/O} <>= call test (dispatch_transforms_1, "dispatch_transforms_1", & "event I/O", & u, results) <>= public :: dispatch_transforms_1 <>= subroutine dispatch_transforms_1 (u) integer, intent(in) :: u type(var_list_t) :: var_list type(model_list_t) :: model_list type(model_t), pointer :: model type(os_data_t) :: os_data class(event_callback_t), allocatable :: event_callback class(eio_t), allocatable :: eio write (u, "(A)") "* Test output: dispatch_transforms_1" write (u, "(A)") "* Purpose: allocate an event I/O (eio) stream" write (u, "(A)") call var_list%init_defaults (0) call os_data%init () call syntax_model_file_init () call model_list%read_model (var_str ("SM_hadrons"), & var_str ("SM_hadrons.mdl"), os_data, model) write (u, "(A)") "* Allocate as raw" write (u, "(A)") call dispatch_eio (eio, var_str ("raw"), var_list, & model, event_callback) call eio%write (u) call eio%final () deallocate (eio) write (u, "(A)") write (u, "(A)") "* Allocate as checkpoints:" write (u, "(A)") call dispatch_eio (eio, var_str ("checkpoint"), var_list, & model, event_callback) call eio%write (u) call eio%final () deallocate (eio) write (u, "(A)") write (u, "(A)") "* Allocate as LHEF:" write (u, "(A)") call var_list%set_string (var_str ("$lhef_extension"), & var_str ("lhe_custom"), is_known = .true.) call dispatch_eio (eio, var_str ("lhef"), var_list, & model, event_callback) call eio%write (u) call eio%final () deallocate (eio) write (u, "(A)") write (u, "(A)") "* Allocate as HepMC:" write (u, "(A)") call dispatch_eio (eio, var_str ("hepmc"), var_list, & model, event_callback) call eio%write (u) call eio%final () deallocate (eio) write (u, "(A)") write (u, "(A)") "* Allocate as weight_stream" write (u, "(A)") call dispatch_eio (eio, var_str ("weight_stream"), var_list, & model, event_callback) call eio%write (u) call eio%final () deallocate (eio) write (u, "(A)") write (u, "(A)") "* Allocate as debug format" write (u, "(A)") call var_list%set_log (var_str ("?debug_verbose"), & .false., is_known = .true.) call dispatch_eio (eio, var_str ("debug"), var_list, & model, event_callback) call eio%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio%final () call var_list%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: dispatch_transforms_1" end subroutine dispatch_transforms_1 @ %def dispatch_transforms_1 @ \subsubsection{Event transforms} This test dispatches [[evt]] (event transform) objects. <>= call test (dispatch_transforms_2, "dispatch_transforms_2", & "event transforms", & u, results) <>= public :: dispatch_transforms_2 <>= subroutine dispatch_transforms_2 (u) integer, intent(in) :: u type(var_list_t), target :: var_list type(model_list_t) :: model_list type(model_t), pointer :: model type(os_data_t) :: os_data type(resonance_history_set_t), dimension(1) :: res_history_set type(beam_structure_t) :: beam_structure class(evt_t), pointer :: evt write (u, "(A)") "* Test output: dispatch_transforms_2" write (u, "(A)") "* Purpose: configure event transform" write (u, "(A)") call syntax_model_file_init () call var_list%init_defaults (0) call os_data%init () call model_list%read_model (var_str ("SM_hadrons"), & var_str ("SM_hadrons.mdl"), os_data, model) write (u, "(A)") "* Resonance insertion" write (u, "(A)") call var_list%set_log (var_str ("?resonance_history"), .true., & is_known = .true.) call dispatch_evt_resonance (evt, var_list, & res_history_set, & var_str ("foo_R")) call evt%write (u, verbose = .true., more_verbose = .true.) call evt%final () deallocate (evt) write (u, "(A)") write (u, "(A)") "* ISR handler" write (u, "(A)") call var_list%set_log (var_str ("?isr_handler"), .true., & is_known = .true.) call var_list%set_log (var_str ("?epa_handler"), .false., & is_known = .true.) call var_list%set_string (var_str ("$isr_handler_mode"), & var_str ("recoil"), & is_known = .true.) call var_list%set_real (var_str ("sqrts"), 100._default, & is_known = .true.) call var_list%set_real (var_str ("isr_mass"), 511.e-6_default, & is_known = .true.) call dispatch_evt_isr_epa_handler (evt, var_list) call evt%write (u, verbose = .true., more_verbose = .true.) call evt%final () deallocate (evt) write (u, "(A)") write (u, "(A)") "* EPA handler" write (u, "(A)") call var_list%set_log (var_str ("?isr_handler"), .false., & is_known = .true.) call var_list%set_log (var_str ("?epa_handler"), .true., & is_known = .true.) call var_list%set_string (var_str ("$epa_handler_mode"), & var_str ("recoil"), & is_known = .true.) call var_list%set_real (var_str ("sqrts"), 100._default, & is_known = .true.) call var_list%set_real (var_str ("epa_mass"), 511.e-6_default, & is_known = .true.) call dispatch_evt_isr_epa_handler (evt, var_list) call evt%write (u, verbose = .true., more_verbose = .true.) call evt%final () deallocate (evt) write (u, "(A)") write (u, "(A)") "* Partonic decays" write (u, "(A)") call dispatch_evt_decay (evt, var_list) call evt%write (u, verbose = .true., more_verbose = .true.) call evt%final () deallocate (evt) write (u, "(A)") write (u, "(A)") "* Shower" write (u, "(A)") call var_list%set_log (var_str ("?allow_shower"), .true., & is_known = .true.) call var_list%set_string (var_str ("$shower_method"), & var_str ("WHIZARD"), is_known = .true.) call dispatch_evt_shower (evt, var_list, model, & model, os_data, beam_structure) call evt%write (u) call write_separator (u, 2) call evt%final () deallocate (evt) call var_list%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: dispatch_transforms_2" end subroutine dispatch_transforms_2 @ %def dispatch_transforms_2 Index: trunk/src/model_features/model_features.nw =================================================================== --- trunk/src/model_features/model_features.nw (revision 8782) +++ trunk/src/model_features/model_features.nw (revision 8783) @@ -1,17516 +1,17503 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: model features %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Model Handling and Features} \includemodulegraph{model_features} These modules deal with process definitions and physics models. These modules use the [[model_data]] methods to automatically generate process definitions. \begin{description} \item[auto\_components] Generic process-definition generator. We can specify a basic process or initial particle(s) and some rules to extend this process, given a model definition with particle names and vertex structures. \item[radiation\_generator] Applies the generic generator to the specific problem of generating NLO corrections in a restricted setup. \end{description} Model construction: \begin{description} \item[eval\_trees] Implementation of the generic [[expr_t]] type for the concrete evaluation of expressions that access user variables. This module is actually part of the Sindarin language implementation, and should be moved elsewhere. Currently, the [[models]] module relies on it. \item[models] Extends the [[model_data_t]] structure by user-variable objects for easy access, and provides the means to read a model definition from file. \item[slha\_interface] Read/write a SUSY model in the standardized SLHA format. The format defines fields and parameters, but no vertices. \end{description} \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Automatic generation of process components} This module provides the functionality for automatically generating radiation corrections or decays, provided as lists of PDG codes. <<[[auto_components.f90]]>>= <> module auto_components <> <> use io_units use diagnostics use model_data use pdg_arrays use physics_defs, only: PHOTON, GLUON, Z_BOSON, W_BOSON use numeric_utils, only: extend_integer_array <> <> <> <> <> contains <> end module auto_components @ %def auto_components @ \subsection{Constraints: Abstract types} An abstract type that denotes a constraint on the automatically generated states. The concrete objects are applied as visitor objects at certain hooks during the splitting algorithm. <>= type, abstract :: split_constraint_t contains <> end type split_constraint_t @ %def split_constraint_t @ By default, all checks return true. <>= procedure :: check_before_split => split_constraint_check_before_split procedure :: check_before_insert => split_constraint_check_before_insert procedure :: check_before_record => split_constraint_check_before_record <>= subroutine split_constraint_check_before_split (c, table, pl, k, passed) class(split_constraint_t), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: k logical, intent(out) :: passed passed = .true. end subroutine split_constraint_check_before_split subroutine split_constraint_check_before_insert (c, table, pa, pl, passed) class(split_constraint_t), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_array_t), intent(in) :: pa type(pdg_list_t), intent(inout) :: pl logical, intent(out) :: passed passed = .true. end subroutine split_constraint_check_before_insert subroutine split_constraint_check_before_record (c, table, pl, n_loop, passed) class(split_constraint_t), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop logical, intent(out) :: passed passed = .true. end subroutine split_constraint_check_before_record @ %def check_before_split @ %def check_before_insert @ %def check_before_record @ A transparent wrapper, so we can collect constraints of different type. <>= type :: split_constraint_wrap_t class(split_constraint_t), allocatable :: c end type split_constraint_wrap_t @ %def split_constraint_wrap_t @ A collection of constraints. <>= public :: split_constraints_t <>= type :: split_constraints_t class(split_constraint_wrap_t), dimension(:), allocatable :: cc contains <> end type split_constraints_t @ %def split_constraints_t @ Initialize the constraints set with a specific number of elements. <>= procedure :: init => split_constraints_init <>= subroutine split_constraints_init (constraints, n) class(split_constraints_t), intent(out) :: constraints integer, intent(in) :: n allocate (constraints%cc (n)) end subroutine split_constraints_init @ %def split_constraints_init @ Set a constraint. <>= procedure :: set => split_constraints_set <>= subroutine split_constraints_set (constraints, i, c) class(split_constraints_t), intent(inout) :: constraints integer, intent(in) :: i class(split_constraint_t), intent(in) :: c allocate (constraints%cc(i)%c, source = c) end subroutine split_constraints_set @ %def split_constraints_set @ Apply checks. [[check_before_split]] is applied to the particle list that we want to split. [[check_before_insert]] is applied to the particle list [[pl]] that is to replace the particle [[pa]] that is split. This check may transform the particle list. [[check_before_record]] is applied to the complete new particle list that results from splitting before it is recorded. <>= procedure :: check_before_split => split_constraints_check_before_split procedure :: check_before_insert => split_constraints_check_before_insert procedure :: check_before_record => split_constraints_check_before_record <>= subroutine split_constraints_check_before_split & (constraints, table, pl, k, passed) class(split_constraints_t), intent(in) :: constraints class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: k logical, intent(out) :: passed integer :: i passed = .true. do i = 1, size (constraints%cc) call constraints%cc(i)%c%check_before_split (table, pl, k, passed) if (.not. passed) return end do end subroutine split_constraints_check_before_split subroutine split_constraints_check_before_insert & (constraints, table, pa, pl, passed) class(split_constraints_t), intent(in) :: constraints class(ps_table_t), intent(in) :: table type(pdg_array_t), intent(in) :: pa type(pdg_list_t), intent(inout) :: pl logical, intent(out) :: passed integer :: i passed = .true. do i = 1, size (constraints%cc) call constraints%cc(i)%c%check_before_insert (table, pa, pl, passed) if (.not. passed) return end do end subroutine split_constraints_check_before_insert subroutine split_constraints_check_before_record & (constraints, table, pl, n_loop, passed) class(split_constraints_t), intent(in) :: constraints class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop logical, intent(out) :: passed integer :: i passed = .true. do i = 1, size (constraints%cc) call constraints%cc(i)%c%check_before_record (table, pl, n_loop, passed) if (.not. passed) return end do end subroutine split_constraints_check_before_record @ %def split_constraints_check_before_split @ %def split_constraints_check_before_insert @ %def split_constraints_check_before_record @ \subsection{Specific constraints} \subsubsection{Number of particles} Specific constraint: The number of particles plus the number of loops, if any, must remain less than the given limit. Note that the number of loops is defined only when we are recording the entry. <>= type, extends (split_constraint_t) :: constraint_n_tot private integer :: n_max = 0 contains procedure :: check_before_split => constraint_n_tot_check_before_split procedure :: check_before_record => constraint_n_tot_check_before_record end type constraint_n_tot @ %def constraint_n_tot <>= public :: constrain_n_tot <>= function constrain_n_tot (n_max) result (c) integer, intent(in) :: n_max type(constraint_n_tot) :: c c%n_max = n_max end function constrain_n_tot subroutine constraint_n_tot_check_before_split (c, table, pl, k, passed) class(constraint_n_tot), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: k logical, intent(out) :: passed passed = pl%get_size () < c%n_max end subroutine constraint_n_tot_check_before_split subroutine constraint_n_tot_check_before_record (c, table, pl, n_loop, passed) class(constraint_n_tot), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop logical, intent(out) :: passed passed = pl%get_size () + n_loop <= c%n_max end subroutine constraint_n_tot_check_before_record @ %def constrain_n_tot @ %def constraint_n_tot_check_before_insert @ \subsubsection{Number of loops} Specific constraint: The number of loops is limited, independent of the total number of particles. <>= type, extends (split_constraint_t) :: constraint_n_loop private integer :: n_loop_max = 0 contains procedure :: check_before_record => constraint_n_loop_check_before_record end type constraint_n_loop @ %def constraint_n_loop <>= public :: constrain_n_loop <>= function constrain_n_loop (n_loop_max) result (c) integer, intent(in) :: n_loop_max type(constraint_n_loop) :: c c%n_loop_max = n_loop_max end function constrain_n_loop subroutine constraint_n_loop_check_before_record & (c, table, pl, n_loop, passed) class(constraint_n_loop), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop logical, intent(out) :: passed passed = n_loop <= c%n_loop_max end subroutine constraint_n_loop_check_before_record @ %def constrain_n_loop @ %def constraint_n_loop_check_before_insert @ \subsubsection{Particles allowed in splitting} Specific constraint: The entries in the particle list ready for insertion are matched to a given list of particle patterns. If a match occurs, the entry is replaced by the corresponding pattern. If there is no match, the check fails. If a massless gauge boson splitting is detected, the splitting partners are checked against a list of excluded particles. If a match occurs, the check fails. <>= type, extends (split_constraint_t) :: constraint_splittings private type(pdg_list_t) :: pl_match, pl_excluded_gauge_splittings contains procedure :: check_before_insert => constraint_splittings_check_before_insert end type constraint_splittings @ %def constraint_splittings <>= public :: constrain_splittings <>= function constrain_splittings (pl_match, pl_excluded_gauge_splittings) result (c) type(pdg_list_t), intent(in) :: pl_match type(pdg_list_t), intent(in) :: pl_excluded_gauge_splittings type(constraint_splittings) :: c c%pl_match = pl_match c%pl_excluded_gauge_splittings = pl_excluded_gauge_splittings end function constrain_splittings subroutine constraint_splittings_check_before_insert (c, table, pa, pl, passed) class(constraint_splittings), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_array_t), intent(in) :: pa type(pdg_list_t), intent(inout) :: pl logical, intent(out) :: passed logical :: has_massless_vector integer :: i has_massless_vector = .false. do i = 1, pa%get_length () if (is_massless_vector(pa%get(i))) then has_massless_vector = .true. exit end if end do passed = .false. if (has_massless_vector .and. count (is_fermion(pl%a%get ())) == 2) then do i = 1, c%pl_excluded_gauge_splittings%get_size () if (pl .match. c%pl_excluded_gauge_splittings%a(i)) return end do call pl%match_replace (c%pl_match, passed) passed = .true. else call pl%match_replace (c%pl_match, passed) end if end subroutine constraint_splittings_check_before_insert @ %def constrain_splittings @ %def constraint_splittings_check_before_insert @ Specific constraint: The entries in the particle list ready for insertion are matched to a given list of particle patterns. If a match occurs, the entry is replaced by the corresponding pattern. If there is no match, the check fails. <>= type, extends (split_constraint_t) :: constraint_insert private type(pdg_list_t) :: pl_match contains procedure :: check_before_insert => constraint_insert_check_before_insert end type constraint_insert @ %def constraint_insert <>= public :: constrain_insert <>= function constrain_insert (pl_match) result (c) type(pdg_list_t), intent(in) :: pl_match type(constraint_insert) :: c c%pl_match = pl_match end function constrain_insert subroutine constraint_insert_check_before_insert (c, table, pa, pl, passed) class(constraint_insert), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_array_t), intent(in) :: pa type(pdg_list_t), intent(inout) :: pl logical, intent(out) :: passed call pl%match_replace (c%pl_match, passed) end subroutine constraint_insert_check_before_insert @ %def constrain_insert @ %def constraint_insert_check_before_insert @ \subsubsection{Particles required in final state} Specific constraint: The entries in the recorded state must be a superset of the entries in the given list (for instance, the lowest-order state). <>= type, extends (split_constraint_t) :: constraint_require private type(pdg_list_t) :: pl contains procedure :: check_before_record => constraint_require_check_before_record end type constraint_require @ %def constraint_require @ We check the current state by matching all particle entries against the stored particle list, and crossing out the particles in the latter list when a match is found. The constraint passed if all entries have been crossed out. For an [[if_table]] in particular, we check the final state only. <>= public :: constrain_require <>= function constrain_require (pl) result (c) type(pdg_list_t), intent(in) :: pl type(constraint_require) :: c c%pl = pl end function constrain_require subroutine constraint_require_check_before_record & (c, table, pl, n_loop, passed) class(constraint_require), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop logical, intent(out) :: passed logical, dimension(:), allocatable :: mask integer :: i, k, n_in select type (table) type is (if_table_t) if (table%proc_type > 0) then select case (table%proc_type) case (PROC_DECAY) n_in = 1 case (PROC_SCATTER) n_in = 2 end select else call msg_fatal ("Neither a decay nor a scattering process") end if class default n_in = 0 end select allocate (mask (c%pl%get_size ()), source = .true.) do i = n_in + 1, pl%get_size () k = c%pl%find_match (pl%get (i), mask) if (k /= 0) mask(k) = .false. end do passed = .not. any (mask) end subroutine constraint_require_check_before_record @ %def constrain_require @ %def constraint_require_check_before_record @ \subsubsection{Radiation} Specific constraint: We have radiation pattern if the original particle matches an entry in the list of particles that should replace it. The constraint prohibits this situation. <>= public :: constrain_radiation <>= type, extends (split_constraint_t) :: constraint_radiation private contains procedure :: check_before_insert => & constraint_radiation_check_before_insert end type constraint_radiation @ %def constraint_radiation <>= function constrain_radiation () result (c) type(constraint_radiation) :: c end function constrain_radiation subroutine constraint_radiation_check_before_insert (c, table, pa, pl, passed) class(constraint_radiation), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_array_t), intent(in) :: pa type(pdg_list_t), intent(inout) :: pl logical, intent(out) :: passed passed = .not. (pl .match. pa) end subroutine constraint_radiation_check_before_insert @ %def constrain_radiation @ %def constraint_radiation_check_before_insert @ \subsubsection{Mass sum} Specific constraint: The sum of masses within the particle list must be smaller than a given limit. For in/out state combinations, we check initial and final state separately. If we specify [[margin]] in the initialization, the sum must be strictly less than the limit minus the given margin (which may be zero). If not, equality is allowed. <>= public :: constrain_mass_sum <>= type, extends (split_constraint_t) :: constraint_mass_sum private real(default) :: mass_limit = 0 logical :: strictly_less = .false. real(default) :: margin = 0 contains procedure :: check_before_record => constraint_mass_sum_check_before_record end type constraint_mass_sum @ %def contraint_mass_sum <>= function constrain_mass_sum (mass_limit, margin) result (c) real(default), intent(in) :: mass_limit real(default), intent(in), optional :: margin type(constraint_mass_sum) :: c c%mass_limit = mass_limit if (present (margin)) then c%strictly_less = .true. c%margin = margin end if end function constrain_mass_sum subroutine constraint_mass_sum_check_before_record & (c, table, pl, n_loop, passed) class(constraint_mass_sum), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop logical, intent(out) :: passed real(default) :: limit if (c%strictly_less) then limit = c%mass_limit - c%margin select type (table) type is (if_table_t) passed = mass_sum (pl, 1, 2, table%model) < limit & .and. mass_sum (pl, 3, pl%get_size (), table%model) < limit class default passed = mass_sum (pl, 1, pl%get_size (), table%model) < limit end select else limit = c%mass_limit select type (table) type is (if_table_t) passed = mass_sum (pl, 1, 2, table%model) <= limit & .and. mass_sum (pl, 3, pl%get_size (), table%model) <= limit class default passed = mass_sum (pl, 1, pl%get_size (), table%model) <= limit end select end if end subroutine constraint_mass_sum_check_before_record @ %def constrain_mass_sum @ %def constraint_mass_sum_check_before_record @ \subsubsection{Initial state particles} Specific constraint: The two incoming particles must both match the given particle list. This is checked for the generated particle list, just before it is recorded. <>= public :: constrain_in_state <>= type, extends (split_constraint_t) :: constraint_in_state private type(pdg_list_t) :: pl contains procedure :: check_before_record => constraint_in_state_check_before_record end type constraint_in_state @ %def constraint_in_state <>= function constrain_in_state (pl) result (c) type(pdg_list_t), intent(in) :: pl type(constraint_in_state) :: c c%pl = pl end function constrain_in_state subroutine constraint_in_state_check_before_record & (c, table, pl, n_loop, passed) class(constraint_in_state), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop logical, intent(out) :: passed integer :: i select type (table) type is (if_table_t) passed = .false. do i = 1, 2 if (.not. (c%pl .match. pl%get (i))) return end do end select passed = .true. end subroutine constraint_in_state_check_before_record @ %def constrain_in_state @ %def constraint_in_state_check_before_record @ \subsubsection{Photon induced processes} If set, filter out photon induced processes. <>= public :: constrain_photon_induced_processes <>= type, extends (split_constraint_t) :: constraint_photon_induced_processes private integer :: n_in contains procedure :: check_before_record => & constraint_photon_induced_processes_check_before_record end type constraint_photon_induced_processes @ %def constraint_photon_induced_processes <>= function constrain_photon_induced_processes (n_in) result (c) integer, intent(in) :: n_in type(constraint_photon_induced_processes) :: c c%n_in = n_in end function constrain_photon_induced_processes subroutine constraint_photon_induced_processes_check_before_record & (c, table, pl, n_loop, passed) class(constraint_photon_induced_processes), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop logical, intent(out) :: passed integer :: i select type (table) type is (if_table_t) passed = .false. do i = 1, c%n_in if (pl%a(i)%get () == 22) return end do end select passed = .true. end subroutine constraint_photon_induced_processes_check_before_record @ %def constrain_photon_induced_processes @ %def constraint_photon_induced_processes_check_before_record @ \subsubsection{Coupling constraint} Filters vertices which do not match the desired NLO pattern. <>= type, extends (split_constraint_t) :: constraint_coupling_t private logical :: qed = .false. logical :: qcd = .true. logical :: ew = .false. integer :: n_nlo_correction_types contains <> end type constraint_coupling_t @ %def constraint_coupling_t @ <>= public :: constrain_couplings <>= function constrain_couplings (qcd, qed, n_nlo_correction_types) result (c) type(constraint_coupling_t) :: c logical, intent(in) :: qcd, qed integer, intent(in) :: n_nlo_correction_types c%qcd = qcd; c%qed = qed c%n_nlo_correction_types = n_nlo_correction_types end function constrain_couplings @ %def constrain_couplings @ <>= procedure :: check_before_insert => constraint_coupling_check_before_insert <>= subroutine constraint_coupling_check_before_insert (c, table, pa, pl, passed) class(constraint_coupling_t), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_array_t), intent(in) :: pa type(pdg_list_t), intent(inout) :: pl logical, intent(out) :: passed type(pdg_list_t) :: pl_vertex type(pdg_array_t) :: pdg_gluon, pdg_photon, pdg_W_Z, pdg_gauge_bosons integer :: i, j pdg_gluon = GLUON; pdg_photon = PHOTON pdg_W_Z = [W_BOSON,-W_BOSON, Z_BOSON] if (c%qcd) pdg_gauge_bosons = pdg_gauge_bosons // pdg_gluon if (c%qed) pdg_gauge_bosons = pdg_gauge_bosons // pdg_photon if (c%ew) pdg_gauge_bosons = pdg_gauge_bosons // pdg_W_Z do j = 1, pa%get_length () call pl_vertex%init (pl%get_size () + 1) call pl_vertex%set (1, pa%get(j)) do i = 1, pl%get_size () call pl_vertex%set (i + 1, pl%get(i)) end do if (pl_vertex%get_size () > 3) then passed = .false. cycle end if if (is_massless_vector(pa%get(j))) then if (.not. table%model%check_vertex & (pl_vertex%a(1)%get (), pl_vertex%a(2)%get (), pl_vertex%a(3)%get ())) then passed = .false. cycle end if else if (.not. table%model%check_vertex & (- pl_vertex%a(1)%get (), pl_vertex%a(2)%get (), pl_vertex%a(3)%get ())) then passed = .false. cycle end if if (.not. (pl_vertex .match. pdg_gauge_bosons)) then passed = .false. cycle end if passed = .true. exit end do end subroutine constraint_coupling_check_before_insert @ %def constraint_coupling_check_before_insert @ \subsection{Tables of states} Automatically generate a list of possible process components for a given initial set (a single massive particle or a preset list of states). The set of process components are generated by recursive splitting, applying constraints on the fly that control and limit the process. The generated states are accumulated in a table that we can read out after completion. <>= type, extends (pdg_list_t) :: ps_entry_t integer :: n_loop = 0 integer :: n_rad = 0 type(ps_entry_t), pointer :: previous => null () type(ps_entry_t), pointer :: next => null () end type ps_entry_t @ %def ps_entry_t @ <>= integer, parameter :: PROC_UNDEFINED = 0 integer, parameter :: PROC_DECAY = 1 integer, parameter :: PROC_SCATTER = 2 @ %def auto_components parameters @ This is the wrapper type for the decay tree for the list of final states and the final array. First, an abstract base type: <>= public :: ps_table_t <>= type, abstract :: ps_table_t private class(model_data_t), pointer :: model => null () logical :: loops = .false. type(ps_entry_t), pointer :: first => null () type(ps_entry_t), pointer :: last => null () integer :: proc_type contains <> end type ps_table_t @ %def ps_table_t @ The extensions: one for decay, one for generic final states. The decay-state table stores the initial particle. The final-state table is indifferent, and the initial/final state table treats the first two particles in its list as incoming antiparticles. <>= public :: ds_table_t public :: fs_table_t public :: if_table_t <>= type, extends (ps_table_t) :: ds_table_t private integer :: pdg_in = 0 contains <> end type ds_table_t type, extends (ps_table_t) :: fs_table_t contains <> end type fs_table_t type, extends (fs_table_t) :: if_table_t contains <> end type if_table_t @ %def ds_table_t fs_table_t if_table_t @ Finalizer: we must deallocate the embedded list. <>= procedure :: final => ps_table_final <>= subroutine ps_table_final (object) class(ps_table_t), intent(inout) :: object type(ps_entry_t), pointer :: current do while (associated (object%first)) current => object%first object%first => current%next deallocate (current) end do nullify (object%last) end subroutine ps_table_final @ %def ps_table_final @ Write the table. A base writer for the body and specific writers for the headers. <>= procedure :: base_write => ps_table_base_write procedure (ps_table_write), deferred :: write <>= interface subroutine ps_table_write (object, unit) import class(ps_table_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine ps_table_write end interface <>= procedure :: write => ds_table_write <>= procedure :: write => fs_table_write <>= procedure :: write => if_table_write @ The first [[n_in]] particles will be replaced by antiparticles in the output, and we write an arrow if [[n_in]] is present. <>= subroutine ps_table_base_write (object, unit, n_in) class(ps_table_t), intent(in) :: object integer, intent(in), optional :: unit integer, intent(in), optional :: n_in integer, dimension(:), allocatable :: pdg type(ps_entry_t), pointer :: entry type(field_data_t), pointer :: prt integer :: u, i, j, n0 u = given_output_unit (unit) entry => object%first do while (associated (entry)) write (u, "(2x)", advance = "no") if (present (n_in)) then do i = 1, n_in write (u, "(1x)", advance = "no") pdg = entry%get (i) do j = 1, size (pdg) prt => object%model%get_field_ptr (pdg(j)) if (j > 1) write (u, "(':')", advance = "no") write (u, "(A)", advance = "no") & char (prt%get_name (pdg(j) >= 0)) end do end do write (u, "(1x,A)", advance = "no") "=>" n0 = n_in + 1 else n0 = 1 end if do i = n0, entry%get_size () write (u, "(1x)", advance = "no") pdg = entry%get (i) do j = 1, size (pdg) prt => object%model%get_field_ptr (pdg(j)) if (j > 1) write (u, "(':')", advance = "no") write (u, "(A)", advance = "no") & char (prt%get_name (pdg(j) < 0)) end do end do if (object%loops) then write (u, "(2x,'[',I0,',',I0,']')") entry%n_loop, entry%n_rad else write (u, "(A)") end if entry => entry%next end do end subroutine ps_table_base_write subroutine ds_table_write (object, unit) class(ds_table_t), intent(in) :: object integer, intent(in), optional :: unit type(field_data_t), pointer :: prt integer :: u u = given_output_unit (unit) prt => object%model%get_field_ptr (object%pdg_in) write (u, "(1x,A,1x,A)") "Decays for particle:", & char (prt%get_name (object%pdg_in < 0)) call object%base_write (u) end subroutine ds_table_write subroutine fs_table_write (object, unit) class(fs_table_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Table of final states:" call object%base_write (u) end subroutine fs_table_write subroutine if_table_write (object, unit) class(if_table_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Table of in/out states:" select case (object%proc_type) case (PROC_DECAY) call object%base_write (u, n_in = 1) case (PROC_SCATTER) call object%base_write (u, n_in = 2) end select end subroutine if_table_write @ %def ps_table_write ds_table_write fs_table_write @ Obtain a particle string for a given index in the pdg list <>= procedure :: get_particle_string => ps_table_get_particle_string <>= subroutine ps_table_get_particle_string (object, index, prt_in, prt_out) class(ps_table_t), intent(in) :: object integer, intent(in) :: index type(string_t), intent(out), dimension(:), allocatable :: prt_in, prt_out integer :: n_in type(field_data_t), pointer :: prt type(ps_entry_t), pointer :: entry integer, dimension(:), allocatable :: pdg integer :: n0 integer :: i, j entry => object%first i = 1 do while (i < index) if (associated (entry%next)) then entry => entry%next i = i + 1 else call msg_fatal ("ps_table: entry with requested index does not exist!") end if end do if (object%proc_type > 0) then select case (object%proc_type) case (PROC_DECAY) n_in = 1 case (PROC_SCATTER) n_in = 2 end select else call msg_fatal ("Neither decay nor scattering process") end if n0 = n_in + 1 allocate (prt_in (n_in), prt_out (entry%get_size () - n_in)) do i = 1, n_in prt_in(i) = "" pdg = entry%get(i) do j = 1, size (pdg) prt => object%model%get_field_ptr (pdg(j)) prt_in(i) = prt_in(i) // prt%get_name (pdg(j) >= 0) if (j /= size (pdg)) prt_in(i) = prt_in(i) // ":" end do end do do i = n0, entry%get_size () prt_out(i-n_in) = "" pdg = entry%get(i) do j = 1, size (pdg) prt => object%model%get_field_ptr (pdg(j)) prt_out(i-n_in) = prt_out(i-n_in) // prt%get_name (pdg(j) < 0) if (j /= size (pdg)) prt_out(i-n_in) = prt_out(i-n_in) // ":" end do end do end subroutine ps_table_get_particle_string @ %def ps_table_get_particle_string @ Initialize with a predefined set of final states, or in/out state lists. <>= generic :: init => ps_table_init procedure, private :: ps_table_init <>= generic :: init => if_table_init procedure, private :: if_table_init <>= subroutine ps_table_init (table, model, pl, constraints, n_in, do_not_check_regular) class(ps_table_t), intent(out) :: table class(model_data_t), intent(in), target :: model type(pdg_list_t), dimension(:), intent(in) :: pl type(split_constraints_t), intent(in) :: constraints integer, intent(in), optional :: n_in logical, intent(in), optional :: do_not_check_regular logical :: passed integer :: i table%model => model if (present (n_in)) then select case (n_in) case (1) table%proc_type = PROC_DECAY case (2) table%proc_type = PROC_SCATTER case default table%proc_type = PROC_UNDEFINED end select else table%proc_type = PROC_UNDEFINED end if do i = 1, size (pl) call table%record (pl(i), 0, 0, constraints, & do_not_check_regular, passed) if (.not. passed) then call msg_fatal ("ps_table: Registering process components failed") end if end do end subroutine ps_table_init subroutine if_table_init (table, model, pl_in, pl_out, constraints) class(if_table_t), intent(out) :: table class(model_data_t), intent(in), target :: model type(pdg_list_t), dimension(:), intent(in) :: pl_in, pl_out type(split_constraints_t), intent(in) :: constraints integer :: i, j, k, p, n_in, n_out type(pdg_array_t), dimension(:), allocatable :: pa_in type(pdg_list_t), dimension(:), allocatable :: pl allocate (pl (size (pl_in) * size (pl_out))) k = 0 do i = 1, size (pl_in) n_in = pl_in(i)%get_size () allocate (pa_in (n_in)) do p = 1, n_in pa_in(p) = pl_in(i)%get (p) end do do j = 1, size (pl_out) n_out = pl_out(j)%get_size () k = k + 1 call pl(k)%init (n_in + n_out) do p = 1, n_in call pl(k)%set (p, invert_pdg_array (pa_in(p), model)) end do do p = 1, n_out call pl(k)%set (n_in + p, pl_out(j)%get (p)) end do end do deallocate (pa_in) end do n_in = size (pl_in(1)%a) call table%init (model, pl, constraints, n_in, do_not_check_regular = .true.) end subroutine if_table_init @ %def ps_table_init if_table_init @ Enable loops for the table. This affects both splitting and output. <>= procedure :: enable_loops => ps_table_enable_loops <>= subroutine ps_table_enable_loops (table) class(ps_table_t), intent(inout) :: table table%loops = .true. end subroutine ps_table_enable_loops @ %def ps_table_enable_loops @ \subsection{Top-level methods} Create a table for a single-particle decay. Construct all possible final states from a single particle with PDG code [[pdg_in]]. The construction is limited by the given [[constraints]]. <>= procedure :: make => ds_table_make <>= subroutine ds_table_make (table, model, pdg_in, constraints) class(ds_table_t), intent(out) :: table class(model_data_t), intent(in), target :: model integer, intent(in) :: pdg_in type(split_constraints_t), intent(in) :: constraints type(pdg_list_t) :: pl_in type(pdg_list_t), dimension(0) :: pl call table%init (model, pl, constraints) table%pdg_in = pdg_in call pl_in%init (1) call pl_in%set (1, [pdg_in]) call table%split (pl_in, 0, constraints) end subroutine ds_table_make @ %def ds_table_make @ Split all entries in a growing table, starting from a table that may already contain states. Add and record split states on the fly. <>= procedure :: radiate => fs_table_radiate <>= subroutine fs_table_radiate (table, constraints, do_not_check_regular) class(fs_table_t), intent(inout) :: table type(split_constraints_t) :: constraints logical, intent(in), optional :: do_not_check_regular type(ps_entry_t), pointer :: current current => table%first do while (associated (current)) call table%split (current, 0, constraints, record = .true., & do_not_check_regular = do_not_check_regular) current => current%next end do end subroutine fs_table_radiate @ %def fs_table_radiate @ \subsection{Splitting algorithm} Recursive splitting. First of all, we record the current [[pdg_list]] in the table, subject to [[constraints]], if requested. We also record copies of the list marked as loop corrections. When we record a particle list, we sort it first. If there is room for splitting, We take a PDG array list and the index of an element, and split this element in all possible ways. The split entry is inserted into the list, which we split further. The recursion terminates whenever the split array would have a length greater than $n_\text{max}$. <>= procedure :: split => ps_table_split <>= recursive subroutine ps_table_split (table, pl, n_rad, constraints, & record, do_not_check_regular) class(ps_table_t), intent(inout) :: table class(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_rad type(split_constraints_t), intent(in) :: constraints logical, intent(in), optional :: record, do_not_check_regular integer :: n_loop, i logical :: passed, save_pdg_index type(vertex_iterator_t) :: vit integer, dimension(:), allocatable :: pdg1 integer, dimension(:), allocatable :: pdg2 if (present (record)) then if (record) then n_loop = 0 INCR_LOOPS: do call table%record_sorted (pl, n_loop, n_rad, constraints, & do_not_check_regular, passed) if (.not. passed) exit INCR_LOOPS if (.not. table%loops) exit INCR_LOOPS n_loop = n_loop + 1 end do INCR_LOOPS end if end if select type (table) type is (if_table_t) save_pdg_index = .true. class default save_pdg_index = .false. end select do i = 1, pl%get_size () call constraints%check_before_split (table, pl, i, passed) if (passed) then pdg1 = pl%get (i) call vit%init (table%model, pdg1, save_pdg_index) SCAN_VERTICES: do call vit%get_next_match (pdg2) if (allocated (pdg2)) then call table%insert (pl, n_rad, i, pdg2, constraints, & do_not_check_regular = do_not_check_regular) else exit SCAN_VERTICES end if end do SCAN_VERTICES end if end do end subroutine ps_table_split @ %def ps_table_split @ The worker part: insert the list of particles found by vertex matching in place of entry [[i]] in the PDG list. Then split/record further. The [[n_in]] parameter tells the replacement routine to insert the new particles after entry [[n_in]]. Otherwise, they follow index [[i]]. <>= procedure :: insert => ps_table_insert <>= recursive subroutine ps_table_insert & (table, pl, n_rad, i, pdg, constraints, n_in, do_not_check_regular) class(ps_table_t), intent(inout) :: table class(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_rad, i integer, dimension(:), intent(in) :: pdg type(split_constraints_t), intent(in) :: constraints integer, intent(in), optional :: n_in logical, intent(in), optional :: do_not_check_regular type(pdg_list_t) :: pl_insert logical :: passed integer :: k, s s = size (pdg) call pl_insert%init (s) do k = 1, s call pl_insert%set (k, pdg(k)) end do call constraints%check_before_insert (table, pl%get (i), pl_insert, passed) if (passed) then if (.not. is_colored_isr ()) return call table%split (pl%replace (i, pl_insert, n_in), n_rad + s - 1, & constraints, record = .true., do_not_check_regular = .true.) end if contains logical function is_colored_isr () result (ok) type(pdg_list_t) :: pl_replaced ok = .true. if (present (n_in)) then if (i <= n_in) then ok = pl_insert%contains_colored_particles () if (.not. ok) then pl_replaced = pl%replace (i, pl_insert, n_in) associate (size_replaced => pl_replaced%get_pdg_sizes (), & size => pl%get_pdg_sizes ()) ok = all (size_replaced(:n_in) == size(:n_in)) end associate end if end if end if end function is_colored_isr end subroutine ps_table_insert @ %def ps_table_insert @ Special case: If we are splitting an initial particle, there is slightly more to do. We loop over the particles from the vertex match and replace the initial particle by each of them in turn. The remaining particles must be appended after the second initial particle, so they will end up in the out state. This is done by providing the [[n_in]] argument to the base method as an optional argument. Note that we must call the base-method procedure explicitly, so the [[table]] argument keeps its dynamic type as [[if_table]] inside this procedure. <>= procedure :: insert => if_table_insert <>= recursive subroutine if_table_insert & (table, pl, n_rad, i, pdg, constraints, n_in, do_not_check_regular) class(if_table_t), intent(inout) :: table class(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_rad, i integer, dimension(:), intent(in) :: pdg type(split_constraints_t), intent(in) :: constraints integer, intent(in), optional :: n_in logical, intent(in), optional :: do_not_check_regular integer, dimension(:), allocatable :: pdg_work integer :: p if (i > 2) then call ps_table_insert (table, pl, n_rad, i, pdg, constraints, & do_not_check_regular = do_not_check_regular) else allocate (pdg_work (size (pdg))) do p = 1, size (pdg) pdg_work(1) = pdg(p) pdg_work(2:p) = pdg(1:p-1) pdg_work(p+1:) = pdg(p+1:) select case (table%proc_type) case (PROC_DECAY) call ps_table_insert (table, & pl, n_rad, i, pdg_work, constraints, n_in = 1, & do_not_check_regular = do_not_check_regular) case (PROC_SCATTER) call ps_table_insert (table, & pl, n_rad, i, pdg_work, constraints, n_in = 2, & do_not_check_regular = do_not_check_regular) end select end do end if end subroutine if_table_insert @ %def if_table_insert @ Sort before recording. In the case of the [[if_table]], we do not sort the first [[n_in]] particle entries. Instead, we check whether they are allowed in the [[pl_beam]] PDG list, if that is provided. <>= procedure :: record_sorted => ps_table_record_sorted <>= procedure :: record_sorted => if_table_record_sorted <>= subroutine ps_table_record_sorted & (table, pl, n_loop, n_rad, constraints, do_not_check_regular, passed) class(ps_table_t), intent(inout) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop, n_rad type(split_constraints_t), intent(in) :: constraints logical, intent(in), optional :: do_not_check_regular logical, intent(out) :: passed call table%record (pl%sort_abs (), n_loop, n_rad, constraints, & do_not_check_regular, passed) end subroutine ps_table_record_sorted subroutine if_table_record_sorted & (table, pl, n_loop, n_rad, constraints, do_not_check_regular, passed) class(if_table_t), intent(inout) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop, n_rad type(split_constraints_t), intent(in) :: constraints logical, intent(in), optional :: do_not_check_regular logical, intent(out) :: passed call table%record (pl%sort_abs (2), n_loop, n_rad, constraints, & do_not_check_regular, passed) end subroutine if_table_record_sorted @ %def ps_table_record_sorted if_table_record_sorted @ Record an entry: insert into the list. Check the ordering and insert it at the correct place, unless it is already there. We record an array only if its mass sum is less than the total available energy. This restriction is removed by setting [[constrained]] to false. <>= procedure :: record => ps_table_record <>= subroutine ps_table_record (table, pl, n_loop, n_rad, constraints, & do_not_check_regular, passed) class(ps_table_t), intent(inout) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop, n_rad type(split_constraints_t), intent(in) :: constraints logical, intent(in), optional :: do_not_check_regular logical, intent(out) :: passed type(ps_entry_t), pointer :: current logical :: needs_check passed = .false. needs_check = .true. if (present (do_not_check_regular)) needs_check = .not. do_not_check_regular if (needs_check .and. .not. pl%is_regular ()) then call msg_warning ("Record ps_table entry: Irregular pdg-list encountered!") return end if call constraints%check_before_record (table, pl, n_loop, passed) if (.not. passed) then return end if current => table%first do while (associated (current)) if (pl == current) then if (n_loop == current%n_loop) return else if (pl < current) then call insert return end if current => current%next end do call insert contains subroutine insert () type(ps_entry_t), pointer :: entry allocate (entry) entry%pdg_list_t = pl entry%n_loop = n_loop entry%n_rad = n_rad if (associated (current)) then if (associated (current%previous)) then current%previous%next => entry entry%previous => current%previous else table%first => entry end if entry%next => current current%previous => entry else if (associated (table%last)) then table%last%next => entry entry%previous => table%last else table%first => entry end if table%last => entry end if end subroutine insert end subroutine ps_table_record @ %def ps_table_record @ \subsection{Tools} Compute the mass sum for a PDG list object, counting the entries with indices between (including) [[n1]] and [[n2]]. Rely on the requirement that if an entry is a PDG array, this array must be degenerate in mass. <>= function mass_sum (pl, n1, n2, model) result (m) type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n1, n2 class(model_data_t), intent(in), target :: model integer, dimension(:), allocatable :: pdg real(default) :: m type(field_data_t), pointer :: prt integer :: i m = 0 do i = n1, n2 pdg = pl%get (i) prt => model%get_field_ptr (pdg(1)) m = m + prt%get_mass () end do end function mass_sum @ %def mass_sum @ Invert a PDG array, replacing particles by antiparticles. This depends on the model. <>= function invert_pdg_array (pa, model) result (pa_inv) type(pdg_array_t), intent(in) :: pa class(model_data_t), intent(in), target :: model type(pdg_array_t) :: pa_inv type(field_data_t), pointer :: prt integer :: i, pdg pa_inv = pa do i = 1, pa_inv%get_length () pdg = pa_inv%get (i) prt => model%get_field_ptr (pdg) if (prt%has_antiparticle ()) call pa_inv%set (i, -pdg) end do end function invert_pdg_array @ %def invert_pdg_array @ \subsection{Access results} Return the number of generated decays. <>= procedure :: get_length => ps_table_get_length <>= function ps_table_get_length (ps_table) result (n) class(ps_table_t), intent(in) :: ps_table integer :: n type(ps_entry_t), pointer :: entry n = 0 entry => ps_table%first do while (associated (entry)) n = n + 1 entry => entry%next end do end function ps_table_get_length @ %def ps_table_get_length @ <>= procedure :: get_emitters => ps_table_get_emitters <>= subroutine ps_table_get_emitters (table, constraints, emitters) class(ps_table_t), intent(in) :: table type(split_constraints_t), intent(in) :: constraints integer, dimension(:), allocatable, intent(out) :: emitters class(pdg_list_t), pointer :: pl integer :: i logical :: passed type(vertex_iterator_t) :: vit integer, dimension(:), allocatable :: pdg1, pdg2 integer :: n_emitters integer, dimension(:), allocatable :: emitters_tmp integer, parameter :: buf0 = 6 n_emitters = 0 pl => table%first allocate (emitters_tmp (buf0)) do i = 1, pl%get_size () call constraints%check_before_split (table, pl, i, passed) if (passed) then pdg1 = pl%get(i) call vit%init (table%model, pdg1, .false.) do call vit%get_next_match(pdg2) if (allocated (pdg2)) then if (n_emitters + 1 > size (emitters_tmp)) & call extend_integer_array (emitters_tmp, 10) emitters_tmp (n_emitters + 1) = pdg1(1) n_emitters = n_emitters + 1 else exit end if end do end if end do allocate (emitters (n_emitters)) emitters = emitters_tmp (1:n_emitters) deallocate (emitters_tmp) end subroutine ps_table_get_emitters @ %def ps_table_get_emitters @ Return an allocated array of decay products (PDG codes). If requested, return also the loop and radiation order count. <>= procedure :: get_pdg_out => ps_table_get_pdg_out <>= subroutine ps_table_get_pdg_out (ps_table, i, pa_out, n_loop, n_rad) class(ps_table_t), intent(in) :: ps_table integer, intent(in) :: i type(pdg_array_t), dimension(:), allocatable, intent(out) :: pa_out integer, intent(out), optional :: n_loop, n_rad type(ps_entry_t), pointer :: entry integer :: n, j n = 0 entry => ps_table%first FIND_ENTRY: do while (associated (entry)) n = n + 1 if (n == i) then allocate (pa_out (entry%get_size ())) do j = 1, entry%get_size () pa_out(j) = entry%get (j) if (present (n_loop)) n_loop = entry%n_loop if (present (n_rad)) n_rad = entry%n_rad end do exit FIND_ENTRY end if entry => entry%next end do FIND_ENTRY end subroutine ps_table_get_pdg_out @ %def ps_table_get_pdg_out @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[auto_components_ut.f90]]>>= <> module auto_components_ut use unit_tests use auto_components_uti <> <> contains <> end module auto_components_ut @ %def auto_components_ut @ <<[[auto_components_uti.f90]]>>= <> module auto_components_uti <> <> use pdg_arrays use model_data use model_testbed, only: prepare_model, cleanup_model use auto_components <> <> contains <> end module auto_components_uti @ %def auto_components_ut @ API: driver for the unit tests below. <>= public :: auto_components_test <>= subroutine auto_components_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine auto_components_test @ %def auto_components_tests @ \subsubsection{Generate Decay Table} Determine all kinematically allowed decay channels for a Higgs boson, using default parameter values. <>= call test (auto_components_1, "auto_components_1", & "generate decay table", & u, results) <>= public :: auto_components_1 <>= subroutine auto_components_1 (u) integer, intent(in) :: u class(model_data_t), pointer :: model type(field_data_t), pointer :: prt type(ds_table_t) :: ds_table type(split_constraints_t) :: constraints write (u, "(A)") "* Test output: auto_components_1" write (u, "(A)") "* Purpose: determine Higgs decay table" write (u, *) write (u, "(A)") "* Read Standard Model" model => null () call prepare_model (model, var_str ("SM")) prt => model%get_field_ptr (25) write (u, *) write (u, "(A)") "* Higgs decays n = 2" write (u, *) call constraints%init (2) call constraints%set (1, constrain_n_tot (2)) call constraints%set (2, constrain_mass_sum (prt%get_mass ())) call ds_table%make (model, 25, constraints) call ds_table%write (u) call ds_table%final () write (u, *) write (u, "(A)") "* Higgs decays n = 3 (w/o radiative)" write (u, *) call constraints%init (3) call constraints%set (1, constrain_n_tot (3)) call constraints%set (2, constrain_mass_sum (prt%get_mass ())) call constraints%set (3, constrain_radiation ()) call ds_table%make (model, 25, constraints) call ds_table%write (u) call ds_table%final () write (u, *) write (u, "(A)") "* Higgs decays n = 3 (w/ radiative)" write (u, *) call constraints%init (2) call constraints%set (1, constrain_n_tot (3)) call constraints%set (2, constrain_mass_sum (prt%get_mass ())) call ds_table%make (model, 25, constraints) call ds_table%write (u) call ds_table%final () write (u, *) write (u, "(A)") "* Cleanup" call cleanup_model (model) deallocate (model) write (u, *) write (u, "(A)") "* Test output end: auto_components_1" end subroutine auto_components_1 @ %def auto_components_1 @ \subsubsection{Generate radiation} Given a final state, add radiation (NLO and NNLO). We provide a list of particles that is allowed to occur in the generated final states. <>= call test (auto_components_2, "auto_components_2", & "generate NLO corrections, final state", & u, results) <>= public :: auto_components_2 <>= subroutine auto_components_2 (u) integer, intent(in) :: u class(model_data_t), pointer :: model type(pdg_list_t), dimension(:), allocatable :: pl, pl_zzh type(pdg_list_t) :: pl_match type(fs_table_t) :: fs_table type(split_constraints_t) :: constraints real(default) :: sqrts integer :: i write (u, "(A)") "* Test output: auto_components_2" write (u, "(A)") "* Purpose: generate radiation (NLO)" write (u, *) write (u, "(A)") "* Read Standard Model" model => null () call prepare_model (model, var_str ("SM")) write (u, *) write (u, "(A)") "* LO final state" write (u, *) allocate (pl (2)) call pl(1)%init (2) call pl(1)%set (1, 1) call pl(1)%set (2, -1) call pl(2)%init (2) call pl(2)%set (1, 21) call pl(2)%set (2, 21) do i = 1, 2 call pl(i)%write (u); write (u, *) end do write (u, *) write (u, "(A)") "* Initialize FS table" write (u, *) call constraints%init (1) call constraints%set (1, constrain_n_tot (3)) call fs_table%init (model, pl, constraints) call fs_table%write (u) write (u, *) write (u, "(A)") "* Generate NLO corrections, unconstrained" write (u, *) call fs_table%radiate (constraints) call fs_table%write (u) call fs_table%final () write (u, *) write (u, "(A)") "* Generate NLO corrections, & &complete but mass-constrained" write (u, *) sqrts = 50 call constraints%init (2) call constraints%set (1, constrain_n_tot (3)) call constraints%set (2, constrain_mass_sum (sqrts)) call fs_table%init (model, pl, constraints) call fs_table%radiate (constraints) call fs_table%write (u) call fs_table%final () write (u, *) write (u, "(A)") "* Generate NLO corrections, restricted" write (u, *) call pl_match%init ([1, -1, 21]) call constraints%init (2) call constraints%set (1, constrain_n_tot (3)) call constraints%set (2, constrain_insert (pl_match)) call fs_table%init (model, pl, constraints) call fs_table%radiate (constraints) call fs_table%write (u) call fs_table%final () write (u, *) write (u, "(A)") "* Generate NNLO corrections, restricted, with one loop" write (u, *) call pl_match%init ([1, -1, 21]) call constraints%init (3) call constraints%set (1, constrain_n_tot (4)) call constraints%set (2, constrain_n_loop (1)) call constraints%set (3, constrain_insert (pl_match)) call fs_table%init (model, pl, constraints) call fs_table%enable_loops () call fs_table%radiate (constraints) call fs_table%write (u) call fs_table%final () write (u, *) write (u, "(A)") "* Generate NNLO corrections, restricted, with loops" write (u, *) call constraints%init (2) call constraints%set (1, constrain_n_tot (4)) call constraints%set (2, constrain_insert (pl_match)) call fs_table%init (model, pl, constraints) call fs_table%enable_loops () call fs_table%radiate (constraints) call fs_table%write (u) call fs_table%final () write (u, *) write (u, "(A)") "* Generate NNLO corrections, restricted, to Z Z H, & &no loops" write (u, *) allocate (pl_zzh (1)) call pl_zzh(1)%init (3) call pl_zzh(1)%set (1, 23) call pl_zzh(1)%set (2, 23) call pl_zzh(1)%set (3, 25) call constraints%init (3) call constraints%set (1, constrain_n_tot (5)) call constraints%set (2, constrain_mass_sum (500._default)) call constraints%set (3, constrain_require (pl_zzh(1))) call fs_table%init (model, pl_zzh, constraints) call fs_table%radiate (constraints) call fs_table%write (u) call fs_table%final () call cleanup_model (model) deallocate (model) write (u, *) write (u, "(A)") "* Test output end: auto_components_2" end subroutine auto_components_2 @ %def auto_components_2 @ \subsubsection{Generate radiation from initial and final state} Given a process, add radiation (NLO and NNLO). We provide a list of particles that is allowed to occur in the generated final states. <>= call test (auto_components_3, "auto_components_3", & "generate NLO corrections, in and out", & u, results) <>= public :: auto_components_3 <>= subroutine auto_components_3 (u) integer, intent(in) :: u class(model_data_t), pointer :: model type(pdg_list_t), dimension(:), allocatable :: pl_in, pl_out type(pdg_list_t) :: pl_match, pl_beam type(if_table_t) :: if_table type(split_constraints_t) :: constraints real(default) :: sqrts integer :: i write (u, "(A)") "* Test output: auto_components_3" write (u, "(A)") "* Purpose: generate radiation (NLO)" write (u, *) write (u, "(A)") "* Read Standard Model" model => null () call prepare_model (model, var_str ("SM")) write (u, *) write (u, "(A)") "* LO initial state" write (u, *) allocate (pl_in (2)) call pl_in(1)%init (2) call pl_in(1)%set (1, 1) call pl_in(1)%set (2, -1) call pl_in(2)%init (2) call pl_in(2)%set (1, -1) call pl_in(2)%set (2, 1) do i = 1, 2 call pl_in(i)%write (u); write (u, *) end do write (u, *) write (u, "(A)") "* LO final state" write (u, *) allocate (pl_out (1)) call pl_out(1)%init (1) call pl_out(1)%set (1, 23) call pl_out(1)%write (u); write (u, *) write (u, *) write (u, "(A)") "* Initialize FS table" write (u, *) call constraints%init (1) call constraints%set (1, constrain_n_tot (4)) call if_table%init (model, pl_in, pl_out, constraints) call if_table%write (u) write (u, *) write (u, "(A)") "* Generate NLO corrections, unconstrained" write (u, *) call if_table%radiate (constraints) call if_table%write (u) call if_table%final () write (u, *) write (u, "(A)") "* Generate NLO corrections, & &complete but mass-constrained" write (u, *) sqrts = 100 call constraints%init (2) call constraints%set (1, constrain_n_tot (4)) call constraints%set (2, constrain_mass_sum (sqrts)) call if_table%init (model, pl_in, pl_out, constraints) call if_table%radiate (constraints) call if_table%write (u) call if_table%final () write (u, *) write (u, "(A)") "* Generate NLO corrections, & &mass-constrained, restricted beams" write (u, *) call pl_beam%init (3) call pl_beam%set (1, 1) call pl_beam%set (2, -1) call pl_beam%set (3, 21) call constraints%init (3) call constraints%set (1, constrain_n_tot (4)) call constraints%set (2, constrain_in_state (pl_beam)) call constraints%set (3, constrain_mass_sum (sqrts)) call if_table%init (model, pl_in, pl_out, constraints) call if_table%radiate (constraints) call if_table%write (u) call if_table%final () write (u, *) write (u, "(A)") "* Generate NLO corrections, restricted" write (u, *) call pl_match%init ([1, -1, 21]) call constraints%init (4) call constraints%set (1, constrain_n_tot (4)) call constraints%set (2, constrain_in_state (pl_beam)) call constraints%set (3, constrain_mass_sum (sqrts)) call constraints%set (4, constrain_insert (pl_match)) call if_table%init (model, pl_in, pl_out, constraints) call if_table%radiate (constraints) call if_table%write (u) call if_table%final () write (u, *) write (u, "(A)") "* Generate NNLO corrections, restricted, Z preserved, & &with loops" write (u, *) call constraints%init (5) call constraints%set (1, constrain_n_tot (5)) call constraints%set (2, constrain_in_state (pl_beam)) call constraints%set (3, constrain_mass_sum (sqrts)) call constraints%set (4, constrain_insert (pl_match)) call constraints%set (5, constrain_require (pl_out(1))) call if_table%init (model, pl_in, pl_out, constraints) call if_table%enable_loops () call if_table%radiate (constraints) call if_table%write (u) call if_table%final () call cleanup_model (model) deallocate (model) write (u, *) write (u, "(A)") "* Test output end: auto_components_3" end subroutine auto_components_3 @ %def auto_components_3 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Creating the real flavor structure} <<[[radiation_generator.f90]]>>= <> module radiation_generator <> <> use diagnostics use io_units use sorting, only: sort_abs use physics_defs, only: PHOTON, GLUON use pdg_arrays use flavors use model_data use auto_components use string_utils, only: split_string, string_contains_word implicit none private <> <> contains <> end module radiation_generator @ %def radiation_generator @ <>= type :: pdg_sorter_t integer :: pdg logical :: checked = .false. integer :: associated_born = 0 end type pdg_sorter_t @ %def pdg_sorter @ <>= type :: pdg_states_t type(pdg_array_t), dimension(:), allocatable :: pdg type(pdg_states_t), pointer :: next integer :: n_particles contains <> end type pdg_states_t @ %def pdg_states_t <>= procedure :: init => pdg_states_init <>= subroutine pdg_states_init (states) class(pdg_states_t), intent(inout) :: states nullify (states%next) end subroutine pdg_states_init @ %def pdg_states_init @ <>= procedure :: add => pdg_states_add <>= subroutine pdg_states_add (states, pdg) class(pdg_states_t), intent(inout), target :: states type(pdg_array_t), dimension(:), intent(in) :: pdg type(pdg_states_t), pointer :: current_state select type (states) type is (pdg_states_t) current_state => states do if (associated (current_state%next)) then current_state => current_state%next else allocate (current_state%next) nullify(current_state%next%next) current_state%pdg = pdg exit end if end do end select end subroutine pdg_states_add @ %def pdg_states_add @ <>= procedure :: get_n_states => pdg_states_get_n_states <>= function pdg_states_get_n_states (states) result (n) class(pdg_states_t), intent(in), target :: states integer :: n type(pdg_states_t), pointer :: current_state n = 0 select type(states) type is (pdg_states_t) current_state => states do if (associated (current_state%next)) then n = n+1 current_state => current_state%next else exit end if end do end select end function pdg_states_get_n_states @ %def pdg_states_get_n_states @ <>= type :: prt_queue_t type(string_t), dimension(:), allocatable :: prt_string type(prt_queue_t), pointer :: next => null () type(prt_queue_t), pointer :: previous => null () type(prt_queue_t), pointer :: front => null () type(prt_queue_t), pointer :: current_prt => null () type(prt_queue_t), pointer :: back => null () integer :: n_lists = 0 contains <> end type prt_queue_t @ %def prt_queue_t @ <>= procedure :: null => prt_queue_null <>= subroutine prt_queue_null (queue) class(prt_queue_t), intent(out) :: queue queue%next => null () queue%previous => null () queue%front => null () queue%current_prt => null () queue%back => null () queue%n_lists = 0 if (allocated (queue%prt_string)) deallocate (queue%prt_string) end subroutine prt_queue_null @ %def prt_queue_null @ <>= procedure :: append => prt_queue_append <>= subroutine prt_queue_append (queue, prt_string) class(prt_queue_t), intent(inout) :: queue type(string_t), intent(in), dimension(:) :: prt_string type(prt_queue_t), pointer :: new_element => null () type(prt_queue_t), pointer :: current_back => null () allocate (new_element) allocate (new_element%prt_string(size (prt_string))) new_element%prt_string = prt_string if (associated (queue%back)) then current_back => queue%back current_back%next => new_element new_element%previous => current_back queue%back => new_element else !!! Initial entry queue%front => new_element queue%back => queue%front queue%current_prt => queue%front end if queue%n_lists = queue%n_lists + 1 end subroutine prt_queue_append @ %def prt_queue_append @ <>= procedure :: get => prt_queue_get <>= subroutine prt_queue_get (queue, prt_string) class(prt_queue_t), intent(inout) :: queue type(string_t), dimension(:), allocatable, intent(out) :: prt_string if (associated (queue%current_prt)) then prt_string = queue%current_prt%prt_string if (associated (queue%current_prt%next)) & queue%current_prt => queue%current_prt%next else prt_string = " " end if end subroutine prt_queue_get @ %def prt_queue_get @ As above. <>= procedure :: get_last => prt_queue_get_last <>= subroutine prt_queue_get_last (queue, prt_string) class(prt_queue_t), intent(in) :: queue type(string_t), dimension(:), allocatable, intent(out) :: prt_string if (associated (queue%back)) then allocate (prt_string(size (queue%back%prt_string))) prt_string = queue%back%prt_string else prt_string = " " end if end subroutine prt_queue_get_last @ %def prt_queue_get_last @ <>= procedure :: reset => prt_queue_reset <>= subroutine prt_queue_reset (queue) class(prt_queue_t), intent(inout) :: queue queue%current_prt => queue%front end subroutine prt_queue_reset @ %def prt_queue_reset @ <>= procedure :: check_for_same_prt_strings => prt_queue_check_for_same_prt_strings <>= function prt_queue_check_for_same_prt_strings (queue) result (val) class(prt_queue_t), intent(inout) :: queue logical :: val type(string_t), dimension(:), allocatable :: prt_string integer, dimension(:,:), allocatable :: i_particle integer :: n_d, n_dbar, n_u, n_ubar, n_s, n_sbar, n_gl, n_e, n_ep, n_mu, n_mup, n_A integer :: i, j call queue%reset () allocate (i_particle (queue%n_lists, 12)) do i = 1, queue%n_lists call queue%get (prt_string) n_d = count_particle (prt_string, 1) n_dbar = count_particle (prt_string, -1) n_u = count_particle (prt_string, 2) n_ubar = count_particle (prt_string, -2) n_s = count_particle (prt_string, 3) n_sbar = count_particle (prt_string, -3) n_gl = count_particle (prt_string, 21) n_e = count_particle (prt_string, 11) n_ep = count_particle (prt_string, -11) n_mu = count_particle (prt_string, 13) n_mup = count_particle (prt_string, -13) n_A = count_particle (prt_string, 22) i_particle (i, 1) = n_d i_particle (i, 2) = n_dbar i_particle (i, 3) = n_u i_particle (i, 4) = n_ubar i_particle (i, 5) = n_s i_particle (i, 6) = n_sbar i_particle (i, 7) = n_gl i_particle (i, 8) = n_e i_particle (i, 9) = n_ep i_particle (i, 10) = n_mu i_particle (i, 11) = n_mup i_particle (i, 12) = n_A end do val = .false. do i = 1, queue%n_lists do j = 1, queue%n_lists if (i == j) cycle val = val .or. all (i_particle (i,:) == i_particle(j,:)) end do end do contains function count_particle (prt_string, pdg) result (n) type(string_t), dimension(:), intent(in) :: prt_string integer, intent(in) :: pdg integer :: n integer :: i type(string_t) :: prt_ref n = 0 select case (pdg) case (1) prt_ref = "d" case (-1) prt_ref = "dbar" case (2) prt_ref = "u" case (-2) prt_ref = "ubar" case (3) prt_ref = "s" case (-3) prt_ref = "sbar" case (21) prt_ref = "gl" case (11) prt_ref = "e-" case (-11) prt_ref = "e+" case (13) prt_ref = "mu-" case (-13) prt_ref = "mu+" case (22) prt_ref = "A" end select do i = 1, size (prt_string) if (prt_string(i) == prt_ref) n = n+1 end do end function count_particle end function prt_queue_check_for_same_prt_strings @ %def prt_queue_check_for_same_prt_strings @ <>= procedure :: contains => prt_queue_contains <>= function prt_queue_contains (queue, prt_string) result (val) class(prt_queue_t), intent(in) :: queue type(string_t), intent(in), dimension(:) :: prt_string logical :: val type(prt_queue_t), pointer :: current => null() if (associated (queue%front)) then current => queue%front else call msg_fatal ("Trying to access empty particle queue") end if val = .false. do if (size (current%prt_string) == size (prt_string)) then if (all (current%prt_string == prt_string)) then val = .true. exit end if end if if (associated (current%next)) then current => current%next else exit end if end do end function prt_queue_contains @ %def prt_string_list_contains @ <>= procedure :: write => prt_queue_write <>= subroutine prt_queue_write (queue, unit) class(prt_queue_t), intent(in) :: queue integer, optional :: unit type(prt_queue_t), pointer :: current => null () integer :: i, j, u u = given_output_unit (unit) if (associated (queue%front)) then current => queue%front else write (u, "(A)") "[Particle queue is empty]" return end if j = 1 do write (u, "(I2,A,1X)", advance = 'no') j , ":" do i = 1, size (current%prt_string) write (u, "(A,1X)", advance = 'no') char (current%prt_string(i)) end do write (u, "(A)") if (associated (current%next)) then current => current%next j = j+1 else exit end if end do end subroutine prt_queue_write @ %def prt_queue_write @ <>= subroutine sort_prt (prt, model) type(string_t), dimension(:), intent(inout) :: prt class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(:), allocatable :: pdg type(flavor_t) :: flv integer :: i call create_pdg_array (prt, model, pdg) call sort_pdg (pdg) do i = 1, size (pdg) call flv%init (pdg(i)%get(), model) prt(i) = flv%get_name () end do end subroutine sort_prt subroutine sort_pdg (pdg) type(pdg_array_t), dimension(:), intent(inout) :: pdg integer, dimension(:), allocatable :: i_pdg integer :: i allocate (i_pdg (size (pdg))) do i = 1, size (pdg) i_pdg(i) = pdg(i)%get () end do i_pdg = sort_abs (i_pdg) do i = 1, size (pdg) call pdg(i)%set (1, i_pdg(i)) end do end subroutine sort_pdg subroutine create_pdg_array (prt, model, pdg) type (string_t), dimension(:), intent(in) :: prt class (model_data_t), intent(in), target :: model type(pdg_array_t), dimension(:), allocatable, intent(out) :: pdg type(flavor_t) :: flv integer :: i allocate (pdg (size (prt))) do i = 1, size (prt) call flv%init (prt(i), model) pdg(i) = flv%get_pdg () end do end subroutine create_pdg_array @ %def sort_prt sort_pdg create_pdg_array @ This is used in unit tests: <>= subroutine write_pdg_array (pdg, u) use pdg_arrays type(pdg_array_t), dimension(:), intent(in) :: pdg integer, intent(in) :: u integer :: i do i = 1, size (pdg) call pdg(i)%write (u) end do write (u, "(A)") end subroutine write_pdg_array subroutine write_particle_string (prt, u) <> type(string_t), dimension(:), intent(in) :: prt integer, intent(in) :: u integer :: i do i = 1, size (prt) write (u, "(A,1X)", advance = "no") char (prt(i)) end do write (u, "(A)") end subroutine write_particle_string @ %def write_pdg_array write_particle_string <>= type :: reshuffle_list_t integer, dimension(:), allocatable :: ii type(reshuffle_list_t), pointer :: next => null () contains <> end type reshuffle_list_t @ %def reshuffle_list_t @ <>= procedure :: write => reshuffle_list_write <>= subroutine reshuffle_list_write (rlist) class(reshuffle_list_t), intent(in) :: rlist type(reshuffle_list_t), pointer :: current => null () integer :: i print *, 'Content of reshuffling list: ' if (associated (rlist%next)) then current => rlist%next i = 1 do print *, 'i: ', i, 'list: ', current%ii i = i + 1 if (associated (current%next)) then current => current%next else exit end if end do else print *, '[EMPTY]' end if end subroutine reshuffle_list_write @ %def reshuffle_list_write @ <>= procedure :: append => reshuffle_list_append <>= subroutine reshuffle_list_append (rlist, ii) class(reshuffle_list_t), intent(inout) :: rlist integer, dimension(:), allocatable, intent(in) :: ii type(reshuffle_list_t), pointer :: current if (associated (rlist%next)) then current => rlist%next do if (associated (current%next)) then current => current%next else allocate (current%next) allocate (current%next%ii (size (ii))) current%next%ii = ii exit end if end do else allocate (rlist%next) allocate (rlist%next%ii (size (ii))) rlist%next%ii = ii end if end subroutine reshuffle_list_append @ %def reshuffle_list_append @ <>= procedure :: is_empty => reshuffle_list_is_empty <>= elemental function reshuffle_list_is_empty (rlist) result (is_empty) logical :: is_empty class(reshuffle_list_t), intent(in) :: rlist is_empty = .not. associated (rlist%next) end function reshuffle_list_is_empty @ %def reshuffle_list_is_empty @ <>= procedure :: get => reshuffle_list_get <>= function reshuffle_list_get (rlist, index) result (ii) integer, dimension(:), allocatable :: ii class(reshuffle_list_t), intent(inout) :: rlist integer, intent(in) :: index type(reshuffle_list_t), pointer :: current => null () integer :: i current => rlist%next do i = 1, index - 1 if (associated (current%next)) then current => current%next else call msg_fatal ("Index exceeds size of reshuffling list") end if end do allocate (ii (size (current%ii))) ii = current%ii end function reshuffle_list_get @ %def reshuffle_list_get @ We need to reset the [[reshuffle_list]] in order to deal with subsequent usages of the [[radiation_generator]]. Below is obviously the lazy and dirty solution. Otherwise, we would have to equip this auxiliary type with additional information about [[last]] and [[previous]] pointers. Considering that at most $n_{\rm{legs}}$ integers are saved in the lists, and that the subroutine is only called during the initialization phase (more precisely: at the moment only in the [[radiation_generator]] unit tests), I think this quick fix is justified. <>= procedure :: reset => reshuffle_list_reset <>= subroutine reshuffle_list_reset (rlist) class(reshuffle_list_t), intent(inout) :: rlist rlist%next => null () end subroutine reshuffle_list_reset @ %def reshuffle_list_reset @ <>= public :: radiation_generator_t <>= type :: radiation_generator_t logical :: qcd_enabled = .false. logical :: qed_enabled = .false. logical :: is_gluon = .false. logical :: fs_gluon = .false. logical :: is_photon = .false. logical :: fs_photon = .false. logical :: only_final_state = .true. type(pdg_list_t) :: pl_in, pl_out type(pdg_list_t) :: pl_excluded_gauge_splittings type(split_constraints_t) :: constraints integer :: n_tot integer :: n_in, n_out integer :: n_loops integer :: n_light_quarks real(default) :: mass_sum type(prt_queue_t) :: prt_queue type(pdg_states_t) :: pdg_raw type(pdg_array_t), dimension(:), allocatable :: pdg_in_born, pdg_out_born type(if_table_t) :: if_table type(reshuffle_list_t) :: reshuffle_list contains <> end type radiation_generator_t @ @ %def radiation_generator_t <>= generic :: init => init_pdg_list, init_pdg_array procedure :: init_pdg_list => radiation_generator_init_pdg_list procedure :: init_pdg_array => radiation_generator_init_pdg_array <>= subroutine radiation_generator_init_pdg_list & (generator, pl_in, pl_out, pl_excluded_gauge_splittings, qcd, qed) class(radiation_generator_t), intent(inout) :: generator type(pdg_list_t), intent(in) :: pl_in, pl_out type(pdg_list_t), intent(in) :: pl_excluded_gauge_splittings logical, intent(in), optional :: qcd, qed if (present (qcd)) generator%qcd_enabled = qcd if (present (qed)) generator%qed_enabled = qed generator%pl_in = pl_in generator%pl_out = pl_out generator%pl_excluded_gauge_splittings = pl_excluded_gauge_splittings generator%is_gluon = pl_in%search_for_particle (GLUON) generator%fs_gluon = pl_out%search_for_particle (GLUON) generator%is_photon = pl_in%search_for_particle (PHOTON) generator%fs_photon = pl_out%search_for_particle (PHOTON) generator%mass_sum = 0._default call generator%pdg_raw%init () end subroutine radiation_generator_init_pdg_list subroutine radiation_generator_init_pdg_array & (generator, pdg_in, pdg_out, pdg_excluded_gauge_splittings, qcd, qed) class(radiation_generator_t), intent(inout) :: generator type(pdg_array_t), intent(in), dimension(:) :: pdg_in, pdg_out type(pdg_array_t), intent(in), dimension(:) :: pdg_excluded_gauge_splittings logical, intent(in), optional :: qcd, qed type(pdg_list_t) :: pl_in, pl_out type(pdg_list_t) :: pl_excluded_gauge_splittings integer :: i call pl_in%init(size (pdg_in)) call pl_out%init(size (pdg_out)) do i = 1, size (pdg_in) call pl_in%set (i, pdg_in(i)) end do do i = 1, size (pdg_out) call pl_out%set (i, pdg_out(i)) end do call pl_excluded_gauge_splittings%init(size (pdg_excluded_gauge_splittings)) do i = 1, size (pdg_excluded_gauge_splittings) call pl_excluded_gauge_splittings%set & (i, pdg_excluded_gauge_splittings(i)) end do call generator%init (pl_in, pl_out, pl_excluded_gauge_splittings, qcd, qed) end subroutine radiation_generator_init_pdg_array @ %def radiation_generator_init_pdg_list radiation_generator_init_pdg_array @ <>= procedure :: set_initial_state_emissions => & radiation_generator_set_initial_state_emissions <>= subroutine radiation_generator_set_initial_state_emissions (generator) class(radiation_generator_t), intent(inout) :: generator generator%only_final_state = .false. end subroutine radiation_generator_set_initial_state_emissions @ %def radiation_generator_set_initial_state_emissions @ <>= procedure :: setup_if_table => radiation_generator_setup_if_table <>= subroutine radiation_generator_setup_if_table (generator, model) class(radiation_generator_t), intent(inout) :: generator class(model_data_t), intent(in), target :: model type(pdg_list_t), dimension(:), allocatable :: pl_in, pl_out allocate (pl_in(1), pl_out(1)) pl_in(1) = generator%pl_in pl_out(1) = generator%pl_out call generator%if_table%init & (model, pl_in, pl_out, generator%constraints) end subroutine radiation_generator_setup_if_table @ %def radiation_generator_setup_if_table @ <>= generic :: reset_particle_content => reset_particle_content_pdg_array, & reset_particle_content_pdg_list procedure :: reset_particle_content_pdg_list => & radiation_generator_reset_particle_content_pdg_list procedure :: reset_particle_content_pdg_array => & radiation_generator_reset_particle_content_pdg_array <>= subroutine radiation_generator_reset_particle_content_pdg_list (generator, pl) class(radiation_generator_t), intent(inout) :: generator type(pdg_list_t), intent(in) :: pl generator%pl_out = pl generator%fs_gluon = pl%search_for_particle (GLUON) generator%fs_photon = pl%search_for_particle (PHOTON) end subroutine radiation_generator_reset_particle_content_pdg_list subroutine radiation_generator_reset_particle_content_pdg_array (generator, pdg) class(radiation_generator_t), intent(inout) :: generator type(pdg_array_t), intent(in), dimension(:) :: pdg type(pdg_list_t) :: pl integer :: i call pl%init (size (pdg)) do i = 1, size (pdg) call pl%set (i, pdg(i)) end do call generator%reset_particle_content (pl) end subroutine radiation_generator_reset_particle_content_pdg_array @ %def radiation_generator_reset_particle_content @ <>= procedure :: reset_reshuffle_list=> radiation_generator_reset_reshuffle_list <>= subroutine radiation_generator_reset_reshuffle_list (generator) class(radiation_generator_t), intent(inout) :: generator call generator%reshuffle_list%reset () end subroutine radiation_generator_reset_reshuffle_list @ %def radiation_generator_reset_reshuffle_list @ <>= procedure :: set_n => radiation_generator_set_n <>= subroutine radiation_generator_set_n (generator, n_in, n_out, n_loops) class(radiation_generator_t), intent(inout) :: generator integer, intent(in) :: n_in, n_out, n_loops generator%n_tot = n_in + n_out + 1 generator%n_in = n_in generator%n_out = n_out generator%n_loops = n_loops end subroutine radiation_generator_set_n @ %def radiation_generator_set_n @ <>= procedure :: set_constraints => radiation_generator_set_constraints <>= subroutine radiation_generator_set_constraints & (generator, set_n_loop, set_mass_sum, & set_selected_particles, set_required_particles) class(radiation_generator_t), intent(inout), target :: generator logical, intent(in) :: set_n_loop logical, intent(in) :: set_mass_sum logical, intent(in) :: set_selected_particles logical, intent(in) :: set_required_particles logical :: set_no_photon_induced = .true. integer :: i, j, n, n_constraints type(pdg_list_t) :: pl_req, pl_insert type(pdg_list_t) :: pl_antiparticles type(pdg_array_t) :: pdg_gluon, pdg_photon type(pdg_array_t) :: pdg_add, pdg_tmp integer :: last_index integer :: n_new_particles, n_skip integer, dimension(:), allocatable :: i_skip integer :: n_nlo_correction_types n_nlo_correction_types = count ([generator%qcd_enabled, generator%qed_enabled]) if (generator%is_photon) set_no_photon_induced = .false. allocate (i_skip (generator%n_tot)) i_skip = -1 n_constraints = 2 + count([set_n_loop, set_mass_sum, & set_selected_particles, set_required_particles, set_no_photon_induced]) associate (constraints => generator%constraints) n = 1 call constraints%init (n_constraints) call constraints%set (n, constrain_n_tot (generator%n_tot)) n = 2 call constraints%set (n, constrain_couplings (generator%qcd_enabled, & generator%qed_enabled, n_nlo_correction_types)) n = n + 1 if (set_no_photon_induced) then call constraints%set (n, constrain_photon_induced_processes (generator%n_in)) n = n + 1 end if if (set_n_loop) then call constraints%set (n, constrain_n_loop(generator%n_loops)) n = n + 1 end if if (set_mass_sum) then call constraints%set (n, constrain_mass_sum(generator%mass_sum)) n = n + 1 end if if (set_required_particles) then if (generator%fs_gluon .or. generator%fs_photon) then do i = 1, generator%n_out pdg_tmp = generator%pl_out%get(i) if (pdg_tmp%search_for_particle (GLUON) & .or. pdg_tmp%search_for_particle (PHOTON)) then i_skip(i) = i end if end do n_skip = count (i_skip > 0) call pl_req%init (generator%n_out-n_skip) else call pl_req%init (generator%n_out) end if j = 1 do i = 1, generator%n_out if (any (i == i_skip)) cycle call pl_req%set (j, generator%pl_out%get(i)) j = j + 1 end do call constraints%set (n, constrain_require (pl_req)) n = n + 1 end if if (set_selected_particles) then if (generator%only_final_state ) then call pl_insert%init (generator%n_out + n_nlo_correction_types) do i = 1, generator%n_out call pl_insert%set(i, generator%pl_out%get(i)) end do last_index = generator%n_out + 1 else call generator%pl_in%create_antiparticles (pl_antiparticles, n_new_particles) call pl_insert%init (generator%n_tot + n_new_particles & + n_nlo_correction_types) do i = 1, generator%n_in call pl_insert%set(i, generator%pl_in%get(i)) end do do i = 1, generator%n_out j = i + generator%n_in call pl_insert%set(j, generator%pl_out%get(i)) end do do i = 1, n_new_particles j = i + generator%n_in + generator%n_out call pl_insert%set(j, pl_antiparticles%get(i)) end do last_index = generator%n_tot + n_new_particles + 1 end if pdg_gluon = GLUON; pdg_photon = PHOTON if (generator%qcd_enabled) then pdg_add = pdg_gluon call pl_insert%set (last_index, pdg_add) last_index = last_index + 1 end if if (generator%qed_enabled) then pdg_add = pdg_photon call pl_insert%set (last_index, pdg_add) end if call constraints%set (n, constrain_splittings (pl_insert, & generator%pl_excluded_gauge_splittings)) end if end associate end subroutine radiation_generator_set_constraints @ %def radiation_generator_set_constraints @ <>= procedure :: find_splittings => radiation_generator_find_splittings <>= subroutine radiation_generator_find_splittings (generator) class(radiation_generator_t), intent(inout) :: generator integer :: i type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out, pdg_tmp integer, dimension(:), allocatable :: reshuffle_list call generator%pl_in%create_pdg_array (pdg_in) call generator%pl_out%create_pdg_array (pdg_out) associate (if_table => generator%if_table) call if_table%radiate (generator%constraints, do_not_check_regular = .true.) do i = 1, if_table%get_length () call if_table%get_pdg_out (i, pdg_tmp) if (size (pdg_tmp) == generator%n_tot) then call pdg_reshuffle (pdg_out, pdg_tmp, reshuffle_list) call generator%reshuffle_list%append (reshuffle_list) end if end do end associate contains subroutine pdg_reshuffle (pdg_born, pdg_real, list) type(pdg_array_t), intent(in), dimension(:) :: pdg_born, pdg_real integer, intent(out), dimension(:), allocatable :: list type(pdg_sorter_t), dimension(:), allocatable :: sort_born type(pdg_sorter_t), dimension(:), allocatable :: sort_real integer :: i_min, n_in, n_born, n_real integer :: ib, ir n_in = generator%n_in n_born = size (pdg_born) n_real = size (pdg_real) allocate (list (n_real - n_in)) allocate (sort_born (n_born)) allocate (sort_real (n_real - n_in)) sort_born%pdg = pdg_born%get () sort_real%pdg = pdg_real(n_in + 1 : n_real)%get() do ib = 1, n_born if (any (sort_born(ib)%pdg == sort_real%pdg)) & call associate_born_indices (sort_born(ib), sort_real, ib, n_real) end do i_min = maxval (sort_real%associated_born) + 1 do ir = 1, n_real - n_in if (sort_real(ir)%associated_born == 0) then sort_real(ir)%associated_born = i_min i_min = i_min + 1 end if end do list = sort_real%associated_born end subroutine pdg_reshuffle subroutine associate_born_indices (sort_born, sort_real, ib, n_real) type(pdg_sorter_t), intent(in) :: sort_born type(pdg_sorter_t), intent(inout), dimension(:) :: sort_real integer, intent(in) :: ib, n_real integer :: ir do ir = 1, n_real - generator%n_in if (sort_born%pdg == sort_real(ir)%pdg & .and..not. sort_real(ir)%checked) then sort_real(ir)%associated_born = ib sort_real(ir)%checked = .true. exit end if end do end subroutine associate_born_indices end subroutine radiation_generator_find_splittings @ %def radiation_generator_find_splittings @ <>= procedure :: generate_real_particle_strings & => radiation_generator_generate_real_particle_strings <>= subroutine radiation_generator_generate_real_particle_strings & (generator, prt_tot_in, prt_tot_out) type :: prt_array_t type(string_t), dimension(:), allocatable :: prt end type class(radiation_generator_t), intent(inout) :: generator type(string_t), intent(out), dimension(:), allocatable :: prt_tot_in, prt_tot_out type(prt_array_t), dimension(:), allocatable :: prt_in, prt_out type(prt_array_t), dimension(:), allocatable :: prt_out0, prt_in0 type(pdg_array_t), dimension(:), allocatable :: pdg_tmp, pdg_out, pdg_in type(pdg_list_t), dimension(:), allocatable :: pl_in, pl_out type(prt_array_t) :: prt_out0_tmp, prt_in0_tmp integer :: i, j integer, dimension(:), allocatable :: reshuffle_list_local type(reshuffle_list_t) :: reshuffle_list integer :: flv type(string_t), dimension(:), allocatable :: buf integer :: i_buf flv = 0 allocate (prt_in0(0), prt_out0(0)) associate (if_table => generator%if_table) do i = 1, if_table%get_length () call if_table%get_pdg_out (i, pdg_tmp) if (size (pdg_tmp) == generator%n_tot) then call if_table%get_particle_string (i, & prt_in0_tmp%prt, prt_out0_tmp%prt) prt_in0 = [prt_in0, prt_in0_tmp] prt_out0 = [prt_out0, prt_out0_tmp] flv = flv + 1 end if end do end associate allocate (prt_in(size (prt_in0)), prt_out(size (prt_out0))) do i = 1, flv allocate (prt_in(i)%prt (generator%n_in)) allocate (prt_out(i)%prt (generator%n_tot - generator%n_in)) end do allocate (prt_tot_in (generator%n_in)) allocate (prt_tot_out (generator%n_tot - generator%n_in)) allocate (buf (generator%n_tot)) buf = "" do j = 1, flv do i = 1, generator%n_in prt_in(j)%prt(i) = prt_in0(j)%prt(i) call fill_buffer (buf(i), prt_in0(j)%prt(i)) end do end do prt_tot_in = buf(1 : generator%n_in) do j = 1, flv allocate (reshuffle_list_local (size (generator%reshuffle_list%get(j)))) reshuffle_list_local = generator%reshuffle_list%get(j) do i = 1, size (reshuffle_list_local) prt_out(j)%prt(reshuffle_list_local(i)) = prt_out0(j)%prt(i) i_buf = reshuffle_list_local(i) + generator%n_in call fill_buffer (buf(i_buf), & prt_out(j)%prt(reshuffle_list_local(i))) end do !!! Need to deallocate here because in the next iteration the reshuffling !!! list can have a different size deallocate (reshuffle_list_local) end do prt_tot_out = buf(generator%n_in + 1 : generator%n_tot) if (debug2_active (D_CORE)) then print *, 'Generated initial state: ' do i = 1, size (prt_tot_in) print *, char (prt_tot_in(i)) end do print *, 'Generated final state: ' do i = 1, size (prt_tot_out) print *, char (prt_tot_out(i)) end do end if contains subroutine fill_buffer (buffer, particle) type(string_t), intent(inout) :: buffer type(string_t), intent(in) :: particle logical :: particle_present if (len (buffer) > 0) then particle_present = check_for_substring (char(buffer), particle) if (.not. particle_present) buffer = buffer // ":" // particle else buffer = buffer // particle end if end subroutine fill_buffer function check_for_substring (buffer, substring) result (exist) character(len=*), intent(in) :: buffer type(string_t), intent(in) :: substring character(len=50) :: buffer_internal logical :: exist integer :: i_first, i_last exist = .false. i_first = 1; i_last = 1 do if (buffer(i_last:i_last) == ":") then buffer_internal = buffer (i_first : i_last - 1) if (buffer_internal == char (substring)) then exist = .true. exit end if i_first = i_last + 1; i_last = i_first + 1 if (i_last > len(buffer)) exit else if (i_last == len(buffer)) then buffer_internal = buffer (i_first : i_last) exist = buffer_internal == char (substring) exit else i_last = i_last + 1 if (i_last > len(buffer)) exit end if end do end function check_for_substring end subroutine radiation_generator_generate_real_particle_strings @ %def radiation_generator_generate_real_particle_strings @ <>= procedure :: contains_emissions => radiation_generator_contains_emissions <>= function radiation_generator_contains_emissions (generator) result (has_em) logical :: has_em class(radiation_generator_t), intent(in) :: generator has_em = .not. generator%reshuffle_list%is_empty () end function radiation_generator_contains_emissions @ %def radiation_generator_contains_emissions @ <>= procedure :: generate => radiation_generator_generate <>= subroutine radiation_generator_generate (generator, prt_in, prt_out) class(radiation_generator_t), intent(inout) :: generator type(string_t), intent(out), dimension(:), allocatable :: prt_in, prt_out call generator%find_splittings () call generator%generate_real_particle_strings (prt_in, prt_out) end subroutine radiation_generator_generate @ %def radiation_generator_generate @ <>= procedure :: generate_multiple => radiation_generator_generate_multiple <>= subroutine radiation_generator_generate_multiple (generator, max_multiplicity, model) class(radiation_generator_t), intent(inout) :: generator integer, intent(in) :: max_multiplicity class(model_data_t), intent(in), target :: model if (max_multiplicity <= generator%n_out) & call msg_fatal ("GKS states: Multiplicity is not large enough!") call generator%first_emission (model) call generator%reset_reshuffle_list () if (max_multiplicity - generator%n_out > 1) & call generator%append_emissions (max_multiplicity, model) end subroutine radiation_generator_generate_multiple @ %def radiation_generator_generate_multiple @ <>= procedure :: first_emission => radiation_generator_first_emission <>= subroutine radiation_generator_first_emission (generator, model) class(radiation_generator_t), intent(inout) :: generator class(model_data_t), intent(in), target :: model type(string_t), dimension(:), allocatable :: prt_in, prt_out call generator%setup_if_table (model) call generator%generate (prt_in, prt_out) call generator%prt_queue%null () call generator%prt_queue%append (prt_out) end subroutine radiation_generator_first_emission @ %def radiation_generator_first_emission @ <>= procedure :: append_emissions => radiation_generator_append_emissions <>= subroutine radiation_generator_append_emissions (generator, max_multiplicity, model) class(radiation_generator_t), intent(inout) :: generator integer, intent(in) :: max_multiplicity class(model_data_t), intent(in), target :: model type(string_t), dimension(:), allocatable :: prt_fetched type(string_t), dimension(:), allocatable :: prt_in type(string_t), dimension(:), allocatable :: prt_out type(pdg_array_t), dimension(:), allocatable :: pdg_new_out integer :: current_multiplicity, i, j, n_longest_length type :: prt_table_t type(string_t), dimension(:), allocatable :: prt end type prt_table_t type(prt_table_t), dimension(:), allocatable :: prt_table_out do call generator%prt_queue%get (prt_fetched) current_multiplicity = size (prt_fetched) if (current_multiplicity == max_multiplicity) exit call create_pdg_array (prt_fetched, model, & pdg_new_out) call generator%reset_particle_content (pdg_new_out) call generator%set_n (2, current_multiplicity, 0) call generator%set_constraints (.false., .false., .true., .true.) call generator%setup_if_table (model) call generator%generate (prt_in, prt_out) n_longest_length = get_length_of_longest_tuple (prt_out) call separate_particles (prt_out, prt_table_out) do i = 1, n_longest_length if (.not. any (prt_table_out(i)%prt == " ")) then call sort_prt (prt_table_out(i)%prt, model) if (.not. generator%prt_queue%contains (prt_table_out(i)%prt)) then call generator%prt_queue%append (prt_table_out(i)%prt) end if end if end do call generator%reset_reshuffle_list () end do contains subroutine separate_particles (prt, prt_table) type(string_t), intent(in), dimension(:) :: prt type(string_t), dimension(:), allocatable :: prt_tmp type(prt_table_t), intent(out), dimension(:), allocatable :: prt_table integer :: i, j logical, dimension(:), allocatable :: tuples_occured allocate (prt_table (n_longest_length)) do i = 1, n_longest_length allocate (prt_table(i)%prt (size (prt))) end do allocate (tuples_occured (size (prt))) do j = 1, size (prt) call split_string (prt(j), var_str (":"), prt_tmp) do i = 1, n_longest_length if (i <= size (prt_tmp)) then prt_table(i)%prt(j) = prt_tmp(i) else prt_table(i)%prt(j) = " " end if end do if (n_longest_length > 1) & tuples_occured(j) = prt_table(1)%prt(j) /= " " & .and. prt_table(2)%prt(j) /= " " end do if (any (tuples_occured)) then do j = 1, size (tuples_occured) if (.not. tuples_occured(j)) then do i = 2, n_longest_length prt_table(i)%prt(j) = prt_table(1)%prt(j) end do end if end do end if end subroutine separate_particles function get_length_of_longest_tuple (prt) result (longest_length) type(string_t), intent(in), dimension(:) :: prt integer :: longest_length, i type(prt_table_t), dimension(:), allocatable :: prt_table allocate (prt_table (size (prt))) longest_length = 0 do i = 1, size (prt) call split_string (prt(i), var_str (":"), prt_table(i)%prt) if (size (prt_table(i)%prt) > longest_length) & longest_length = size (prt_table(i)%prt) end do end function get_length_of_longest_tuple end subroutine radiation_generator_append_emissions @ %def radiation_generator_append_emissions @ <>= procedure :: reset_queue => radiation_generator_reset_queue <>= subroutine radiation_generator_reset_queue (generator) class(radiation_generator_t), intent(inout) :: generator call generator%prt_queue%reset () end subroutine radiation_generator_reset_queue @ %def radiation_generator_reset_queue @ <>= procedure :: get_n_gks_states => radiation_generator_get_n_gks_states <>= function radiation_generator_get_n_gks_states (generator) result (n) class(radiation_generator_t), intent(in) :: generator integer :: n n = generator%prt_queue%n_lists end function radiation_generator_get_n_gks_states @ %def radiation_generator_get_n_fks_states @ <>= procedure :: get_next_state => radiation_generator_get_next_state <>= function radiation_generator_get_next_state (generator) result (prt_string) class(radiation_generator_t), intent(inout) :: generator type(string_t), dimension(:), allocatable :: prt_string call generator%prt_queue%get (prt_string) end function radiation_generator_get_next_state @ %def radiation_generator_get_next_state @ <>= procedure :: get_emitter_indices => radiation_generator_get_emitter_indices <>= subroutine radiation_generator_get_emitter_indices (generator, indices) class(radiation_generator_t), intent(in) :: generator integer, dimension(:), allocatable, intent(out) :: indices type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out integer, dimension(:), allocatable :: flv_in, flv_out integer, dimension(:), allocatable :: emitters integer :: i, j integer :: n_in, n_out call generator%pl_in%create_pdg_array (pdg_in) call generator%pl_out%create_pdg_array (pdg_out) n_in = size (pdg_in); n_out = size (pdg_out) allocate (flv_in (n_in), flv_out (n_out)) forall (i=1:n_in) flv_in(i) = pdg_in(i)%get() forall (i=1:n_out) flv_out(i) = pdg_out(i)%get() call generator%if_table%get_emitters (generator%constraints, emitters) allocate (indices (size (emitters))) j = 1 do i = 1, n_in + n_out if (i <= n_in) then if (any (flv_in(i) == emitters)) then indices (j) = i j = j + 1 end if else if (any (flv_out(i-n_in) == emitters)) then indices (j) = i j = j + 1 end if end if end do end subroutine radiation_generator_get_emitter_indices @ %def radiation_generator_get_emitter_indices @ <>= procedure :: get_raw_states => radiation_generator_get_raw_states <>= function radiation_generator_get_raw_states (generator) result (raw_states) class(radiation_generator_t), intent(in), target :: generator integer, dimension(:,:), allocatable :: raw_states type(pdg_states_t), pointer :: state integer :: n_states, n_particles integer :: i_state integer :: j state => generator%pdg_raw n_states = generator%pdg_raw%get_n_states () n_particles = size (generator%pdg_raw%pdg) allocate (raw_states (n_particles, n_states)) do i_state = 1, n_states do j = 1, n_particles raw_states (j, i_state) = state%pdg(j)%get () end do state => state%next end do end function radiation_generator_get_raw_states @ %def radiation_generator_get_raw_states @ <>= procedure :: save_born_raw => radiation_generator_save_born_raw <>= subroutine radiation_generator_save_born_raw (generator, pdg_in, pdg_out) class(radiation_generator_t), intent(inout) :: generator type(pdg_array_t), dimension(:), allocatable, intent(in) :: pdg_in, pdg_out generator%pdg_in_born = pdg_in generator%pdg_out_born = pdg_out end subroutine radiation_generator_save_born_raw @ %def radiation_generator_save_born_raw @ <>= procedure :: get_born_raw => radiation_generator_get_born_raw <>= function radiation_generator_get_born_raw (generator) result (flv_born) class(radiation_generator_t), intent(in) :: generator integer, dimension(:,:), allocatable :: flv_born integer :: i_part, n_particles n_particles = size (generator%pdg_in_born) + size (generator%pdg_out_born) allocate (flv_born (n_particles, 1)) flv_born(1,1) = generator%pdg_in_born(1)%get () flv_born(2,1) = generator%pdg_in_born(2)%get () do i_part = 3, n_particles flv_born(i_part, 1) = generator%pdg_out_born(i_part-2)%get () end do end function radiation_generator_get_born_raw @ %def radiation_generator_get_born_raw @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[radiation_generator_ut.f90]]>>= <> module radiation_generator_ut use unit_tests use radiation_generator_uti <> <> contains <> end module radiation_generator_ut @ %def radiation_generator_ut @ <<[[radiation_generator_uti.f90]]>>= <> module radiation_generator_uti <> use format_utils, only: write_separator use os_interface use pdg_arrays use models use kinds, only: default use radiation_generator <> <> contains <> <> end module radiation_generator_uti @ %def radiation_generator_ut @ API: driver for the unit tests below. <>= public :: radiation_generator_test <>= subroutine radiation_generator_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results call test(radiation_generator_1, "radiation_generator_1", & "Test the generator of N+1-particle flavor structures in QCD", & u, results) call test(radiation_generator_2, "radiation_generator_2", & "Test multiple splittings in QCD", & u, results) call test(radiation_generator_3, "radiation_generator_3", & "Test the generator of N+1-particle flavor structures in QED", & u, results) call test(radiation_generator_4, "radiation_generator_4", & "Test multiple splittings in QED", & u, results) end subroutine radiation_generator_test @ %def radiation_generator_test @ <>= public :: radiation_generator_1 <>= subroutine radiation_generator_1 (u) integer, intent(in) :: u type(radiation_generator_t) :: generator type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out type(os_data_t) :: os_data type(model_list_t) :: model_list type(model_t), pointer :: model => null () write (u, "(A)") "* Test output: radiation_generator_1" write (u, "(A)") "* Purpose: Create N+1-particle flavor structures & &from predefined N-particle flavor structures" write (u, "(A)") "* One additional strong coupling, no additional electroweak coupling" write (u, "(A)") write (u, "(A)") "* Loading radiation model: SM.mdl" call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Success" allocate (pdg_in (2)) pdg_in(1) = 11; pdg_in(2) = -11 write (u, "(A)") "* Start checking processes" call write_separator (u) write (u, "(A)") "* Process 1: Top pair-production with additional gluon" allocate (pdg_out(3)) pdg_out(1) = 6; pdg_out(2) = -6; pdg_out(3) = 21 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 2: Top pair-production with additional jet" allocate (pdg_out(3)) pdg_out(1) = 6; pdg_out(2) = -6; pdg_out(3) = [-1,1,-2,2,-3,3,-4,4,-5,5,21] call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 3: Quark-antiquark production" allocate (pdg_out(2)) pdg_out(1) = 2; pdg_out(2) = -2 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 4: Quark-antiquark production with additional gluon" allocate (pdg_out(3)) pdg_out(1) = 2; pdg_out(2) = -2; pdg_out(3) = 21 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 5: Z + jets" allocate (pdg_out(3)) pdg_out(1) = 2; pdg_out(2) = -2; pdg_out(3) = 23 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 6: Top Decay" allocate (pdg_out(4)) pdg_out(1) = 24; pdg_out(2) = -24 pdg_out(3) = 5; pdg_out(4) = -5 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 7: Production of four quarks" allocate (pdg_out(4)) pdg_out(1) = 2; pdg_out(2) = -2; pdg_out(3) = 2; pdg_out(4) = -2 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out); deallocate (pdg_in) write (u, "(A)") "* Process 8: Drell-Yan lepto-production" allocate (pdg_in (2)); allocate (pdg_out (2)) pdg_in(1) = 2; pdg_in(2) = -2 pdg_out(1) = 11; pdg_out(2) = -11 call test_process (generator, pdg_in, pdg_out, u, .true.) deallocate (pdg_out); deallocate (pdg_in) write (u, "(A)") "* Process 9: WZ production at hadron-colliders" allocate (pdg_in (2)); allocate (pdg_out (2)) pdg_in(1) = 1; pdg_in(2) = -2 pdg_out(1) = -24; pdg_out(2) = 23 call test_process (generator, pdg_in, pdg_out, u, .true.) deallocate (pdg_out); deallocate (pdg_in) contains subroutine test_process (generator, pdg_in, pdg_out, u, include_initial_state) type(radiation_generator_t), intent(inout) :: generator type(pdg_array_t), dimension(:), intent(in) :: pdg_in, pdg_out integer, intent(in) :: u logical, intent(in), optional :: include_initial_state type(string_t), dimension(:), allocatable :: prt_strings_in type(string_t), dimension(:), allocatable :: prt_strings_out type(pdg_array_t), dimension(10) :: pdg_excluded logical :: yorn yorn = .false. pdg_excluded = [-4, 4, 5, -5, 6, -6, 13, -13, 15, -15] if (present (include_initial_state)) yorn = include_initial_state write (u, "(A)") "* Leading order: " write (u, "(A)", advance = 'no') '* Incoming: ' call write_pdg_array (pdg_in, u) write (u, "(A)", advance = 'no') '* Outgoing: ' call write_pdg_array (pdg_out, u) call generator%init (pdg_in, pdg_out, & pdg_excluded_gauge_splittings = pdg_excluded, qcd = .true., qed = .false.) call generator%set_n (2, size(pdg_out), 0) if (yorn) call generator%set_initial_state_emissions () call generator%set_constraints (.false., .false., .true., .true.) call generator%setup_if_table (model) call generator%generate (prt_strings_in, prt_strings_out) write (u, "(A)") "* Additional radiation: " write (u, "(A)") "* Incoming: " call write_particle_string (prt_strings_in, u) write (u, "(A)") "* Outgoing: " call write_particle_string (prt_strings_out, u) call write_separator(u) call generator%reset_reshuffle_list () end subroutine test_process end subroutine radiation_generator_1 @ %def radiation_generator_1 @ <>= public :: radiation_generator_2 <>= subroutine radiation_generator_2 (u) integer, intent(in) :: u type(radiation_generator_t) :: generator type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out type(pdg_array_t), dimension(:), allocatable :: pdg_excluded type(os_data_t) :: os_data type(model_list_t) :: model_list type(model_t), pointer :: model => null () integer, parameter :: max_multiplicity = 10 type(string_t), dimension(:), allocatable :: prt_last write (u, "(A)") "* Test output: radiation_generator_2" write (u, "(A)") "* Purpose: Test the repeated application of & &a radiation generator splitting in QCD" write (u, "(A)") "* Only Final state emissions! " write (u, "(A)") write (u, "(A)") "* Loading radiation model: SM.mdl" call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Success" allocate (pdg_in (2)) pdg_in(1) = 11; pdg_in(2) = -11 allocate (pdg_out(2)) pdg_out(1) = 2; pdg_out(2) = -2 allocate (pdg_excluded (10)) pdg_excluded = [-4, 4, 5, -5, 6, -6, 13, -13, 15, -15] write (u, "(A)") "* Leading order" write (u, "(A)", advance = 'no') "* Incoming: " call write_pdg_array (pdg_in, u) write (u, "(A)", advance = 'no') "* Outgoing: " call write_pdg_array (pdg_out, u) call generator%init (pdg_in, pdg_out, & pdg_excluded_gauge_splittings = pdg_excluded, qcd = .true., qed = .false.) call generator%set_n (2, 2, 0) call generator%set_constraints (.false., .false., .true., .true.) call write_separator (u) write (u, "(A)") "Generate higher-multiplicity states" write (u, "(A,I0)") "Desired multiplicity: ", max_multiplicity call generator%generate_multiple (max_multiplicity, model) call generator%prt_queue%write (u) call write_separator (u) write (u, "(A,I0)") "Number of higher-multiplicity states: ", generator%prt_queue%n_lists write (u, "(A)") "Check that no particle state occurs twice or more" if (.not. generator%prt_queue%check_for_same_prt_strings()) then write (u, "(A)") "SUCCESS" else write (u, "(A)") "FAIL" end if call write_separator (u) write (u, "(A,I0,A)") "Check that there are ", max_multiplicity, " particles in the last entry:" call generator%prt_queue%get_last (prt_last) if (size (prt_last) == max_multiplicity) then write (u, "(A)") "SUCCESS" else write (u, "(A)") "FAIL" end if end subroutine radiation_generator_2 @ %def radiation_generator_2 @ <>= public :: radiation_generator_3 <>= subroutine radiation_generator_3 (u) integer, intent(in) :: u type(radiation_generator_t) :: generator type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out type(os_data_t) :: os_data type(model_list_t) :: model_list type(model_t), pointer :: model => null () write (u, "(A)") "* Test output: radiation_generator_3" write (u, "(A)") "* Purpose: Create N+1-particle flavor structures & &from predefined N-particle flavor structures" write (u, "(A)") "* One additional electroweak coupling, no additional strong coupling" write (u, "(A)") write (u, "(A)") "* Loading radiation model: SM.mdl" call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Success" allocate (pdg_in (2)) pdg_in(1) = 11; pdg_in(2) = -11 write (u, "(A)") "* Start checking processes" call write_separator (u) write (u, "(A)") "* Process 1: Tau pair-production with additional photon" allocate (pdg_out(3)) pdg_out(1) = 15; pdg_out(2) = -15; pdg_out(3) = 22 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 2: Tau pair-production with additional leptons or photon" allocate (pdg_out(3)) pdg_out(1) = 15; pdg_out(2) = -15; pdg_out(3) = [-13, 13, 22] call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 3: Electron-positron production" allocate (pdg_out(2)) pdg_out(1) = 11; pdg_out(2) = -11 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 4: Quark-antiquark production with additional photon" allocate (pdg_out(3)) pdg_out(1) = 2; pdg_out(2) = -2; pdg_out(3) = 22 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 5: Z + jets " allocate (pdg_out(3)) pdg_out(1) = 2; pdg_out(2) = -2; pdg_out(3) = 23 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 6: W + jets" allocate (pdg_out(3)) pdg_out(1) = 1; pdg_out(2) = -2; pdg_out(3) = -24 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 7: Top Decay" allocate (pdg_out(4)) pdg_out(1) = 24; pdg_out(2) = -24 pdg_out(3) = 5; pdg_out(4) = -5 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 8: Production of four quarks" allocate (pdg_out(4)) pdg_out(1) = 2; pdg_out(2) = -2; pdg_out(3) = 2; pdg_out(4) = -2 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 9: Neutrino pair-production" allocate (pdg_out(2)) pdg_out(1) = 12; pdg_out(2) = -12 call test_process (generator, pdg_in, pdg_out, u, .true.) deallocate (pdg_out); deallocate (pdg_in) write (u, "(A)") "* Process 10: Drell-Yan lepto-production" allocate (pdg_in (2)); allocate (pdg_out (2)) pdg_in(1) = 2; pdg_in(2) = -2 pdg_out(1) = 11; pdg_out(2) = -11 call test_process (generator, pdg_in, pdg_out, u, .true.) deallocate (pdg_out); deallocate (pdg_in) write (u, "(A)") "* Process 11: WZ production at hadron-colliders" allocate (pdg_in (2)); allocate (pdg_out (2)) pdg_in(1) = 1; pdg_in(2) = -2 pdg_out(1) = -24; pdg_out(2) = 23 call test_process (generator, pdg_in, pdg_out, u, .true.) deallocate (pdg_out); deallocate (pdg_in) write (u, "(A)") "* Process 12: Positron-neutrino production" allocate (pdg_in (2)); allocate (pdg_out (2)) pdg_in(1) = -1; pdg_in(2) = 2 pdg_out(1) = -11; pdg_out(2) = 12 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out); deallocate (pdg_in) contains subroutine test_process (generator, pdg_in, pdg_out, u, include_initial_state) type(radiation_generator_t), intent(inout) :: generator type(pdg_array_t), dimension(:), intent(in) :: pdg_in, pdg_out integer, intent(in) :: u logical, intent(in), optional :: include_initial_state type(string_t), dimension(:), allocatable :: prt_strings_in type(string_t), dimension(:), allocatable :: prt_strings_out type(pdg_array_t), dimension(10) :: pdg_excluded logical :: yorn yorn = .false. pdg_excluded = [-4, 4, 5, -5, 6, -6, 13, -13, 15, -15] if (present (include_initial_state)) yorn = include_initial_state write (u, "(A)") "* Leading order: " write (u, "(A)", advance = 'no') '* Incoming: ' call write_pdg_array (pdg_in, u) write (u, "(A)", advance = 'no') '* Outgoing: ' call write_pdg_array (pdg_out, u) call generator%init (pdg_in, pdg_out, & pdg_excluded_gauge_splittings = pdg_excluded, qcd = .false., qed = .true.) call generator%set_n (2, size(pdg_out), 0) if (yorn) call generator%set_initial_state_emissions () call generator%set_constraints (.false., .false., .true., .true.) call generator%setup_if_table (model) call generator%generate (prt_strings_in, prt_strings_out) write (u, "(A)") "* Additional radiation: " write (u, "(A)") "* Incoming: " call write_particle_string (prt_strings_in, u) write (u, "(A)") "* Outgoing: " call write_particle_string (prt_strings_out, u) call write_separator(u) call generator%reset_reshuffle_list () end subroutine test_process end subroutine radiation_generator_3 @ %def radiation_generator_3 @ <>= public :: radiation_generator_4 <>= subroutine radiation_generator_4 (u) integer, intent(in) :: u type(radiation_generator_t) :: generator type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out type(pdg_array_t), dimension(:), allocatable :: pdg_excluded type(os_data_t) :: os_data type(model_list_t) :: model_list type(model_t), pointer :: model => null () integer, parameter :: max_multiplicity = 10 type(string_t), dimension(:), allocatable :: prt_last write (u, "(A)") "* Test output: radiation_generator_4" write (u, "(A)") "* Purpose: Test the repeated application of & &a radiation generator splitting in QED" write (u, "(A)") "* Only Final state emissions! " write (u, "(A)") write (u, "(A)") "* Loading radiation model: SM.mdl" call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Success" allocate (pdg_in (2)) pdg_in(1) = 2; pdg_in(2) = -2 allocate (pdg_out(2)) pdg_out(1) = 11; pdg_out(2) = -11 allocate ( pdg_excluded (14)) pdg_excluded = [1, -1, 2, -2, 3, -3, 4, -4, 5, -5, 6, -6, 15, -15] write (u, "(A)") "* Leading order" write (u, "(A)", advance = 'no') "* Incoming: " call write_pdg_array (pdg_in, u) write (u, "(A)", advance = 'no') "* Outgoing: " call write_pdg_array (pdg_out, u) call generator%init (pdg_in, pdg_out, & pdg_excluded_gauge_splittings = pdg_excluded, qcd = .false., qed = .true.) call generator%set_n (2, 2, 0) call generator%set_constraints (.false., .false., .true., .true.) call write_separator (u) write (u, "(A)") "Generate higher-multiplicity states" write (u, "(A,I0)") "Desired multiplicity: ", max_multiplicity call generator%generate_multiple (max_multiplicity, model) call generator%prt_queue%write (u) call write_separator (u) write (u, "(A,I0)") "Number of higher-multiplicity states: ", generator%prt_queue%n_lists write (u, "(A)") "Check that no particle state occurs twice or more" if (.not. generator%prt_queue%check_for_same_prt_strings()) then write (u, "(A)") "SUCCESS" else write (u, "(A)") "FAIL" end if call write_separator (u) write (u, "(A,I0,A)") "Check that there are ", max_multiplicity, " particles in the last entry:" call generator%prt_queue%get_last (prt_last) if (size (prt_last) == max_multiplicity) then write (u, "(A)") "SUCCESS" else write (u, "(A)") "FAIL" end if end subroutine radiation_generator_4 @ %def radiation_generator_4 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Sindarin Expression Implementation} This module defines expressions of all kinds, represented in a tree structure, for repeated evaluation. This provides an implementation of the [[expr_base]] abstract type. We have two flavors of expressions: one with particles and one without particles. The latter version is used for defining cut/selection criteria and for online analysis. <<[[eval_trees.f90]]>>= <> module eval_trees use, intrinsic :: iso_c_binding !NODEP! <> <> use io_units use constants, only: DEGREE, IMAGO, PI use format_defs, only: FMT_19 use numeric_utils, only: nearly_equal use diagnostics use lorentz use md5 use formats use sorting use ifiles use lexers use syntax_rules use parser use analysis use jets use pdg_arrays use subevents use var_base use expr_base use variables use observables <> <> <> <> <> contains <> end module eval_trees @ %def eval_trees @ \subsection{Tree nodes} The evaluation tree consists of branch nodes (unary and binary) and of leaf nodes, originating from a common root. The node object should be polymorphic. For the time being, polymorphism is emulated here. This means that we have to maintain all possibilities that the node may hold, including associated procedures as pointers. The following parameter values characterize the node. Unary and binary operators have sub-nodes. The other are leaf nodes. Possible leafs are literal constants or named-parameter references. <>= integer, parameter :: EN_UNKNOWN = 0, EN_UNARY = 1, EN_BINARY = 2 integer, parameter :: EN_CONSTANT = 3, EN_VARIABLE = 4 integer, parameter :: EN_CONDITIONAL = 5, EN_BLOCK = 6 integer, parameter :: EN_RECORD_CMD = 7 integer, parameter :: EN_OBS1_INT = 11, EN_OBS2_INT = 12 integer, parameter :: EN_OBSEV_INT = 13 integer, parameter :: EN_OBS1_REAL = 21, EN_OBS2_REAL = 22 integer, parameter :: EN_OBSEV_REAL = 23 integer, parameter :: EN_PRT_FUN_UNARY = 101, EN_PRT_FUN_BINARY = 102 integer, parameter :: EN_EVAL_FUN_UNARY = 111, EN_EVAL_FUN_BINARY = 112 integer, parameter :: EN_LOG_FUN_UNARY = 121, EN_LOG_FUN_BINARY = 122 integer, parameter :: EN_INT_FUN_UNARY = 131, EN_INT_FUN_BINARY = 132 integer, parameter :: EN_REAL_FUN_UNARY = 141, EN_REAL_FUN_BINARY = 142 integer, parameter :: EN_REAL_FUN_CUM = 151 integer, parameter :: EN_FORMAT_STR = 161 @ %def EN_UNKNOWN EN_UNARY EN_BINARY EN_CONSTANT EN_VARIABLE EN_CONDITIONAL @ %def EN_RECORD_CMD @ %def EN_OBS1_INT EN_OBS2_INT EN_OBS1_REAL EN_OBS2_REAL EN_OBSEV_INT EN_OBSEV_REAL @ %def EN_PRT_FUN_UNARY EN_PRT_FUN_BINARY @ %def EN_EVAL_FUN_UNARY EN_EVAL_FUN_BINARY @ %def EN_LOG_FUN_UNARY EN_LOG_FUN_BINARY @ %def EN_INT_FUN_UNARY EN_INT_FUN_BINARY @ %def EN_REAL_FUN_UNARY EN_REAL_FUN_BINARY @ %def EN_REAL_FUN_CUM @ %def EN_FORMAT_STR @ This is exported only for use within unit tests. <>= public :: eval_node_t <>= type :: eval_node_t private type(string_t) :: tag integer :: type = EN_UNKNOWN integer :: result_type = V_NONE type(var_list_t), pointer :: var_list => null () type(string_t) :: var_name logical, pointer :: value_is_known => null () logical, pointer :: lval => null () integer, pointer :: ival => null () real(default), pointer :: rval => null () complex(default), pointer :: cval => null () type(subevt_t), pointer :: pval => null () type(pdg_array_t), pointer :: aval => null () type(string_t), pointer :: sval => null () type(eval_node_t), pointer :: arg0 => null () type(eval_node_t), pointer :: arg1 => null () type(eval_node_t), pointer :: arg2 => null () type(eval_node_t), pointer :: arg3 => null () type(eval_node_t), pointer :: arg4 => null () procedure(obs_unary_int), nopass, pointer :: obs1_int => null () procedure(obs_unary_real), nopass, pointer :: obs1_real => null () procedure(obs_binary_int), nopass, pointer :: obs2_int => null () procedure(obs_binary_real), nopass, pointer :: obs2_real => null () procedure(obs_sev_int), nopass, pointer :: obsev_int => null () procedure(obs_sev_real), nopass, pointer :: obsev_real => null () integer, pointer :: prt_type => null () integer, pointer :: index => null () real(default), pointer :: tolerance => null () integer, pointer :: jet_algorithm => null () real(default), pointer :: jet_r => null () real(default), pointer :: jet_p => null () real(default), pointer :: jet_ycut => null () real(default), pointer :: jet_dcut => null () real(default), pointer :: photon_iso_eps => null () real(default), pointer :: photon_iso_n => null () real(default), pointer :: photon_iso_r0 => null () real(default), pointer :: photon_rec_r0 => null () type(prt_t), pointer :: prt1 => null () type(prt_t), pointer :: prt2 => null () procedure(unary_log), nopass, pointer :: op1_log => null () procedure(unary_int), nopass, pointer :: op1_int => null () procedure(unary_real), nopass, pointer :: op1_real => null () procedure(unary_cmplx), nopass, pointer :: op1_cmplx => null () procedure(unary_pdg), nopass, pointer :: op1_pdg => null () procedure(unary_sev), nopass, pointer :: op1_sev => null () procedure(unary_str), nopass, pointer :: op1_str => null () procedure(unary_cut), nopass, pointer :: op1_cut => null () procedure(unary_evi), nopass, pointer :: op1_evi => null () procedure(unary_evr), nopass, pointer :: op1_evr => null () procedure(binary_log), nopass, pointer :: op2_log => null () procedure(binary_int), nopass, pointer :: op2_int => null () procedure(binary_real), nopass, pointer :: op2_real => null () procedure(binary_cmplx), nopass, pointer :: op2_cmplx => null () procedure(binary_pdg), nopass, pointer :: op2_pdg => null () procedure(binary_sev), nopass, pointer :: op2_sev => null () procedure(binary_str), nopass, pointer :: op2_str => null () procedure(binary_cut), nopass, pointer :: op2_cut => null () procedure(binary_evi), nopass, pointer :: op2_evi => null () procedure(binary_evr), nopass, pointer :: op2_evr => null () procedure(cum_evi), nopass, pointer :: opcum_evi => null () procedure(cum_evr), nopass, pointer :: opcum_evr => null () contains <> end type eval_node_t @ %def eval_node_t @ Finalize a node recursively. Allocated constants are deleted, pointers are ignored. <>= procedure :: final_rec => eval_node_final_rec <>= recursive subroutine eval_node_final_rec (node) class(eval_node_t), intent(inout) :: node select case (node%type) case (EN_UNARY) call eval_node_final_rec (node%arg1) case (EN_BINARY) call eval_node_final_rec (node%arg1) call eval_node_final_rec (node%arg2) case (EN_CONDITIONAL) call eval_node_final_rec (node%arg0) call eval_node_final_rec (node%arg1) call eval_node_final_rec (node%arg2) case (EN_BLOCK) call eval_node_final_rec (node%arg0) call eval_node_final_rec (node%arg1) case (EN_PRT_FUN_UNARY, EN_EVAL_FUN_UNARY, & EN_LOG_FUN_UNARY, EN_INT_FUN_UNARY, EN_REAL_FUN_UNARY) if (associated (node%arg0)) call eval_node_final_rec (node%arg0) call eval_node_final_rec (node%arg1) deallocate (node%index) deallocate (node%prt1) case (EN_REAL_FUN_CUM) if (associated (node%arg0)) call eval_node_final_rec (node%arg0) call eval_node_final_rec (node%arg1) deallocate (node%index) deallocate (node%prt1) case (EN_PRT_FUN_BINARY, EN_EVAL_FUN_BINARY, & EN_LOG_FUN_BINARY, EN_INT_FUN_BINARY, EN_REAL_FUN_BINARY) if (associated (node%arg0)) call eval_node_final_rec (node%arg0) call eval_node_final_rec (node%arg1) call eval_node_final_rec (node%arg2) deallocate (node%index) deallocate (node%prt1) deallocate (node%prt2) case (EN_FORMAT_STR) if (associated (node%arg0)) call eval_node_final_rec (node%arg0) if (associated (node%arg1)) call eval_node_final_rec (node%arg1) deallocate (node%ival) case (EN_RECORD_CMD) if (associated (node%arg0)) call eval_node_final_rec (node%arg0) if (associated (node%arg1)) call eval_node_final_rec (node%arg1) if (associated (node%arg2)) call eval_node_final_rec (node%arg2) if (associated (node%arg3)) call eval_node_final_rec (node%arg3) if (associated (node%arg4)) call eval_node_final_rec (node%arg4) end select select case (node%type) case (EN_UNARY, EN_BINARY, EN_CONDITIONAL, EN_CONSTANT, EN_BLOCK, & EN_PRT_FUN_UNARY, EN_PRT_FUN_BINARY, & EN_EVAL_FUN_UNARY, EN_EVAL_FUN_BINARY, & EN_LOG_FUN_UNARY, EN_LOG_FUN_BINARY, & EN_INT_FUN_UNARY, EN_INT_FUN_BINARY, & EN_REAL_FUN_UNARY, EN_REAL_FUN_BINARY, & EN_REAL_FUN_CUM, & EN_FORMAT_STR, EN_RECORD_CMD) select case (node%result_type) case (V_LOG); deallocate (node%lval) case (V_INT); deallocate (node%ival) case (V_REAL); deallocate (node%rval) case (V_CMPLX); deallocate (node%cval) case (V_SEV); deallocate (node%pval) case (V_PDG); deallocate (node%aval) case (V_STR); deallocate (node%sval) end select deallocate (node%value_is_known) end select end subroutine eval_node_final_rec @ %def eval_node_final_rec @ \subsubsection{Leaf nodes} Initialize a leaf node with a literal constant. <>= subroutine eval_node_init_log (node, lval) type(eval_node_t), intent(out) :: node logical, intent(in) :: lval node%type = EN_CONSTANT node%result_type = V_LOG allocate (node%lval, node%value_is_known) node%lval = lval node%value_is_known = .true. end subroutine eval_node_init_log subroutine eval_node_init_int (node, ival) type(eval_node_t), intent(out) :: node integer, intent(in) :: ival node%type = EN_CONSTANT node%result_type = V_INT allocate (node%ival, node%value_is_known) node%ival = ival node%value_is_known = .true. end subroutine eval_node_init_int subroutine eval_node_init_real (node, rval) type(eval_node_t), intent(out) :: node real(default), intent(in) :: rval node%type = EN_CONSTANT node%result_type = V_REAL allocate (node%rval, node%value_is_known) node%rval = rval node%value_is_known = .true. end subroutine eval_node_init_real subroutine eval_node_init_cmplx (node, cval) type(eval_node_t), intent(out) :: node complex(default), intent(in) :: cval node%type = EN_CONSTANT node%result_type = V_CMPLX allocate (node%cval, node%value_is_known) node%cval = cval node%value_is_known = .true. end subroutine eval_node_init_cmplx subroutine eval_node_init_subevt (node, pval) type(eval_node_t), intent(out) :: node type(subevt_t), intent(in) :: pval node%type = EN_CONSTANT node%result_type = V_SEV allocate (node%pval, node%value_is_known) node%pval = pval node%value_is_known = .true. end subroutine eval_node_init_subevt subroutine eval_node_init_pdg_array (node, aval) type(eval_node_t), intent(out) :: node type(pdg_array_t), intent(in) :: aval node%type = EN_CONSTANT node%result_type = V_PDG allocate (node%aval, node%value_is_known) node%aval = aval node%value_is_known = .true. end subroutine eval_node_init_pdg_array subroutine eval_node_init_string (node, sval) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: sval node%type = EN_CONSTANT node%result_type = V_STR allocate (node%sval, node%value_is_known) node%sval = sval node%value_is_known = .true. end subroutine eval_node_init_string @ %def eval_node_init_log eval_node_init_int eval_node_init_real @ %def eval_node_init_cmplx eval_node_init_prt eval_node_init_subevt @ %def eval_node_init_pdg_array eval_node_init_string @ Initialize a leaf node with a pointer to a named parameter <>= subroutine eval_node_init_log_ptr (node, name, lval, is_known) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name logical, intent(in), target :: lval logical, intent(in), target :: is_known node%type = EN_VARIABLE node%tag = name node%result_type = V_LOG node%lval => lval node%value_is_known => is_known end subroutine eval_node_init_log_ptr subroutine eval_node_init_int_ptr (node, name, ival, is_known) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name integer, intent(in), target :: ival logical, intent(in), target :: is_known node%type = EN_VARIABLE node%tag = name node%result_type = V_INT node%ival => ival node%value_is_known => is_known end subroutine eval_node_init_int_ptr subroutine eval_node_init_real_ptr (node, name, rval, is_known) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name real(default), intent(in), target :: rval logical, intent(in), target :: is_known node%type = EN_VARIABLE node%tag = name node%result_type = V_REAL node%rval => rval node%value_is_known => is_known end subroutine eval_node_init_real_ptr subroutine eval_node_init_cmplx_ptr (node, name, cval, is_known) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name complex(default), intent(in), target :: cval logical, intent(in), target :: is_known node%type = EN_VARIABLE node%tag = name node%result_type = V_CMPLX node%cval => cval node%value_is_known => is_known end subroutine eval_node_init_cmplx_ptr subroutine eval_node_init_subevt_ptr (node, name, pval, is_known) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name type(subevt_t), intent(in), target :: pval logical, intent(in), target :: is_known node%type = EN_VARIABLE node%tag = name node%result_type = V_SEV node%pval => pval node%value_is_known => is_known end subroutine eval_node_init_subevt_ptr subroutine eval_node_init_pdg_array_ptr (node, name, aval, is_known) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name type(pdg_array_t), intent(in), target :: aval logical, intent(in), target :: is_known node%type = EN_VARIABLE node%tag = name node%result_type = V_PDG node%aval => aval node%value_is_known => is_known end subroutine eval_node_init_pdg_array_ptr subroutine eval_node_init_string_ptr (node, name, sval, is_known) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name type(string_t), intent(in), target :: sval logical, intent(in), target :: is_known node%type = EN_VARIABLE node%tag = name node%result_type = V_STR node%sval => sval node%value_is_known => is_known end subroutine eval_node_init_string_ptr @ %def eval_node_init_log_ptr eval_node_init_int_ptr @ %def eval_node_init_real_ptr eval_node_init_cmplx_ptr @ %def eval_node_init_subevt_ptr eval_node_init_string_ptr @ The procedure-pointer cases: <>= subroutine eval_node_init_obs1_int_ptr (node, name, obs1_iptr, p1) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name procedure(obs_unary_int), intent(in), pointer :: obs1_iptr type(prt_t), intent(in), target :: p1 node%type = EN_OBS1_INT node%tag = name node%result_type = V_INT node%obs1_int => obs1_iptr node%prt1 => p1 allocate (node%ival, node%value_is_known) node%value_is_known = .false. end subroutine eval_node_init_obs1_int_ptr subroutine eval_node_init_obs2_int_ptr (node, name, obs2_iptr, p1, p2) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name procedure(obs_binary_int), intent(in), pointer :: obs2_iptr type(prt_t), intent(in), target :: p1, p2 node%type = EN_OBS2_INT node%tag = name node%result_type = V_INT node%obs2_int => obs2_iptr node%prt1 => p1 node%prt2 => p2 allocate (node%ival, node%value_is_known) node%value_is_known = .false. end subroutine eval_node_init_obs2_int_ptr subroutine eval_node_init_obsev_int_ptr (node, name, obsev_iptr, pval) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name procedure(obs_sev_int), intent(in), pointer :: obsev_iptr type(subevt_t), intent(in), target :: pval node%type = EN_OBSEV_INT node%tag = name node%result_type = V_INT node%obsev_int => obsev_iptr node%pval => pval allocate (node%rval, node%value_is_known) node%value_is_known = .false. end subroutine eval_node_init_obsev_int_ptr subroutine eval_node_init_obs1_real_ptr (node, name, obs1_rptr, p1) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name procedure(obs_unary_real), intent(in), pointer :: obs1_rptr type(prt_t), intent(in), target :: p1 node%type = EN_OBS1_REAL node%tag = name node%result_type = V_REAL node%obs1_real => obs1_rptr node%prt1 => p1 allocate (node%rval, node%value_is_known) node%value_is_known = .false. end subroutine eval_node_init_obs1_real_ptr subroutine eval_node_init_obs2_real_ptr (node, name, obs2_rptr, p1, p2) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name procedure(obs_binary_real), intent(in), pointer :: obs2_rptr type(prt_t), intent(in), target :: p1, p2 node%type = EN_OBS2_REAL node%tag = name node%result_type = V_REAL node%obs2_real => obs2_rptr node%prt1 => p1 node%prt2 => p2 allocate (node%rval, node%value_is_known) node%value_is_known = .false. end subroutine eval_node_init_obs2_real_ptr subroutine eval_node_init_obsev_real_ptr (node, name, obsev_rptr, pval) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name procedure(obs_sev_real), intent(in), pointer :: obsev_rptr type(subevt_t), intent(in), target :: pval node%type = EN_OBSEV_REAL node%tag = name node%result_type = V_REAL node%obsev_real => obsev_rptr node%pval => pval allocate (node%rval, node%value_is_known) node%value_is_known = .false. end subroutine eval_node_init_obsev_real_ptr @ %def eval_node_init_obs1_int_ptr @ %def eval_node_init_obs2_int_ptr @ %def eval_node_init_obs1_real_ptr @ %def eval_node_init_obs2_real_ptr @ %def eval_node_init_obsev_int_ptr @ %def eval_node_init_obsev_real_ptr @ \subsubsection{Branch nodes} Initialize a branch node, sub-nodes are given. <>= subroutine eval_node_init_branch (node, tag, result_type, arg1, arg2) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: tag integer, intent(in) :: result_type type(eval_node_t), intent(in), target :: arg1 type(eval_node_t), intent(in), target, optional :: arg2 if (present (arg2)) then node%type = EN_BINARY else node%type = EN_UNARY end if node%tag = tag node%result_type = result_type call eval_node_allocate_value (node) node%arg1 => arg1 if (present (arg2)) node%arg2 => arg2 end subroutine eval_node_init_branch @ %def eval_node_init_branch @ Allocate the node value according to the result type. <>= subroutine eval_node_allocate_value (node) type(eval_node_t), intent(inout) :: node select case (node%result_type) case (V_LOG); allocate (node%lval) case (V_INT); allocate (node%ival) case (V_REAL); allocate (node%rval) case (V_CMPLX); allocate (node%cval) case (V_PDG); allocate (node%aval) case (V_SEV); allocate (node%pval) call subevt_init (node%pval) case (V_STR); allocate (node%sval) end select allocate (node%value_is_known) node%value_is_known = .false. end subroutine eval_node_allocate_value @ %def eval_node_allocate_value @ Initialize a block node which contains, in addition to the expression to be evaluated, a variable definition. The result type is not yet assigned, because we can compile the enclosed expression only after the var list is set up. Note that the node always allocates a new variable list and appends it to the current one. Thus, if the variable redefines an existing one, it only shadows it but does not reset it. Any side-effects are therefore absent and need not be undone outside the block. If the flag [[new]] is set, a variable is (re)declared. This must not be done for intrinsic variables. Vice versa, if the variable is not existent, the [[new]] flag is required. <>= subroutine eval_node_init_block (node, name, type, var_def, var_list) type(eval_node_t), intent(out), target :: node type(string_t), intent(in) :: name integer, intent(in) :: type type(eval_node_t), intent(in), target :: var_def type(var_list_t), intent(in), target :: var_list node%type = EN_BLOCK node%tag = "var_def" node%var_name = name node%arg1 => var_def allocate (node%var_list) call node%var_list%link (var_list) if (var_def%type == EN_CONSTANT) then select case (type) case (V_LOG) - call var_list_append_log (node%var_list, name, var_def%lval) + call node%var_list%append_log (name, var_def%lval) case (V_INT) - call var_list_append_int (node%var_list, name, var_def%ival) + call node%var_list%append_int (name, var_def%ival) case (V_REAL) - call var_list_append_real (node%var_list, name, var_def%rval) + call node%var_list%append_real (name, var_def%rval) case (V_CMPLX) - call var_list_append_cmplx (node%var_list, name, var_def%cval) + call node%var_list%append_cmplx (name, var_def%cval) case (V_PDG) - call var_list_append_pdg_array & - (node%var_list, name, var_def%aval) + call node%var_list%append_pdg_array (name, var_def%aval) case (V_SEV) - call var_list_append_subevt & - (node%var_list, name, var_def%pval) + call node%var_list%append_subevt (name, var_def%pval) case (V_STR) - call var_list_append_string (node%var_list, name, var_def%sval) + call node%var_list%append_string (name, var_def%sval) end select else select case (type) - case (V_LOG); call var_list_append_log_ptr & - (node%var_list, name, var_def%lval, var_def%value_is_known) - case (V_INT); call var_list_append_int_ptr & - (node%var_list, name, var_def%ival, var_def%value_is_known) - case (V_REAL); call var_list_append_real_ptr & - (node%var_list, name, var_def%rval, var_def%value_is_known) - case (V_CMPLX); call var_list_append_cmplx_ptr & - (node%var_list, name, var_def%cval, var_def%value_is_known) - case (V_PDG); call var_list_append_pdg_array_ptr & - (node%var_list, name, var_def%aval, var_def%value_is_known) - case (V_SEV); call var_list_append_subevt_ptr & - (node%var_list, name, var_def%pval, var_def%value_is_known) - case (V_STR); call var_list_append_string_ptr & - (node%var_list, name, var_def%sval, var_def%value_is_known) + case (V_LOG); call node%var_list%append_log_ptr & + (name, var_def%lval, var_def%value_is_known) + case (V_INT); call node%var_list%append_int_ptr & + (name, var_def%ival, var_def%value_is_known) + case (V_REAL); call node%var_list%append_real_ptr & + (name, var_def%rval, var_def%value_is_known) + case (V_CMPLX); call node%var_list%append_cmplx_ptr & + (name, var_def%cval, var_def%value_is_known) + case (V_PDG); call node%var_list%append_pdg_array_ptr & + (name, var_def%aval, var_def%value_is_known) + case (V_SEV); call node%var_list%append_subevt_ptr & + (name, var_def%pval, var_def%value_is_known) + case (V_STR); call node%var_list%append_string_ptr & + (name, var_def%sval, var_def%value_is_known) end select end if end subroutine eval_node_init_block @ %def eval_node_init_block @ Complete block initialization by assigning the expression to evaluate to [[arg0]]. <>= subroutine eval_node_set_expr (node, arg, result_type) type(eval_node_t), intent(inout) :: node type(eval_node_t), intent(in), target :: arg integer, intent(in), optional :: result_type if (present (result_type)) then node%result_type = result_type else node%result_type = arg%result_type end if call eval_node_allocate_value (node) node%arg0 => arg end subroutine eval_node_set_expr @ %def eval_node_set_block_expr @ Initialize a conditional. There are three branches: the condition (evaluates to logical) and the two alternatives (evaluate both to the same arbitrary type). <>= subroutine eval_node_init_conditional (node, result_type, cond, arg1, arg2) type(eval_node_t), intent(out) :: node integer, intent(in) :: result_type type(eval_node_t), intent(in), target :: cond, arg1, arg2 node%type = EN_CONDITIONAL node%tag = "cond" node%result_type = result_type call eval_node_allocate_value (node) node%arg0 => cond node%arg1 => arg1 node%arg2 => arg2 end subroutine eval_node_init_conditional @ %def eval_node_init_conditional @ Initialize a recording command (which evaluates to a logical constant). The first branch is the ID of the analysis object to be filled, the optional branches 1 to 4 are the values to be recorded. If the event-weight pointer is null, we record values with unit weight. Otherwise, we use the value pointed to as event weight. There can be up to four arguments which represent $x$, $y$, $\Delta y$, $\Delta x$. Therefore, this is the only node type that may fill four sub-nodes. <>= subroutine eval_node_init_record_cmd & (node, event_weight, id, arg1, arg2, arg3, arg4) type(eval_node_t), intent(out) :: node real(default), pointer :: event_weight type(eval_node_t), intent(in), target :: id type(eval_node_t), intent(in), optional, target :: arg1, arg2, arg3, arg4 call eval_node_init_log (node, .true.) node%type = EN_RECORD_CMD node%rval => event_weight node%tag = "record_cmd" node%arg0 => id if (present (arg1)) then node%arg1 => arg1 if (present (arg2)) then node%arg2 => arg2 if (present (arg3)) then node%arg3 => arg3 if (present (arg4)) then node%arg4 => arg4 end if end if end if end if end subroutine eval_node_init_record_cmd @ %def eval_node_init_record_cmd @ Initialize a node for operations on subevents. The particle lists (one or two) are inserted as [[arg1]] and [[arg2]]. We allocated particle pointers as temporaries for iterating over particle lists. The procedure pointer which holds the function to evaluate for the subevents (e.g., combine, select) is also initialized. <>= subroutine eval_node_init_prt_fun_unary (node, arg1, name, proc) type(eval_node_t), intent(out) :: node type(eval_node_t), intent(in), target :: arg1 type(string_t), intent(in) :: name procedure(unary_sev) :: proc node%type = EN_PRT_FUN_UNARY node%tag = name node%result_type = V_SEV call eval_node_allocate_value (node) node%arg1 => arg1 allocate (node%index, source = 0) allocate (node%prt1) node%op1_sev => proc end subroutine eval_node_init_prt_fun_unary subroutine eval_node_init_prt_fun_binary (node, arg1, arg2, name, proc) type(eval_node_t), intent(out) :: node type(eval_node_t), intent(in), target :: arg1, arg2 type(string_t), intent(in) :: name procedure(binary_sev) :: proc node%type = EN_PRT_FUN_BINARY node%tag = name node%result_type = V_SEV call eval_node_allocate_value (node) node%arg1 => arg1 node%arg2 => arg2 allocate (node%index, source = 0) allocate (node%prt1) allocate (node%prt2) node%op2_sev => proc end subroutine eval_node_init_prt_fun_binary @ %def eval_node_init_prt_fun_unary eval_node_init_prt_fun_binary @ Similar, but for particle-list functions that evaluate to a real value. <>= subroutine eval_node_init_eval_fun_unary (node, arg1, name) type(eval_node_t), intent(out) :: node type(eval_node_t), intent(in), target :: arg1 type(string_t), intent(in) :: name node%type = EN_EVAL_FUN_UNARY node%tag = name node%result_type = V_REAL call eval_node_allocate_value (node) node%arg1 => arg1 allocate (node%index, source = 0) allocate (node%prt1) end subroutine eval_node_init_eval_fun_unary subroutine eval_node_init_eval_fun_binary (node, arg1, arg2, name) type(eval_node_t), intent(out) :: node type(eval_node_t), intent(in), target :: arg1, arg2 type(string_t), intent(in) :: name node%type = EN_EVAL_FUN_BINARY node%tag = name node%result_type = V_REAL call eval_node_allocate_value (node) node%arg1 => arg1 node%arg2 => arg2 allocate (node%index, source = 0) allocate (node%prt1) allocate (node%prt2) end subroutine eval_node_init_eval_fun_binary @ %def eval_node_init_eval_fun_unary eval_node_init_eval_fun_binary @ These are for particle-list functions that evaluate to a logical value. <>= subroutine eval_node_init_log_fun_unary (node, arg1, name, proc) type(eval_node_t), intent(out) :: node type(eval_node_t), intent(in), target :: arg1 type(string_t), intent(in) :: name procedure(unary_cut) :: proc node%type = EN_LOG_FUN_UNARY node%tag = name node%result_type = V_LOG call eval_node_allocate_value (node) node%arg1 => arg1 allocate (node%index, source = 0) allocate (node%prt1) node%op1_cut => proc end subroutine eval_node_init_log_fun_unary subroutine eval_node_init_log_fun_binary (node, arg1, arg2, name, proc) type(eval_node_t), intent(out) :: node type(eval_node_t), intent(in), target :: arg1, arg2 type(string_t), intent(in) :: name procedure(binary_cut) :: proc node%type = EN_LOG_FUN_BINARY node%tag = name node%result_type = V_LOG call eval_node_allocate_value (node) node%arg1 => arg1 node%arg2 => arg2 allocate (node%index, source = 0) allocate (node%prt1) allocate (node%prt2) node%op2_cut => proc end subroutine eval_node_init_log_fun_binary @ %def eval_node_init_log_fun_unary eval_node_init_log_fun_binary @ These are for particle-list functions that evaluate to an integer value. <>= subroutine eval_node_init_int_fun_unary (node, arg1, name, proc) type(eval_node_t), intent(out) :: node type(eval_node_t), intent(in), target :: arg1 type(string_t), intent(in) :: name procedure(unary_evi) :: proc node%type = EN_INT_FUN_UNARY node%tag = name node%result_type = V_INT call eval_node_allocate_value (node) node%arg1 => arg1 allocate (node%index, source = 0) allocate (node%prt1) node%op1_evi => proc end subroutine eval_node_init_int_fun_unary subroutine eval_node_init_int_fun_binary (node, arg1, arg2, name, proc) type(eval_node_t), intent(out) :: node type(eval_node_t), intent(in), target :: arg1, arg2 type(string_t), intent(in) :: name procedure(binary_evi) :: proc node%type = EN_INT_FUN_BINARY node%tag = name node%result_type = V_INT call eval_node_allocate_value (node) node%arg1 => arg1 node%arg2 => arg2 allocate (node%index, source = 0) allocate (node%prt1) allocate (node%prt2) node%op2_evi => proc end subroutine eval_node_init_int_fun_binary @ %def eval_node_init_int_fun_unary eval_node_init_int_fun_binary @ These are for particle-list functions that evaluate to a real value. <>= subroutine eval_node_init_real_fun_unary (node, arg1, name, proc) type(eval_node_t), intent(out) :: node type(eval_node_t), intent(in), target :: arg1 type(string_t), intent(in) :: name procedure(unary_evr) :: proc node%type = EN_REAL_FUN_UNARY node%tag = name node%result_type = V_REAL call eval_node_allocate_value (node) node%arg1 => arg1 allocate (node%index, source = 0) allocate (node%prt1) node%op1_evr => proc end subroutine eval_node_init_real_fun_unary subroutine eval_node_init_real_fun_binary (node, arg1, arg2, name, proc) type(eval_node_t), intent(out) :: node type(eval_node_t), intent(in), target :: arg1, arg2 type(string_t), intent(in) :: name procedure(binary_evr) :: proc node%type = EN_REAL_FUN_BINARY node%tag = name node%result_type = V_REAL call eval_node_allocate_value (node) node%arg1 => arg1 node%arg2 => arg2 allocate (node%index, source = 0) allocate (node%prt1) allocate (node%prt2) node%op2_evr => proc end subroutine eval_node_init_real_fun_binary subroutine eval_node_init_real_fun_cum (node, arg1, name, proc) type(eval_node_t), intent(out) :: node type(eval_node_t), intent(in), target :: arg1 type(string_t), intent(in) :: name procedure(cum_evr) :: proc node%type = EN_REAL_FUN_CUM node%tag = name node%result_type = V_REAL call eval_node_allocate_value (node) node%arg1 => arg1 allocate (node%index, source = 0) allocate (node%prt1) node%opcum_evr => proc end subroutine eval_node_init_real_fun_cum @ %def eval_node_init_real_fun_unary eval_node_init_real_fun_binary @ %def eval_node_init_real_fun_cum @ Initialize a node for a string formatting function (sprintf). <>= subroutine eval_node_init_format_string (node, fmt, arg, name, n_args) type(eval_node_t), intent(out) :: node type(eval_node_t), pointer :: fmt, arg type(string_t), intent(in) :: name integer, intent(in) :: n_args node%type = EN_FORMAT_STR node%tag = name node%result_type = V_STR call eval_node_allocate_value (node) node%arg0 => fmt node%arg1 => arg allocate (node%ival) node%ival = n_args end subroutine eval_node_init_format_string @ %def eval_node_init_format_string @ If particle functions depend upon a condition (or an expression is evaluated), the observables that can be evaluated for the given particles have to be thrown on the local variable stack. This is done here. Each observable is initialized with the particle pointers which have been allocated for the node. The integer variable that is referred to by the [[Index]] pseudo-observable is always known when it is referred to. <>= subroutine eval_node_set_observables (node, var_list) type(eval_node_t), intent(inout) :: node type(var_list_t), intent(in), target :: var_list logical, save, target :: known = .true. allocate (node%var_list) call node%var_list%link (var_list) allocate (node%index, source = 0) - call var_list_append_int_ptr & - (node%var_list, var_str ("Index"), node%index, known, intrinsic=.true.) + call node%var_list%append_int_ptr & + (var_str ("Index"), node%index, known, intrinsic=.true.) if (.not. associated (node%prt2)) then call var_list_set_observables_unary & (node%var_list, node%prt1) if (associated (node%pval)) then call var_list_set_observables_sev & (node%var_list, node%pval) end if else call var_list_set_observables_binary & (node%var_list, node%prt1, node%prt2) end if end subroutine eval_node_set_observables @ %def eval_node_set_observables @ \subsubsection{Output} <>= procedure :: write => eval_node_write <>= subroutine eval_node_write (node, unit, indent) class(eval_node_t), intent(in) :: node integer, intent(in), optional :: unit integer, intent(in), optional :: indent integer :: u, ind u = given_output_unit (unit); if (u < 0) return ind = 0; if (present (indent)) ind = indent write (u, "(A)", advance="no") repeat ("| ", ind) // "o " select case (node%type) case (EN_UNARY, EN_BINARY, EN_CONDITIONAL, & EN_PRT_FUN_UNARY, EN_PRT_FUN_BINARY, & EN_EVAL_FUN_UNARY, EN_EVAL_FUN_BINARY, & EN_LOG_FUN_UNARY, EN_LOG_FUN_BINARY, & EN_INT_FUN_UNARY, EN_INT_FUN_BINARY, & EN_REAL_FUN_UNARY, EN_REAL_FUN_BINARY, & EN_REAL_FUN_CUM) write (u, "(A)", advance="no") "[" // char (node%tag) // "] =" case (EN_CONSTANT) write (u, "(A)", advance="no") "[const] =" case (EN_VARIABLE) write (u, "(A)", advance="no") char (node%tag) // " =>" case (EN_OBS1_INT, EN_OBS2_INT, EN_OBS1_REAL, EN_OBS2_REAL) write (u, "(A)", advance="no") char (node%tag) // " =" case (EN_BLOCK) write (u, "(A)", advance="no") "[" // char (node%tag) // "]" // & char (node%var_name) // " [expr] = " case default write (u, "(A)", advance="no") "[???] =" end select select case (node%result_type) case (V_LOG) if (node%value_is_known) then if (node%lval) then write (u, "(1x,A)") "true" else write (u, "(1x,A)") "false" end if else write (u, "(1x,A)") "[unknown logical]" end if case (V_INT) if (node%value_is_known) then write (u, "(1x,I0)") node%ival else write (u, "(1x,A)") "[unknown integer]" end if case (V_REAL) if (node%value_is_known) then write (u, "(1x," // FMT_19 // ")") node%rval else write (u, "(1x,A)") "[unknown real]" end if case (V_CMPLX) if (node%value_is_known) then write (u, "(1x,'('," // FMT_19 // ",','," // & FMT_19 // ",')')") node%cval else write (u, "(1x,A)") "[unknown complex]" end if case (V_SEV) if (char (node%tag) == "@evt") then write (u, "(1x,A)") "[event subevent]" else if (node%value_is_known) then call node%pval%write (unit, prefix = repeat ("| ", ind + 1)) else write (u, "(1x,A)") "[unknown subevent]" end if case (V_PDG) write (u, "(1x)", advance="no") call node%aval%write (u); write (u, *) case (V_STR) if (node%value_is_known) then write (u, "(A)") '"' // char (node%sval) // '"' else write (u, "(1x,A)") "[unknown string]" end if case default write (u, "(1x,A)") "[empty]" end select select case (node%type) case (EN_OBS1_INT, EN_OBS1_REAL) write (u, "(A,6x,A)", advance="no") repeat ("| ", ind), "prt1 =" call prt_write (node%prt1, unit) case (EN_OBS2_INT, EN_OBS2_REAL) write (u, "(A,6x,A)", advance="no") repeat ("| ", ind), "prt1 =" call prt_write (node%prt1, unit) write (u, "(A,6x,A)", advance="no") repeat ("| ", ind), "prt2 =" call prt_write (node%prt2, unit) end select end subroutine eval_node_write recursive subroutine eval_node_write_rec (node, unit, indent) type(eval_node_t), intent(in) :: node integer, intent(in), optional :: unit integer, intent(in), optional :: indent integer :: u, ind u = given_output_unit (unit); if (u < 0) return ind = 0; if (present (indent)) ind = indent call eval_node_write (node, unit, indent) select case (node%type) case (EN_UNARY) if (associated (node%arg0)) & call eval_node_write_rec (node%arg0, unit, ind+1) call eval_node_write_rec (node%arg1, unit, ind+1) case (EN_BINARY) if (associated (node%arg0)) & call eval_node_write_rec (node%arg0, unit, ind+1) call eval_node_write_rec (node%arg1, unit, ind+1) call eval_node_write_rec (node%arg2, unit, ind+1) case (EN_BLOCK) call eval_node_write_rec (node%arg1, unit, ind+1) call eval_node_write_rec (node%arg0, unit, ind+1) case (EN_CONDITIONAL) call eval_node_write_rec (node%arg0, unit, ind+1) call eval_node_write_rec (node%arg1, unit, ind+1) call eval_node_write_rec (node%arg2, unit, ind+1) case (EN_PRT_FUN_UNARY, EN_EVAL_FUN_UNARY, & EN_LOG_FUN_UNARY, EN_INT_FUN_UNARY, EN_REAL_FUN_UNARY, & EN_REAL_FUN_CUM) if (associated (node%arg0)) & call eval_node_write_rec (node%arg0, unit, ind+1) call eval_node_write_rec (node%arg1, unit, ind+1) case (EN_PRT_FUN_BINARY, EN_EVAL_FUN_BINARY, & EN_LOG_FUN_BINARY, EN_INT_FUN_BINARY, EN_REAL_FUN_BINARY) if (associated (node%arg0)) & call eval_node_write_rec (node%arg0, unit, ind+1) call eval_node_write_rec (node%arg1, unit, ind+1) call eval_node_write_rec (node%arg2, unit, ind+1) case (EN_RECORD_CMD) if (associated (node%arg1)) then call eval_node_write_rec (node%arg1, unit, ind+1) if (associated (node%arg2)) then call eval_node_write_rec (node%arg2, unit, ind+1) if (associated (node%arg3)) then call eval_node_write_rec (node%arg3, unit, ind+1) if (associated (node%arg4)) then call eval_node_write_rec (node%arg4, unit, ind+1) end if end if end if end if end select end subroutine eval_node_write_rec @ %def eval_node_write eval_node_write_rec @ \subsection{Operation types} For the operations associated to evaluation tree nodes, we define abstract interfaces for all cases. Particles/subevents are transferred by-reference, to avoid unnecessary copying. Therefore, subroutines instead of functions. <>= abstract interface logical function unary_log (arg) import eval_node_t type(eval_node_t), intent(in) :: arg end function unary_log end interface abstract interface integer function unary_int (arg) import eval_node_t type(eval_node_t), intent(in) :: arg end function unary_int end interface abstract interface real(default) function unary_real (arg) import default import eval_node_t type(eval_node_t), intent(in) :: arg end function unary_real end interface abstract interface complex(default) function unary_cmplx (arg) import default import eval_node_t type(eval_node_t), intent(in) :: arg end function unary_cmplx end interface abstract interface subroutine unary_pdg (pdg_array, arg) import pdg_array_t import eval_node_t type(pdg_array_t), intent(out) :: pdg_array type(eval_node_t), intent(in) :: arg end subroutine unary_pdg end interface abstract interface subroutine unary_sev (subevt, arg, arg0) import subevt_t import eval_node_t type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: arg type(eval_node_t), intent(inout), optional :: arg0 end subroutine unary_sev end interface abstract interface subroutine unary_str (string, arg) import string_t import eval_node_t type(string_t), intent(out) :: string type(eval_node_t), intent(in) :: arg end subroutine unary_str end interface abstract interface logical function unary_cut (arg1, arg0) import eval_node_t type(eval_node_t), intent(in) :: arg1 type(eval_node_t), intent(inout) :: arg0 end function unary_cut end interface abstract interface subroutine unary_evi (ival, arg1, arg0) import eval_node_t integer, intent(out) :: ival type(eval_node_t), intent(in) :: arg1 type(eval_node_t), intent(inout), optional :: arg0 end subroutine unary_evi end interface abstract interface subroutine unary_evr (rval, arg1, arg0) import eval_node_t, default real(default), intent(out) :: rval type(eval_node_t), intent(in) :: arg1 type(eval_node_t), intent(inout), optional :: arg0 end subroutine unary_evr end interface abstract interface logical function binary_log (arg1, arg2) import eval_node_t type(eval_node_t), intent(in) :: arg1, arg2 end function binary_log end interface abstract interface integer function binary_int (arg1, arg2) import eval_node_t type(eval_node_t), intent(in) :: arg1, arg2 end function binary_int end interface abstract interface real(default) function binary_real (arg1, arg2) import default import eval_node_t type(eval_node_t), intent(in) :: arg1, arg2 end function binary_real end interface abstract interface complex(default) function binary_cmplx (arg1, arg2) import default import eval_node_t type(eval_node_t), intent(in) :: arg1, arg2 end function binary_cmplx end interface abstract interface subroutine binary_pdg (pdg_array, arg1, arg2) import pdg_array_t import eval_node_t type(pdg_array_t), intent(out) :: pdg_array type(eval_node_t), intent(in) :: arg1, arg2 end subroutine binary_pdg end interface abstract interface subroutine binary_sev (subevt, arg1, arg2, arg0) import subevt_t import eval_node_t type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: arg1, arg2 type(eval_node_t), intent(inout), optional :: arg0 end subroutine binary_sev end interface abstract interface subroutine binary_str (string, arg1, arg2) import string_t import eval_node_t type(string_t), intent(out) :: string type(eval_node_t), intent(in) :: arg1, arg2 end subroutine binary_str end interface abstract interface logical function binary_cut (arg1, arg2, arg0) import eval_node_t type(eval_node_t), intent(in) :: arg1, arg2 type(eval_node_t), intent(inout) :: arg0 end function binary_cut end interface abstract interface subroutine binary_evi (ival, arg1, arg2, arg0) import eval_node_t integer, intent(out) :: ival type(eval_node_t), intent(in) :: arg1, arg2 type(eval_node_t), intent(inout), optional :: arg0 end subroutine binary_evi end interface abstract interface subroutine binary_evr (rval, arg1, arg2, arg0) import eval_node_t, default real(default), intent(out) :: rval type(eval_node_t), intent(in) :: arg1, arg2 type(eval_node_t), intent(inout), optional :: arg0 end subroutine binary_evr end interface abstract interface integer function cum_evi (arg1, arg0) import eval_node_t type(eval_node_t), intent(in) :: arg1 type(eval_node_t), intent(inout) :: arg0 end function cum_evi end interface abstract interface real(default) function cum_evr (arg1, arg0) import eval_node_t, default type(eval_node_t), intent(in) :: arg1 type(eval_node_t), intent(inout) :: arg0 end function cum_evr end interface @ The following subroutines set the procedure pointer: <>= subroutine eval_node_set_op1_log (en, op) type(eval_node_t), intent(inout) :: en procedure(unary_log) :: op en%op1_log => op end subroutine eval_node_set_op1_log subroutine eval_node_set_op1_int (en, op) type(eval_node_t), intent(inout) :: en procedure(unary_int) :: op en%op1_int => op end subroutine eval_node_set_op1_int subroutine eval_node_set_op1_real (en, op) type(eval_node_t), intent(inout) :: en procedure(unary_real) :: op en%op1_real => op end subroutine eval_node_set_op1_real subroutine eval_node_set_op1_cmplx (en, op) type(eval_node_t), intent(inout) :: en procedure(unary_cmplx) :: op en%op1_cmplx => op end subroutine eval_node_set_op1_cmplx subroutine eval_node_set_op1_pdg (en, op) type(eval_node_t), intent(inout) :: en procedure(unary_pdg) :: op en%op1_pdg => op end subroutine eval_node_set_op1_pdg subroutine eval_node_set_op1_sev (en, op) type(eval_node_t), intent(inout) :: en procedure(unary_sev) :: op en%op1_sev => op end subroutine eval_node_set_op1_sev subroutine eval_node_set_op1_str (en, op) type(eval_node_t), intent(inout) :: en procedure(unary_str) :: op en%op1_str => op end subroutine eval_node_set_op1_str subroutine eval_node_set_op2_log (en, op) type(eval_node_t), intent(inout) :: en procedure(binary_log) :: op en%op2_log => op end subroutine eval_node_set_op2_log subroutine eval_node_set_op2_int (en, op) type(eval_node_t), intent(inout) :: en procedure(binary_int) :: op en%op2_int => op end subroutine eval_node_set_op2_int subroutine eval_node_set_op2_real (en, op) type(eval_node_t), intent(inout) :: en procedure(binary_real) :: op en%op2_real => op end subroutine eval_node_set_op2_real subroutine eval_node_set_op2_cmplx (en, op) type(eval_node_t), intent(inout) :: en procedure(binary_cmplx) :: op en%op2_cmplx => op end subroutine eval_node_set_op2_cmplx subroutine eval_node_set_op2_pdg (en, op) type(eval_node_t), intent(inout) :: en procedure(binary_pdg) :: op en%op2_pdg => op end subroutine eval_node_set_op2_pdg subroutine eval_node_set_op2_sev (en, op) type(eval_node_t), intent(inout) :: en procedure(binary_sev) :: op en%op2_sev => op end subroutine eval_node_set_op2_sev subroutine eval_node_set_op2_str (en, op) type(eval_node_t), intent(inout) :: en procedure(binary_str) :: op en%op2_str => op end subroutine eval_node_set_op2_str @ %def eval_node_set_operator @ \subsection{Specific operators} Our expression syntax contains all Fortran functions that make sense. These functions have to be provided in a form that they can be used in procedures pointers, and have the abstract interfaces above. For some intrinsic functions, we could use specific versions provided by Fortran directly. However, this has two drawbacks: (i) We should work with the values instead of the eval-nodes as argument, which complicates the interface; (ii) more importantly, the [[default]] real type need not be equivalent to double precision. This would, at least, introduce system dependencies. Finally, for operators there are no specific versions. Therefore, we write wrappers for all possible functions, at the expense of some overhead. \subsubsection{Binary numerical functions} <>= integer function add_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival + en2%ival end function add_ii real(default) function add_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival + en2%rval end function add_ir complex(default) function add_ic (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival + en2%cval end function add_ic real(default) function add_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval + en2%ival end function add_ri complex(default) function add_ci (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval + en2%ival end function add_ci complex(default) function add_cr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval + en2%rval end function add_cr complex(default) function add_rc (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval + en2%cval end function add_rc real(default) function add_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval + en2%rval end function add_rr complex(default) function add_cc (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval + en2%cval end function add_cc integer function sub_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival - en2%ival end function sub_ii real(default) function sub_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival - en2%rval end function sub_ir real(default) function sub_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval - en2%ival end function sub_ri complex(default) function sub_ic (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival - en2%cval end function sub_ic complex(default) function sub_ci (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval - en2%ival end function sub_ci complex(default) function sub_cr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval - en2%rval end function sub_cr complex(default) function sub_rc (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval - en2%cval end function sub_rc real(default) function sub_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval - en2%rval end function sub_rr complex(default) function sub_cc (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval - en2%cval end function sub_cc integer function mul_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival * en2%ival end function mul_ii real(default) function mul_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival * en2%rval end function mul_ir real(default) function mul_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval * en2%ival end function mul_ri complex(default) function mul_ic (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival * en2%cval end function mul_ic complex(default) function mul_ci (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval * en2%ival end function mul_ci complex(default) function mul_rc (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval * en2%cval end function mul_rc complex(default) function mul_cr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval * en2%rval end function mul_cr real(default) function mul_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval * en2%rval end function mul_rr complex(default) function mul_cc (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval * en2%cval end function mul_cc integer function div_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (en2%ival == 0) then if (en1%ival >= 0) then call msg_warning ("division by zero: " // int2char (en1%ival) // & " / 0 ; result set to 0") else call msg_warning ("division by zero: (" // int2char (en1%ival) // & ") / 0 ; result set to 0") end if y = 0 return end if y = en1%ival / en2%ival end function div_ii real(default) function div_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival / en2%rval end function div_ir real(default) function div_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval / en2%ival end function div_ri complex(default) function div_ic (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival / en2%cval end function div_ic complex(default) function div_ci (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval / en2%ival end function div_ci complex(default) function div_rc (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval / en2%cval end function div_rc complex(default) function div_cr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval / en2%rval end function div_cr real(default) function div_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval / en2%rval end function div_rr complex(default) function div_cc (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval / en2%cval end function div_cc integer function pow_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 integer :: a, b real(default) :: rres a = en1%ival b = en2%ival if ((a == 0) .and. (b < 0)) then call msg_warning ("division by zero: " // int2char (a) // & " ^ (" // int2char (b) // ") ; result set to 0") y = 0 return end if rres = real(a, default) ** b y = rres if (real(y, default) /= rres) then if (b < 0) then call msg_warning ("result of all-integer operation " // & int2char (a) // " ^ (" // int2char (b) // & ") has been trucated to "// int2char (y), & [ var_str ("Chances are that you want to use " // & "reals instead of integers at this point.") ]) else call msg_warning ("integer overflow in " // int2char (a) // & " ^ " // int2char (b) // " ; result is " // int2char (y), & [ var_str ("Using reals instead of integers might help.")]) end if end if end function pow_ii real(default) function pow_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval ** en2%ival end function pow_ri complex(default) function pow_ci (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval ** en2%ival end function pow_ci real(default) function pow_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival ** en2%rval end function pow_ir real(default) function pow_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval ** en2%rval end function pow_rr complex(default) function pow_cr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval ** en2%rval end function pow_cr complex(default) function pow_ic (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival ** en2%cval end function pow_ic complex(default) function pow_rc (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval ** en2%cval end function pow_rc complex(default) function pow_cc (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval ** en2%cval end function pow_cc integer function max_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = max (en1%ival, en2%ival) end function max_ii real(default) function max_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = max (real (en1%ival, default), en2%rval) end function max_ir real(default) function max_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = max (en1%rval, real (en2%ival, default)) end function max_ri real(default) function max_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = max (en1%rval, en2%rval) end function max_rr integer function min_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = min (en1%ival, en2%ival) end function min_ii real(default) function min_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = min (real (en1%ival, default), en2%rval) end function min_ir real(default) function min_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = min (en1%rval, real (en2%ival, default)) end function min_ri real(default) function min_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = min (en1%rval, en2%rval) end function min_rr integer function mod_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = mod (en1%ival, en2%ival) end function mod_ii real(default) function mod_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = mod (real (en1%ival, default), en2%rval) end function mod_ir real(default) function mod_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = mod (en1%rval, real (en2%ival, default)) end function mod_ri real(default) function mod_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = mod (en1%rval, en2%rval) end function mod_rr integer function modulo_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = modulo (en1%ival, en2%ival) end function modulo_ii real(default) function modulo_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = modulo (real (en1%ival, default), en2%rval) end function modulo_ir real(default) function modulo_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = modulo (en1%rval, real (en2%ival, default)) end function modulo_ri real(default) function modulo_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = modulo (en1%rval, en2%rval) end function modulo_rr @ \subsubsection{Unary numeric functions} <>= real(default) function real_i (en) result (y) type(eval_node_t), intent(in) :: en y = en%ival end function real_i real(default) function real_c (en) result (y) type(eval_node_t), intent(in) :: en y = en%cval end function real_c integer function int_r (en) result (y) type(eval_node_t), intent(in) :: en y = en%rval end function int_r complex(default) function cmplx_i (en) result (y) type(eval_node_t), intent(in) :: en y = en%ival end function cmplx_i integer function int_c (en) result (y) type(eval_node_t), intent(in) :: en y = en%cval end function int_c complex(default) function cmplx_r (en) result (y) type(eval_node_t), intent(in) :: en y = en%rval end function cmplx_r integer function nint_r (en) result (y) type(eval_node_t), intent(in) :: en y = nint (en%rval) end function nint_r integer function floor_r (en) result (y) type(eval_node_t), intent(in) :: en y = floor (en%rval) end function floor_r integer function ceiling_r (en) result (y) type(eval_node_t), intent(in) :: en y = ceiling (en%rval) end function ceiling_r integer function neg_i (en) result (y) type(eval_node_t), intent(in) :: en y = - en%ival end function neg_i real(default) function neg_r (en) result (y) type(eval_node_t), intent(in) :: en y = - en%rval end function neg_r complex(default) function neg_c (en) result (y) type(eval_node_t), intent(in) :: en y = - en%cval end function neg_c integer function abs_i (en) result (y) type(eval_node_t), intent(in) :: en y = abs (en%ival) end function abs_i real(default) function abs_r (en) result (y) type(eval_node_t), intent(in) :: en y = abs (en%rval) end function abs_r real(default) function abs_c (en) result (y) type(eval_node_t), intent(in) :: en y = abs (en%cval) end function abs_c integer function conjg_i (en) result (y) type(eval_node_t), intent(in) :: en y = en%ival end function conjg_i real(default) function conjg_r (en) result (y) type(eval_node_t), intent(in) :: en y = en%rval end function conjg_r complex(default) function conjg_c (en) result (y) type(eval_node_t), intent(in) :: en y = conjg (en%cval) end function conjg_c integer function sgn_i (en) result (y) type(eval_node_t), intent(in) :: en y = sign (1, en%ival) end function sgn_i real(default) function sgn_r (en) result (y) type(eval_node_t), intent(in) :: en y = sign (1._default, en%rval) end function sgn_r real(default) function sqrt_r (en) result (y) type(eval_node_t), intent(in) :: en y = sqrt (en%rval) end function sqrt_r real(default) function exp_r (en) result (y) type(eval_node_t), intent(in) :: en y = exp (en%rval) end function exp_r real(default) function log_r (en) result (y) type(eval_node_t), intent(in) :: en y = log (en%rval) end function log_r real(default) function log10_r (en) result (y) type(eval_node_t), intent(in) :: en y = log10 (en%rval) end function log10_r complex(default) function sqrt_c (en) result (y) type(eval_node_t), intent(in) :: en y = sqrt (en%cval) end function sqrt_c complex(default) function exp_c (en) result (y) type(eval_node_t), intent(in) :: en y = exp (en%cval) end function exp_c complex(default) function log_c (en) result (y) type(eval_node_t), intent(in) :: en y = log (en%cval) end function log_c real(default) function sin_r (en) result (y) type(eval_node_t), intent(in) :: en y = sin (en%rval) end function sin_r real(default) function cos_r (en) result (y) type(eval_node_t), intent(in) :: en y = cos (en%rval) end function cos_r real(default) function tan_r (en) result (y) type(eval_node_t), intent(in) :: en y = tan (en%rval) end function tan_r real(default) function asin_r (en) result (y) type(eval_node_t), intent(in) :: en y = asin (en%rval) end function asin_r real(default) function acos_r (en) result (y) type(eval_node_t), intent(in) :: en y = acos (en%rval) end function acos_r real(default) function atan_r (en) result (y) type(eval_node_t), intent(in) :: en y = atan (en%rval) end function atan_r complex(default) function sin_c (en) result (y) type(eval_node_t), intent(in) :: en y = sin (en%cval) end function sin_c complex(default) function cos_c (en) result (y) type(eval_node_t), intent(in) :: en y = cos (en%cval) end function cos_c real(default) function sinh_r (en) result (y) type(eval_node_t), intent(in) :: en y = sinh (en%rval) end function sinh_r real(default) function cosh_r (en) result (y) type(eval_node_t), intent(in) :: en y = cosh (en%rval) end function cosh_r real(default) function tanh_r (en) result (y) type(eval_node_t), intent(in) :: en y = tanh (en%rval) end function tanh_r real(default) function asinh_r (en) result (y) type(eval_node_t), intent(in) :: en y = asinh (en%rval) end function asinh_r real(default) function acosh_r (en) result (y) type(eval_node_t), intent(in) :: en y = acosh (en%rval) end function acosh_r real(default) function atanh_r (en) result (y) type(eval_node_t), intent(in) :: en y = atanh (en%rval) end function atanh_r @ \subsubsection{Binary logical functions} Logical expressions: <>= logical function ignore_first_ll (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en2%lval end function ignore_first_ll logical function or_ll (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%lval .or. en2%lval end function or_ll logical function and_ll (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%lval .and. en2%lval end function and_ll @ Comparisons: <>= logical function comp_lt_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival < en2%ival end function comp_lt_ii logical function comp_lt_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival < en2%rval end function comp_lt_ir logical function comp_lt_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval < en2%ival end function comp_lt_ri logical function comp_lt_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval < en2%rval end function comp_lt_rr logical function comp_gt_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival > en2%ival end function comp_gt_ii logical function comp_gt_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival > en2%rval end function comp_gt_ir logical function comp_gt_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval > en2%ival end function comp_gt_ri logical function comp_gt_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval > en2%rval end function comp_gt_rr logical function comp_le_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival <= en2%ival end function comp_le_ii logical function comp_le_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival <= en2%rval end function comp_le_ir logical function comp_le_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval <= en2%ival end function comp_le_ri logical function comp_le_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval <= en2%rval end function comp_le_rr logical function comp_ge_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival >= en2%ival end function comp_ge_ii logical function comp_ge_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival >= en2%rval end function comp_ge_ir logical function comp_ge_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval >= en2%ival end function comp_ge_ri logical function comp_ge_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval >= en2%rval end function comp_ge_rr logical function comp_eq_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival == en2%ival end function comp_eq_ii logical function comp_eq_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival == en2%rval end function comp_eq_ir logical function comp_eq_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval == en2%ival end function comp_eq_ri logical function comp_eq_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval == en2%rval end function comp_eq_rr logical function comp_eq_ss (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%sval == en2%sval end function comp_eq_ss logical function comp_ne_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival /= en2%ival end function comp_ne_ii logical function comp_ne_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival /= en2%rval end function comp_ne_ir logical function comp_ne_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval /= en2%ival end function comp_ne_ri logical function comp_ne_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval /= en2%rval end function comp_ne_rr logical function comp_ne_ss (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%sval /= en2%sval end function comp_ne_ss @ Comparisons with tolerance: <>= logical function comp_se_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = abs (en1%ival - en2%ival) <= en1%tolerance else y = en1%ival == en2%ival end if end function comp_se_ii logical function comp_se_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = abs (en1%rval - en2%ival) <= en1%tolerance else y = en1%rval == en2%ival end if end function comp_se_ri logical function comp_se_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = abs (en1%ival - en2%rval) <= en1%tolerance else y = en1%ival == en2%rval end if end function comp_se_ir logical function comp_se_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = abs (en1%rval - en2%rval) <= en1%tolerance else y = en1%rval == en2%rval end if end function comp_se_rr logical function comp_ns_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = abs (en1%ival - en2%ival) > en1%tolerance else y = en1%ival /= en2%ival end if end function comp_ns_ii logical function comp_ns_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = abs (en1%rval - en2%ival) > en1%tolerance else y = en1%rval /= en2%ival end if end function comp_ns_ri logical function comp_ns_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = abs (en1%ival - en2%rval) > en1%tolerance else y = en1%ival /= en2%rval end if end function comp_ns_ir logical function comp_ns_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = abs (en1%rval - en2%rval) > en1%tolerance else y = en1%rval /= en2%rval end if end function comp_ns_rr logical function comp_ls_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%ival <= en2%ival + en1%tolerance else y = en1%ival <= en2%ival end if end function comp_ls_ii logical function comp_ls_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%rval <= en2%ival + en1%tolerance else y = en1%rval <= en2%ival end if end function comp_ls_ri logical function comp_ls_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%ival <= en2%rval + en1%tolerance else y = en1%ival <= en2%rval end if end function comp_ls_ir logical function comp_ls_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%rval <= en2%rval + en1%tolerance else y = en1%rval <= en2%rval end if end function comp_ls_rr logical function comp_ll_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%ival < en2%ival - en1%tolerance else y = en1%ival < en2%ival end if end function comp_ll_ii logical function comp_ll_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%rval < en2%ival - en1%tolerance else y = en1%rval < en2%ival end if end function comp_ll_ri logical function comp_ll_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%ival < en2%rval - en1%tolerance else y = en1%ival < en2%rval end if end function comp_ll_ir logical function comp_ll_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%rval < en2%rval - en1%tolerance else y = en1%rval < en2%rval end if end function comp_ll_rr logical function comp_gs_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%ival >= en2%ival - en1%tolerance else y = en1%ival >= en2%ival end if end function comp_gs_ii logical function comp_gs_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%rval >= en2%ival - en1%tolerance else y = en1%rval >= en2%ival end if end function comp_gs_ri logical function comp_gs_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%ival >= en2%rval - en1%tolerance else y = en1%ival >= en2%rval end if end function comp_gs_ir logical function comp_gs_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%rval >= en2%rval - en1%tolerance else y = en1%rval >= en2%rval end if end function comp_gs_rr logical function comp_gg_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%ival > en2%ival + en1%tolerance else y = en1%ival > en2%ival end if end function comp_gg_ii logical function comp_gg_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%rval > en2%ival + en1%tolerance else y = en1%rval > en2%ival end if end function comp_gg_ri logical function comp_gg_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%ival > en2%rval + en1%tolerance else y = en1%ival > en2%rval end if end function comp_gg_ir logical function comp_gg_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%rval > en2%rval + en1%tolerance else y = en1%rval > en2%rval end if end function comp_gg_rr @ \subsubsection{Unary logical functions} <>= logical function not_l (en) result (y) type(eval_node_t), intent(in) :: en y = .not. en%lval end function not_l @ \subsubsection{Unary PDG-array functions} Make a PDG-array object from an integer. <>= subroutine pdg_i (pdg_array, en) type(pdg_array_t), intent(out) :: pdg_array type(eval_node_t), intent(in) :: en pdg_array = en%ival end subroutine pdg_i @ \subsubsection{Binary PDG-array functions} Concatenate two PDG-array objects. <>= subroutine concat_cc (pdg_array, en1, en2) type(pdg_array_t), intent(out) :: pdg_array type(eval_node_t), intent(in) :: en1, en2 pdg_array = en1%aval // en2%aval end subroutine concat_cc @ \subsubsection{Unary particle-list functions} Combine all particles of the first argument. If [[en0]] is present, create a mask which is true only for those particles that pass the test. <>= subroutine collect_p (subevt, en1, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout), optional :: en0 logical, dimension(:), allocatable :: mask1 integer :: n, i n = en1%pval%get_length () allocate (mask1 (n)) if (present (en0)) then do i = 1, n en0%index = i en0%prt1 = en1%pval%get_prt (i) call eval_node_evaluate (en0) mask1(i) = en0%lval end do else mask1 = .true. end if call subevt_collect (subevt, en1%pval, mask1) end subroutine collect_p @ %def collect_p @ Cluster the particles of the first argument. If [[en0]] is present, create a mask which is true only for those particles that pass the test. <>= subroutine cluster_p (subevt, en1, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout), optional :: en0 logical, dimension(:), allocatable :: mask1 integer :: n, i !!! Should not be initialized for every event type(jet_definition_t) :: jet_def logical :: keep_jets, exclusive call jet_def%init (en1%jet_algorithm, en1%jet_r, en1%jet_p, en1%jet_ycut) n = en1%pval%get_length () allocate (mask1 (n)) if (present (en0)) then do i = 1, n en0%index = i en0%prt1 = en1%pval%get_prt (i) call eval_node_evaluate (en0) mask1(i) = en0%lval end do else mask1 = .true. end if if (associated (en1%var_list)) then keep_jets = en1%var_list%get_lval (var_str("?keep_flavors_when_clustering")) else keep_jets = .false. end if exclusive = .false. select case (en1%jet_algorithm) case (ee_kt_algorithm) exclusive = .true. case (ee_genkt_algorithm) if (en1%jet_r > Pi) exclusive = .true. end select call subevt_cluster (subevt, en1%pval, en1%jet_dcut, mask1, & jet_def, keep_jets, exclusive) call jet_def%final () end subroutine cluster_p @ %def cluster_p @ Recombine photons with other particles (usually charged leptons and maybe quarks) given in the same subevent. If [[en0]] is present, create a mask which is true only for those particles that pass the test. <>= subroutine photon_recombination_p (subevt, en1, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout), optional :: en0 logical, dimension(:), allocatable :: mask1 type(prt_t), dimension(:), allocatable :: prt integer :: n, i real(default) :: reco_r0 logical :: keep_flv reco_r0 = en1%photon_rec_r0 n = en1%pval%get_length () allocate (prt (n)) do i = 1, n prt(i) = en1%pval%get_prt (i) if (.not. prt_is_recombinable (prt (i))) then call msg_fatal ("Only charged leptons, quarks, and " //& "photons can be included in photon recombination.") end if end do if (count (prt_is_photon (prt)) > 1) & call msg_fatal ("Photon recombination is supported " // & "only for single photons.") allocate (mask1 (n)) if (present (en0)) then do i = 1, n en0%index = i en0%prt1 = en1%pval%get_prt (i) call eval_node_evaluate (en0) mask1(i) = en0%lval end do else mask1 = .true. end if if (associated (en1%var_list)) then keep_flv = en1%var_list%get_lval & (var_str("?keep_flavors_when_recombining")) else keep_flv = .false. end if call subevt_recombine & (subevt, en1%pval, mask1, reco_r0, keep_flv) end subroutine photon_recombination_p @ %def photon_recombination_p @ Select all particles of the first argument. If [[en0]] is present, create a mask which is true only for those particles that pass the test. <>= subroutine select_p (subevt, en1, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout), optional :: en0 logical, dimension(:), allocatable :: mask1 integer :: n, i n = en1%pval%get_length () allocate (mask1 (n)) if (present (en0)) then do i = 1, n en0%index = i en0%prt1 = en1%pval%get_prt (i) call eval_node_evaluate (en0) mask1(i) = en0%lval end do else mask1 = .true. end if call subevt_select (subevt, en1%pval, mask1) end subroutine select_p @ %def select_p [[select_b_jet_p]], [[select_non_b_jet_p]], [[select_c_jet_p]], and [[select_light_jet_p]] are special selection function acting on a subevent of combined particles (jets) and result in a list of $b$ jets, non-$b$ jets (i.e. $c$ and light jets), $c$ jets, and light jets, respectively. <>= subroutine select_b_jet_p (subevt, en1, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout), optional :: en0 logical, dimension(:), allocatable :: mask1 integer :: n, i n = en1%pval%get_length () allocate (mask1 (n)) do i = 1, n mask1(i) = prt_is_b_jet (en1%pval%get_prt (i)) if (present (en0)) then en0%index = i en0%prt1 = en1%pval%get_prt (i) call eval_node_evaluate (en0) mask1(i) = en0%lval .and. mask1(i) end if end do call subevt_select (subevt, en1%pval, mask1) end subroutine select_b_jet_p @ %def select_b_jet_p <>= subroutine select_non_b_jet_p (subevt, en1, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout), optional :: en0 logical, dimension(:), allocatable :: mask1 integer :: n, i n = en1%pval%get_length () allocate (mask1 (n)) do i = 1, n mask1(i) = .not. prt_is_b_jet (en1%pval%get_prt (i)) if (present (en0)) then en0%index = i en0%prt1 = en1%pval%get_prt (i) call eval_node_evaluate (en0) mask1(i) = en0%lval .and. mask1(i) end if end do call subevt_select (subevt, en1%pval, mask1) end subroutine select_non_b_jet_p @ %def select_non_b_jet_p <>= subroutine select_c_jet_p (subevt, en1, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout), optional :: en0 logical, dimension(:), allocatable :: mask1 integer :: n, i n = en1%pval%get_length () allocate (mask1 (n)) do i = 1, n mask1(i) = .not. prt_is_b_jet (en1%pval%get_prt (i)) & .and. prt_is_c_jet (en1%pval%get_prt (i)) if (present (en0)) then en0%index = i en0%prt1 = en1%pval%get_prt (i) call eval_node_evaluate (en0) mask1(i) = en0%lval .and. mask1(i) end if end do call subevt_select (subevt, en1%pval, mask1) end subroutine select_c_jet_p @ %def select_c_jet_p <>= subroutine select_light_jet_p (subevt, en1, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout), optional :: en0 logical, dimension(:), allocatable :: mask1 integer :: n, i n = en1%pval%get_length () allocate (mask1 (n)) do i = 1, n mask1(i) = .not. prt_is_b_jet (en1%pval%get_prt (i)) & .and. .not. prt_is_c_jet (en1%pval%get_prt (i)) if (present (en0)) then en0%index = i en0%prt1 = en1%pval%get_prt (i) call eval_node_evaluate (en0) mask1(i) = en0%lval .and. mask1(i) end if end do call subevt_select (subevt, en1%pval, mask1) end subroutine select_light_jet_p @ %def select_light_jet_p @ Extract the particle with index given by [[en0]] from the argument list. Negative indices count from the end. If [[en0]] is absent, extract the first particle. The result is a list with a single entry, or no entries if the original list was empty or if the index is out of range. This function has no counterpart with two arguments. <>= subroutine extract_p (subevt, en1, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout), optional :: en0 integer :: index if (present (en0)) then call eval_node_evaluate (en0) select case (en0%result_type) case (V_INT); index = en0%ival case default call eval_node_write (en0) call msg_fatal (" Index parameter of 'extract' must be integer.") end select else index = 1 end if call subevt_extract (subevt, en1%pval, index) end subroutine extract_p @ %def extract_p @ Sort the subevent according to the result of evaluating [[en0]]. If [[en0]] is absent, sort by default method (PDG code, particles before antiparticles). <>= subroutine sort_p (subevt, en1, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout), optional :: en0 integer, dimension(:), allocatable :: ival real(default), dimension(:), allocatable :: rval integer :: i, n n = en1%pval%get_length () if (present (en0)) then select case (en0%result_type) case (V_INT); allocate (ival (n)) case (V_REAL); allocate (rval (n)) end select do i = 1, n en0%index = i en0%prt1 = en1%pval%get_prt (i) call eval_node_evaluate (en0) select case (en0%result_type) case (V_INT); ival(i) = en0%ival case (V_REAL); rval(i) = en0%rval end select end do select case (en0%result_type) case (V_INT); call subevt_sort (subevt, en1%pval, ival) case (V_REAL); call subevt_sort (subevt, en1%pval, rval) end select else call subevt_sort (subevt, en1%pval) end if end subroutine sort_p @ %def sort_p @ The following functions return a logical value. [[all]] evaluates to true if the condition [[en0]] is true for all elements of the subevent. [[any]] and [[no]] are analogous. <>= function all_p (en1, en0) result (lval) logical :: lval type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout) :: en0 integer :: i, n n = en1%pval%get_length () lval = .true. do i = 1, n en0%index = i en0%prt1 = en1%pval%get_prt (i) call eval_node_evaluate (en0) lval = en0%lval if (.not. lval) exit end do end function all_p function any_p (en1, en0) result (lval) logical :: lval type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout) :: en0 integer :: i, n n = en1%pval%get_length () lval = .false. do i = 1, n en0%index = i en0%prt1 = en1%pval%get_prt (i) call eval_node_evaluate (en0) lval = en0%lval if (lval) exit end do end function any_p function no_p (en1, en0) result (lval) logical :: lval type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout) :: en0 integer :: i, n n = en1%pval%get_length () lval = .true. do i = 1, n en0%index = i en0%prt1 = en1%pval%get_prt (i) call eval_node_evaluate (en0) lval = .not. en0%lval if (lval) exit end do end function no_p @ %def all_p any_p no_p @ The following function returns an integer value, namely the number of particles for which the condition is true. If there is no condition, it returns simply the length of the subevent. <>= subroutine count_a (ival, en1, en0) integer, intent(out) :: ival type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout), optional :: en0 integer :: i, n, count n = en1%pval%get_length () if (present (en0)) then count = 0 do i = 1, n en0%index = i en0%prt1 = en1%pval%get_prt (i) call eval_node_evaluate (en0) if (en0%lval) count = count + 1 end do ival = count else ival = n end if end subroutine count_a @ %def count_a @ The following functions return either an integer or a real value, namely the sum or the product of the values of the corresponding expression. <>= function sum_a (en1, en0) result (rval) real(default) :: rval type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout) :: en0 integer :: i, n n = en1%pval%get_length () rval = 0._default do i = 1, n en0%index = i en0%prt1 = en1%pval%get_prt (i) call eval_node_evaluate (en0) rval = rval + en0%rval end do end function sum_a function prod_a (en1, en0) result (rval) real(default) :: rval type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout) :: en0 integer :: i, n n = en1%pval%get_length () rval = 1._default do i = 1, n en0%index = i en0%prt1 = en1%pval%get_prt (i) call eval_node_evaluate (en0) rval = rval * en0%rval end do end function prod_a @ %def sum_a prod_a \subsubsection{Binary particle-list functions} This joins two subevents, stored in the evaluation nodes [[en1]] and [[en2]]. If [[en0]] is also present, it amounts to a logical test returning true or false for every pair of particles. A particle of the second list gets a mask entry only if it passes the test for all particles of the first list. <>= subroutine join_pp (subevt, en1, en2, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout), optional :: en0 logical, dimension(:), allocatable :: mask2 integer :: i, j, n1, n2 n1 = en1%pval%get_length () n2 = en2%pval%get_length () allocate (mask2 (n2)) mask2 = .true. if (present (en0)) then do i = 1, n1 en0%index = i en0%prt1 = en1%pval%get_prt (i) do j = 1, n2 en0%prt2 = en2%pval%get_prt (j) call eval_node_evaluate (en0) mask2(j) = mask2(j) .and. en0%lval end do end do end if call subevt_join (subevt, en1%pval, en2%pval, mask2) end subroutine join_pp @ %def join_pp @ Combine two subevents, i.e., make a list of composite particles built from all possible particle pairs from the two lists. If [[en0]] is present, create a mask which is true only for those pairs that pass the test. <>= subroutine combine_pp (subevt, en1, en2, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout), optional :: en0 logical, dimension(:,:), allocatable :: mask12 integer :: i, j, n1, n2 n1 = en1%pval%get_length () n2 = en2%pval%get_length () if (present (en0)) then allocate (mask12 (n1, n2)) do i = 1, n1 en0%index = i en0%prt1 = en1%pval%get_prt (i) do j = 1, n2 en0%prt2 = en2%pval%get_prt (j) call eval_node_evaluate (en0) mask12(i,j) = en0%lval end do end do call subevt_combine (subevt, en1%pval, en2%pval, mask12) else call subevt_combine (subevt, en1%pval, en2%pval) end if end subroutine combine_pp @ %def combine_pp @ Combine all particles of the first argument. If [[en0]] is present, create a mask which is true only for those particles that pass the test w.r.t. all particles in the second argument. If [[en0]] is absent, the second argument is ignored. <>= subroutine collect_pp (subevt, en1, en2, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout), optional :: en0 logical, dimension(:), allocatable :: mask1 integer :: i, j, n1, n2 n1 = en1%pval%get_length () n2 = en2%pval%get_length () allocate (mask1 (n1)) mask1 = .true. if (present (en0)) then do i = 1, n1 en0%index = i en0%prt1 = en1%pval%get_prt (i) do j = 1, n2 en0%prt2 = en2%pval%get_prt (j) call eval_node_evaluate (en0) mask1(i) = mask1(i) .and. en0%lval end do end do end if call subevt_collect (subevt, en1%pval, mask1) end subroutine collect_pp @ %def collect_pp @ Select all particles of the first argument. If [[en0]] is present, create a mask which is true only for those particles that pass the test w.r.t. all particles in the second argument. If [[en0]] is absent, the second argument is ignored, and the first argument is transferred unchanged. (This case is not very useful, of course.) <>= subroutine select_pp (subevt, en1, en2, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout), optional :: en0 logical, dimension(:), allocatable :: mask1 integer :: i, j, n1, n2 n1 = en1%pval%get_length () n2 = en2%pval%get_length () allocate (mask1 (n1)) mask1 = .true. if (present (en0)) then do i = 1, n1 en0%index = i en0%prt1 = en1%pval%get_prt (i) do j = 1, n2 en0%prt2 = en2%pval%get_prt (j) call eval_node_evaluate (en0) mask1(i) = mask1(i) .and. en0%lval end do end do end if call subevt_select (subevt, en1%pval, mask1) end subroutine select_pp @ %def select_pp @ Sort the first subevent according to the result of evaluating [[en0]]. From the second subevent, only the first element is taken as reference. If [[en0]] is absent, we sort by default method (PDG code, particles before antiparticles). <>= subroutine sort_pp (subevt, en1, en2, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout), optional :: en0 integer, dimension(:), allocatable :: ival real(default), dimension(:), allocatable :: rval integer :: i, n1 n1 = en1%pval%get_length () if (present (en0)) then select case (en0%result_type) case (V_INT); allocate (ival (n1)) case (V_REAL); allocate (rval (n1)) end select do i = 1, n1 en0%index = i en0%prt1 = en1%pval%get_prt (i) en0%prt2 = en2%pval%get_prt (1) call eval_node_evaluate (en0) select case (en0%result_type) case (V_INT); ival(i) = en0%ival case (V_REAL); rval(i) = en0%rval end select end do select case (en0%result_type) case (V_INT); call subevt_sort (subevt, en1%pval, ival) case (V_REAL); call subevt_sort (subevt, en1%pval, rval) end select else call subevt_sort (subevt, en1%pval) end if end subroutine sort_pp @ %def sort_pp @ The following functions return a logical value. [[all]] evaluates to true if the condition [[en0]] is true for all valid element pairs of both subevents. Invalid pairs (with common [[src]] entry) are ignored. [[any]] and [[no]] are analogous. <>= function all_pp (en1, en2, en0) result (lval) logical :: lval type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout) :: en0 integer :: i, j, n1, n2 n1 = en1%pval%get_length () n2 = en2%pval%get_length () lval = .true. LOOP1: do i = 1, n1 en0%index = i en0%prt1 = en1%pval%get_prt (i) do j = 1, n2 en0%prt2 = en2%pval%get_prt (j) if (are_disjoint (en0%prt1, en0%prt2)) then call eval_node_evaluate (en0) lval = en0%lval if (.not. lval) exit LOOP1 end if end do end do LOOP1 end function all_pp function any_pp (en1, en2, en0) result (lval) logical :: lval type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout) :: en0 integer :: i, j, n1, n2 n1 = en1%pval%get_length () n2 = en2%pval%get_length () lval = .false. LOOP1: do i = 1, n1 en0%index = i en0%prt1 = en1%pval%get_prt (i) do j = 1, n2 en0%prt2 = en2%pval%get_prt (j) if (are_disjoint (en0%prt1, en0%prt2)) then call eval_node_evaluate (en0) lval = en0%lval if (lval) exit LOOP1 end if end do end do LOOP1 end function any_pp function no_pp (en1, en2, en0) result (lval) logical :: lval type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout) :: en0 integer :: i, j, n1, n2 n1 = en1%pval%get_length () n2 = en2%pval%get_length () lval = .true. LOOP1: do i = 1, n1 en0%index = i en0%prt1 = en1%pval%get_prt (i) do j = 1, n2 en0%prt2 = en2%pval%get_prt (j) if (are_disjoint (en0%prt1, en0%prt2)) then call eval_node_evaluate (en0) lval = .not. en0%lval if (lval) exit LOOP1 end if end do end do LOOP1 end function no_pp @ %def all_pp any_pp no_pp The conditional restriction encoded in the [[eval_node_t]] [[en_0]] is applied only to the photons from [[en1]], not to the objects being isolated from in [[en2]]. <>= function photon_isolation_pp (en1, en2, en0) result (lval) logical :: lval type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout) :: en0 type(prt_t) :: prt type(prt_t), dimension(:), allocatable :: prt_gam0, prt_lep type(vector4_t), dimension(:), allocatable :: & p_gam0, p_lep0, p_lep, p_par integer :: i, j, n1, n2, n_par, n_lep, n_gam, n_delta real(default), dimension(:), allocatable :: delta_r, et_sum integer, dimension(:), allocatable :: index real(default) :: eps, iso_n, r0, pt_gam logical, dimension(:,:), allocatable :: photon_mask n1 = en1%pval%get_length () n2 = en2%pval%get_length () allocate (p_gam0 (n1), prt_gam0 (n1)) eps = en1%photon_iso_eps iso_n = en1%photon_iso_n r0 = en1%photon_iso_r0 lval = .true. do i = 1, n1 en0%index = i prt = en1%pval%get_prt (i) prt_gam0(i) = prt if (.not. prt_is_photon (prt_gam0(i))) & call msg_fatal ("Photon isolation can only " // & "be applied to photons.") p_gam0(i) = prt_get_momentum (prt_gam0(i)) en0%prt1 = prt call eval_node_evaluate (en0) lval = en0%lval if (.not. lval) return end do if (n1 == 0) then call msg_fatal ("Photon isolation applied on empty photon sample.") end if n_par = 0 n_lep = 0 n_gam = 0 do i = 1, n2 prt = en2%pval%get_prt (i) if (prt_is_parton (prt) .or. prt_is_clustered (prt)) then n_par = n_par + 1 end if if (prt_is_lepton (prt)) then n_lep = n_lep + 1 end if if (prt_is_photon (prt)) then n_gam = n_gam + 1 end if end do if (n_lep > 0 .and. n_gam == 0) then call msg_fatal ("Photon isolation from EM energy: photons " // & "have to be included.") end if if (n_lep > 0 .and. n_gam /= n1) then call msg_fatal ("Photon isolation: photon samples do not match.") end if allocate (p_par (n_par)) allocate (p_lep0 (n_gam+n_lep), prt_lep(n_gam+n_lep)) n_par = 0 n_lep = 0 do i = 1, n2 prt = en2%pval%get_prt (i) if (prt_is_parton (prt) .or. prt_is_clustered (prt)) then n_par = n_par + 1 p_par(n_par) = prt_get_momentum (prt) end if if (prt_is_lepton (prt) .or. prt_is_photon(prt)) then n_lep = n_lep + 1 prt_lep(n_lep) = prt p_lep0(n_lep) = prt_get_momentum (prt_lep(n_lep)) end if end do if (n_par > 0) then allocate (delta_r (n_par), index (n_par)) HADRON_ISOLATION: do i = 1, n1 pt_gam = transverse_part (p_gam0(i)) delta_r(1:n_par) = sort (eta_phi_distance (p_gam0(i), p_par(1:n_par))) index(1:n_par) = order (eta_phi_distance (p_gam0(i), p_par(1:n_par))) n_delta = count (delta_r < r0) allocate (et_sum(n_delta)) do j = 1, n_delta et_sum(j) = sum (transverse_part (p_par (index (1:j)))) if (.not. et_sum(j) <= & iso_chi_gamma (delta_r(j), r0, iso_n, eps, pt_gam)) then lval = .false. return end if end do deallocate (et_sum) end do HADRON_ISOLATION deallocate (delta_r) deallocate (index) end if if (n_lep > 0) then allocate (photon_mask(n1,n_lep)) do i = 1, n1 photon_mask(i,:) = .not. (prt_gam0(i) .match. prt_lep(:)) end do allocate (delta_r (n_lep-1), index (n_lep-1), p_lep(n_lep-1)) EM_ISOLATION: do i = 1, n1 pt_gam = transverse_part (p_gam0(i)) p_lep = pack (p_lep0, photon_mask(i,:)) delta_r(1:n_lep-1) = sort (eta_phi_distance (p_gam0(i), p_lep(1:n_lep-1))) index(1:n_lep-1) = order (eta_phi_distance (p_gam0(i), p_lep(1:n_lep-1))) n_delta = count (delta_r < r0) allocate (et_sum(n_delta)) do j = 1, n_delta et_sum(j) = sum (transverse_part (p_lep (index(1:j)))) if (.not. et_sum(j) <= & iso_chi_gamma (delta_r(j), r0, iso_n, eps, pt_gam)) then lval = .false. return end if end do deallocate (et_sum) end do EM_ISOLATION deallocate (delta_r) deallocate (index) end if contains function iso_chi_gamma (dr, r0_gam, n_gam, eps_gam, pt_gam) result (iso) real(default) :: iso real(default), intent(in) :: dr, r0_gam, n_gam, eps_gam, pt_gam iso = eps_gam * pt_gam if (.not. nearly_equal (abs(n_gam), 0._default)) then iso = iso * ((1._default - cos(dr)) / & (1._default - cos(r0_gam)))**abs(n_gam) end if end function iso_chi_gamma end function photon_isolation_pp @ %def photon_isolation_pp @ This function evaluates an observable for a pair of particles. From the two particle lists, we take the first pair without [[src]] overlap. If there is no valid pair, we revert the status of the value to unknown. <>= subroutine eval_pp (en1, en2, en0, rval, is_known) type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout) :: en0 real(default), intent(out) :: rval logical, intent(out) :: is_known integer :: i, j, n1, n2 n1 = en1%pval%get_length () n2 = en2%pval%get_length () rval = 0 is_known = .false. LOOP1: do i = 1, n1 en0%index = i en0%prt1 = en1%pval%get_prt (i) do j = 1, n2 en0%prt2 = en2%pval%get_prt (j) if (are_disjoint (en0%prt1, en0%prt2)) then call eval_node_evaluate (en0) rval = en0%rval is_known = .true. exit LOOP1 end if end do end do LOOP1 end subroutine eval_pp @ %def eval_ppp @ The following function returns an integer value, namely the number of valid particle-pairs from both lists for which the condition is true. Invalid pairs (with common [[src]] entry) are ignored. If there is no condition, it returns the number of valid particle pairs. <>= subroutine count_pp (ival, en1, en2, en0) integer, intent(out) :: ival type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout), optional :: en0 integer :: i, j, n1, n2, count n1 = en1%pval%get_length () n2 = en2%pval%get_length () if (present (en0)) then count = 0 do i = 1, n1 en0%index = i en0%prt1 = en1%pval%get_prt (i) do j = 1, n2 en0%prt2 = en2%pval%get_prt (j) if (are_disjoint (en0%prt1, en0%prt2)) then call eval_node_evaluate (en0) if (en0%lval) count = count + 1 end if end do end do else count = 0 do i = 1, n1 do j = 1, n2 if (are_disjoint (en1%pval%get_prt (i), & en2%pval%get_prt (j))) then count = count + 1 end if end do end do end if ival = count end subroutine count_pp @ %def count_pp @ This function makes up a subevent from the second argument which consists only of particles which match the PDG code array (first argument). <>= subroutine select_pdg_ca (subevt, en1, en2, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout), optional :: en0 if (present (en0)) then call subevt_select_pdg_code (subevt, en1%aval, en2%pval, en0%ival) else call subevt_select_pdg_code (subevt, en1%aval, en2%pval) end if end subroutine select_pdg_ca @ %def select_pdg_ca @ \subsubsection{Binary string functions} Currently, the only string operation is concatenation. <>= subroutine concat_ss (string, en1, en2) type(string_t), intent(out) :: string type(eval_node_t), intent(in) :: en1, en2 string = en1%sval // en2%sval end subroutine concat_ss @ %def concat_ss @ \subsection{Compiling the parse tree} The evaluation tree is built recursively by following a parse tree. Evaluate an expression. The requested type is given as an optional argument; default is numeric (integer or real). <>= recursive subroutine eval_node_compile_genexpr & (en, pn, var_list, result_type) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list integer, intent(in), optional :: result_type if (debug_active (D_MODEL_F)) then print *, "read genexpr"; call parse_node_write (pn) end if if (present (result_type)) then select case (result_type) case (V_INT, V_REAL, V_CMPLX) call eval_node_compile_expr (en, pn, var_list) case (V_LOG) call eval_node_compile_lexpr (en, pn, var_list) case (V_SEV) call eval_node_compile_pexpr (en, pn, var_list) case (V_PDG) call eval_node_compile_cexpr (en, pn, var_list) case (V_STR) call eval_node_compile_sexpr (en, pn, var_list) end select else call eval_node_compile_expr (en, pn, var_list) end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done genexpr" end if end subroutine eval_node_compile_genexpr @ %def eval_node_compile_genexpr @ \subsubsection{Numeric expressions} This procedure compiles a numerical expression. This is a single term or a sum or difference of terms. We have to account for all combinations of integer and real arguments. If both are constant, we immediately do the calculation and allocate a constant node. <>= recursive subroutine eval_node_compile_expr (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_term, pn_addition, pn_op, pn_arg type(eval_node_t), pointer :: en1, en2 type(string_t) :: key integer :: t1, t2, t if (debug_active (D_MODEL_F)) then print *, "read expr"; call parse_node_write (pn) end if pn_term => parse_node_get_sub_ptr (pn) select case (char (parse_node_get_rule_key (pn_term))) case ("term") call eval_node_compile_term (en, pn_term, var_list) pn_addition => parse_node_get_next_ptr (pn_term, tag="addition") case ("addition") en => null () pn_addition => pn_term case default call parse_node_mismatch ("term|addition", pn) end select do while (associated (pn_addition)) pn_op => parse_node_get_sub_ptr (pn_addition) pn_arg => parse_node_get_next_ptr (pn_op, tag="term") call eval_node_compile_term (en2, pn_arg, var_list) t2 = en2%result_type if (associated (en)) then en1 => en t1 = en1%result_type else allocate (en1) select case (t2) case (V_INT); call eval_node_init_int (en1, 0) case (V_REAL); call eval_node_init_real (en1, 0._default) case (V_CMPLX); call eval_node_init_cmplx (en1, cmplx & (0._default, 0._default, kind=default)) end select t1 = t2 end if t = numeric_result_type (t1, t2) allocate (en) key = parse_node_get_key (pn_op) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then select case (char (key)) case ("+") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_int (en, add_ii (en1, en2)) case (V_REAL); call eval_node_init_real (en, add_ir (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, add_ic (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_real (en, add_ri (en1, en2)) case (V_REAL); call eval_node_init_real (en, add_rr (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, add_rc (en1, en2)) end select case (V_CMPLX) select case (t2) case (V_INT); call eval_node_init_cmplx (en, add_ci (en1, en2)) case (V_REAL); call eval_node_init_cmplx (en, add_cr (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, add_cc (en1, en2)) end select end select case ("-") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_int (en, sub_ii (en1, en2)) case (V_REAL); call eval_node_init_real (en, sub_ir (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, sub_ic (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_real (en, sub_ri (en1, en2)) case (V_REAL); call eval_node_init_real (en, sub_rr (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, sub_rc (en1, en2)) end select case (V_CMPLX) select case (t2) case (V_INT); call eval_node_init_cmplx (en, sub_ci (en1, en2)) case (V_REAL); call eval_node_init_cmplx (en, sub_cr (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, sub_cc (en1, en2)) end select end select end select call eval_node_final_rec (en1) call eval_node_final_rec (en2) deallocate (en1, en2) else call eval_node_init_branch (en, key, t, en1, en2) select case (char (key)) case ("+") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_int (en, add_ii) case (V_REAL); call eval_node_set_op2_real (en, add_ir) case (V_CMPLX); call eval_node_set_op2_cmplx (en, add_ic) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_real (en, add_ri) case (V_REAL); call eval_node_set_op2_real (en, add_rr) case (V_CMPLX); call eval_node_set_op2_cmplx (en, add_rc) end select case (V_CMPLX) select case (t2) case (V_INT); call eval_node_set_op2_cmplx (en, add_ci) case (V_REAL); call eval_node_set_op2_cmplx (en, add_cr) case (V_CMPLX); call eval_node_set_op2_cmplx (en, add_cc) end select end select case ("-") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_int (en, sub_ii) case (V_REAL); call eval_node_set_op2_real (en, sub_ir) case (V_CMPLX); call eval_node_set_op2_cmplx (en, sub_ic) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_real (en, sub_ri) case (V_REAL); call eval_node_set_op2_real (en, sub_rr) case (V_CMPLX); call eval_node_set_op2_cmplx (en, sub_rc) end select case (V_CMPLX) select case (t2) case (V_INT); call eval_node_set_op2_cmplx (en, sub_ci) case (V_REAL); call eval_node_set_op2_cmplx (en, sub_cr) case (V_CMPLX); call eval_node_set_op2_cmplx (en, sub_cc) end select end select end select end if pn_addition => parse_node_get_next_ptr (pn_addition) end do if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done expr" end if end subroutine eval_node_compile_expr @ %def eval_node_compile_expr <>= recursive subroutine eval_node_compile_term (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_factor, pn_multiplication, pn_op, pn_arg type(eval_node_t), pointer :: en1, en2 type(string_t) :: key integer :: t1, t2, t if (debug_active (D_MODEL_F)) then print *, "read term"; call parse_node_write (pn) end if pn_factor => parse_node_get_sub_ptr (pn, tag="factor") call eval_node_compile_factor (en, pn_factor, var_list) pn_multiplication => & parse_node_get_next_ptr (pn_factor, tag="multiplication") do while (associated (pn_multiplication)) pn_op => parse_node_get_sub_ptr (pn_multiplication) pn_arg => parse_node_get_next_ptr (pn_op, tag="factor") en1 => en call eval_node_compile_factor (en2, pn_arg, var_list) t1 = en1%result_type t2 = en2%result_type t = numeric_result_type (t1, t2) allocate (en) key = parse_node_get_key (pn_op) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then select case (char (key)) case ("*") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_int (en, mul_ii (en1, en2)) case (V_REAL); call eval_node_init_real (en, mul_ir (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, mul_ic (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_real (en, mul_ri (en1, en2)) case (V_REAL); call eval_node_init_real (en, mul_rr (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, mul_rc (en1, en2)) end select case (V_CMPLX) select case (t2) case (V_INT); call eval_node_init_cmplx (en, mul_ci (en1, en2)) case (V_REAL); call eval_node_init_cmplx (en, mul_cr (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, mul_cc (en1, en2)) end select end select case ("/") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_int (en, div_ii (en1, en2)) case (V_REAL); call eval_node_init_real (en, div_ir (en1, en2)) case (V_CMPLX); call eval_node_init_real (en, div_ir (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_real (en, div_ri (en1, en2)) case (V_REAL); call eval_node_init_real (en, div_rr (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, div_rc (en1, en2)) end select case (V_CMPLX) select case (t2) case (V_INT); call eval_node_init_cmplx (en, div_ci (en1, en2)) case (V_REAL); call eval_node_init_cmplx (en, div_cr (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, div_cc (en1, en2)) end select end select end select call eval_node_final_rec (en1) call eval_node_final_rec (en2) deallocate (en1, en2) else call eval_node_init_branch (en, key, t, en1, en2) select case (char (key)) case ("*") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_int (en, mul_ii) case (V_REAL); call eval_node_set_op2_real (en, mul_ir) case (V_CMPLX); call eval_node_set_op2_cmplx (en, mul_ic) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_real (en, mul_ri) case (V_REAL); call eval_node_set_op2_real (en, mul_rr) case (V_CMPLX); call eval_node_set_op2_cmplx (en, mul_rc) end select case (V_CMPLX) select case (t2) case (V_INT); call eval_node_set_op2_cmplx (en, mul_ci) case (V_REAL); call eval_node_set_op2_cmplx (en, mul_cr) case (V_CMPLX); call eval_node_set_op2_cmplx (en, mul_cc) end select end select case ("/") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_int (en, div_ii) case (V_REAL); call eval_node_set_op2_real (en, div_ir) case (V_CMPLX); call eval_node_set_op2_cmplx (en, div_ic) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_real (en, div_ri) case (V_REAL); call eval_node_set_op2_real (en, div_rr) case (V_CMPLX); call eval_node_set_op2_cmplx (en, div_rc) end select case (V_CMPLX) select case (t2) case (V_INT); call eval_node_set_op2_cmplx (en, div_ci) case (V_REAL); call eval_node_set_op2_cmplx (en, div_cr) case (V_CMPLX); call eval_node_set_op2_cmplx (en, div_cc) end select end select end select end if pn_multiplication => parse_node_get_next_ptr (pn_multiplication) end do if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done term" end if end subroutine eval_node_compile_term @ %def eval_node_compile_term <>= recursive subroutine eval_node_compile_factor (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_value, pn_exponentiation, pn_op, pn_arg type(eval_node_t), pointer :: en1, en2 type(string_t) :: key integer :: t1, t2, t if (debug_active (D_MODEL_F)) then print *, "read factor"; call parse_node_write (pn) end if pn_value => parse_node_get_sub_ptr (pn) call eval_node_compile_signed_value (en, pn_value, var_list) pn_exponentiation => & parse_node_get_next_ptr (pn_value, tag="exponentiation") if (associated (pn_exponentiation)) then pn_op => parse_node_get_sub_ptr (pn_exponentiation) pn_arg => parse_node_get_next_ptr (pn_op) en1 => en call eval_node_compile_signed_value (en2, pn_arg, var_list) t1 = en1%result_type t2 = en2%result_type t = numeric_result_type (t1, t2) allocate (en) key = parse_node_get_key (pn_op) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_int (en, pow_ii (en1, en2)) case (V_REAL); call eval_node_init_real (en, pow_ir (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, pow_ic (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_real (en, pow_ri (en1, en2)) case (V_REAL); call eval_node_init_real (en, pow_rr (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, pow_rc (en1, en2)) end select case (V_CMPLX) select case (t2) case (V_INT); call eval_node_init_cmplx (en, pow_ci (en1, en2)) case (V_REAL); call eval_node_init_cmplx (en, pow_cr (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, pow_cc (en1, en2)) end select end select call eval_node_final_rec (en1) call eval_node_final_rec (en2) deallocate (en1, en2) else call eval_node_init_branch (en, key, t, en1, en2) select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_int (en, pow_ii) case (V_REAL,V_CMPLX); call eval_type_error (pn, "exponentiation", t1) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_real (en, pow_ri) case (V_REAL); call eval_node_set_op2_real (en, pow_rr) case (V_CMPLX); call eval_type_error (pn, "exponentiation", t1) end select case (V_CMPLX) select case (t2) case (V_INT); call eval_node_set_op2_cmplx (en, pow_ci) case (V_REAL); call eval_node_set_op2_cmplx (en, pow_cr) case (V_CMPLX); call eval_node_set_op2_cmplx (en, pow_cc) end select end select end if end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done factor" end if end subroutine eval_node_compile_factor @ %def eval_node_compile_factor <>= recursive subroutine eval_node_compile_signed_value (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_arg type(eval_node_t), pointer :: en1 integer :: t if (debug_active (D_MODEL_F)) then print *, "read signed value"; call parse_node_write (pn) end if select case (char (parse_node_get_rule_key (pn))) case ("signed_value") pn_arg => parse_node_get_sub_ptr (pn, 2) call eval_node_compile_value (en1, pn_arg, var_list) t = en1%result_type allocate (en) if (en1%type == EN_CONSTANT) then select case (t) case (V_INT); call eval_node_init_int (en, neg_i (en1)) case (V_REAL); call eval_node_init_real (en, neg_r (en1)) case (V_CMPLX); call eval_node_init_cmplx (en, neg_c (en1)) end select call eval_node_final_rec (en1) deallocate (en1) else call eval_node_init_branch (en, var_str ("-"), t, en1) select case (t) case (V_INT); call eval_node_set_op1_int (en, neg_i) case (V_REAL); call eval_node_set_op1_real (en, neg_r) case (V_CMPLX); call eval_node_set_op1_cmplx (en, neg_c) end select end if case default call eval_node_compile_value (en, pn, var_list) end select if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done signed value" end if end subroutine eval_node_compile_signed_value @ %def eval_node_compile_signed_value @ Integer, real and complex values have an optional unit. The unit is extracted and applied immediately. An integer with unit evaluates to a real constant. <>= recursive subroutine eval_node_compile_value (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list if (debug_active (D_MODEL_F)) then print *, "read value"; call parse_node_write (pn) end if select case (char (parse_node_get_rule_key (pn))) case ("integer_value", "real_value", "complex_value") call eval_node_compile_numeric_value (en, pn) case ("pi") call eval_node_compile_constant (en, pn) case ("I") call eval_node_compile_constant (en, pn) case ("variable") call eval_node_compile_variable (en, pn, var_list) case ("result") call eval_node_compile_result (en, pn, var_list) case ("expr") call eval_node_compile_expr (en, pn, var_list) case ("block_expr") call eval_node_compile_block_expr (en, pn, var_list) case ("conditional_expr") call eval_node_compile_conditional (en, pn, var_list) case ("unary_function") call eval_node_compile_unary_function (en, pn, var_list) case ("binary_function") call eval_node_compile_binary_function (en, pn, var_list) case ("eval_fun") call eval_node_compile_eval_function (en, pn, var_list) case ("count_fun") call eval_node_compile_count_function (en, pn, var_list) case ("sum_fun", "prod_fun") call eval_node_compile_numeric_function (en, pn, var_list) case default call parse_node_mismatch & ("integer|real|complex|constant|variable|" // & "expr|block_expr|conditional_expr|" // & "unary_function|binary_function|numeric_pexpr", pn) end select if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done value" end if end subroutine eval_node_compile_value @ %def eval_node_compile_value @ Real, complex and integer values are numeric literals with an optional unit attached. In case of an integer, the unit actually makes it a real value in disguise. The signed version of real values is not possible in generic expressions; it is a special case for numeric constants in model files (see below). We do not introduce signed versions of complex values. <>= subroutine eval_node_compile_numeric_value (en, pn) type(eval_node_t), pointer :: en type(parse_node_t), intent(in), target :: pn type(parse_node_t), pointer :: pn_val, pn_unit allocate (en) pn_val => parse_node_get_sub_ptr (pn) pn_unit => parse_node_get_next_ptr (pn_val) select case (char (parse_node_get_rule_key (pn))) case ("integer_value") if (associated (pn_unit)) then call eval_node_init_real (en, & parse_node_get_integer (pn_val) * parse_node_get_unit (pn_unit)) else call eval_node_init_int (en, parse_node_get_integer (pn_val)) end if case ("real_value") if (associated (pn_unit)) then call eval_node_init_real (en, & parse_node_get_real (pn_val) * parse_node_get_unit (pn_unit)) else call eval_node_init_real (en, parse_node_get_real (pn_val)) end if case ("complex_value") if (associated (pn_unit)) then call eval_node_init_cmplx (en, & parse_node_get_cmplx (pn_val) * parse_node_get_unit (pn_unit)) else call eval_node_init_cmplx (en, parse_node_get_cmplx (pn_val)) end if case ("neg_real_value") pn_val => parse_node_get_sub_ptr (parse_node_get_sub_ptr (pn, 2)) pn_unit => parse_node_get_next_ptr (pn_val) if (associated (pn_unit)) then call eval_node_init_real (en, & - parse_node_get_real (pn_val) * parse_node_get_unit (pn_unit)) else call eval_node_init_real (en, - parse_node_get_real (pn_val)) end if case ("pos_real_value") pn_val => parse_node_get_sub_ptr (parse_node_get_sub_ptr (pn, 2)) pn_unit => parse_node_get_next_ptr (pn_val) if (associated (pn_unit)) then call eval_node_init_real (en, & parse_node_get_real (pn_val) * parse_node_get_unit (pn_unit)) else call eval_node_init_real (en, parse_node_get_real (pn_val)) end if case default call parse_node_mismatch & ("integer_value|real_value|complex_value|neg_real_value|pos_real_value", pn) end select end subroutine eval_node_compile_numeric_value @ %def eval_node_compile_numeric_value @ These are the units, predefined and hardcoded. The default energy unit is GeV, the default angular unit is radians. We include units for observables of dimension energy squared. Luminosities are normalized in inverse femtobarns. <>= function parse_node_get_unit (pn) result (factor) real(default) :: factor real(default) :: unit type(parse_node_t), intent(in) :: pn type(parse_node_t), pointer :: pn_unit, pn_unit_power type(parse_node_t), pointer :: pn_frac, pn_num, pn_int, pn_div, pn_den integer :: num, den pn_unit => parse_node_get_sub_ptr (pn) select case (char (parse_node_get_key (pn_unit))) case ("TeV"); unit = 1.e3_default case ("GeV"); unit = 1 case ("MeV"); unit = 1.e-3_default case ("keV"); unit = 1.e-6_default case ("eV"); unit = 1.e-9_default case ("meV"); unit = 1.e-12_default case ("nbarn"); unit = 1.e6_default case ("pbarn"); unit = 1.e3_default case ("fbarn"); unit = 1 case ("abarn"); unit = 1.e-3_default case ("rad"); unit = 1 case ("mrad"); unit = 1.e-3_default case ("degree"); unit = degree case ("%"); unit = 1.e-2_default case default call msg_bug (" Unit '" // & char (parse_node_get_key (pn)) // "' is undefined.") end select pn_unit_power => parse_node_get_next_ptr (pn_unit) if (associated (pn_unit_power)) then pn_frac => parse_node_get_sub_ptr (pn_unit_power, 2) pn_num => parse_node_get_sub_ptr (pn_frac) select case (char (parse_node_get_rule_key (pn_num))) case ("neg_int") pn_int => parse_node_get_sub_ptr (pn_num, 2) num = - parse_node_get_integer (pn_int) case ("pos_int") pn_int => parse_node_get_sub_ptr (pn_num, 2) num = parse_node_get_integer (pn_int) case ("integer_literal") num = parse_node_get_integer (pn_num) case default call parse_node_mismatch ("neg_int|pos_int|integer_literal", pn_num) end select pn_div => parse_node_get_next_ptr (pn_num) if (associated (pn_div)) then pn_den => parse_node_get_sub_ptr (pn_div, 2) den = parse_node_get_integer (pn_den) else den = 1 end if else num = 1 den = 1 end if factor = unit ** (real (num, default) / den) end function parse_node_get_unit @ %def parse_node_get_unit @ There are only two predefined constants, but more can be added easily. <>= subroutine eval_node_compile_constant (en, pn) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn if (debug_active (D_MODEL_F)) then print *, "read constant"; call parse_node_write (pn) end if allocate (en) select case (char (parse_node_get_key (pn))) case ("pi"); call eval_node_init_real (en, pi) case ("I"); call eval_node_init_cmplx (en, imago) case default call parse_node_mismatch ("pi or I", pn) end select if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done constant" end if end subroutine eval_node_compile_constant @ %def eval_node_compile_constant @ Compile a variable, with or without a specified type. Take the list of variables, look for the name and make a node with a pointer to the value. If no type is provided, the variable is numeric, and the stored value determines whether it is real or integer. We explicitly demand that the variable is defined, so we do not accidentally point to variables that are declared only later in the script but have come into existence in a previous compilation pass. Variables may actually be anonymous, these are expressions in disguise. In that case, the expression replaces the variable name in the parse tree, and we allocate an ordinary expression node in the eval tree. Variables of type [[V_PDG]] (pdg-code array) are not treated here. They are handled by [[eval_node_compile_cvariable]]. <>= recursive subroutine eval_node_compile_variable (en, pn, var_list, var_type) type(eval_node_t), pointer :: en type(parse_node_t), intent(in), target :: pn type(var_list_t), intent(in), target :: var_list integer, intent(in), optional :: var_type type(parse_node_t), pointer :: pn_name type(string_t) :: var_name logical, target, save :: no_lval real(default), target, save :: no_rval type(subevt_t), target, save :: no_pval type(string_t), target, save :: no_sval logical, target, save :: unknown = .false. integer :: type logical :: defined logical, pointer :: known logical, pointer :: lptr integer, pointer :: iptr real(default), pointer :: rptr complex(default), pointer :: cptr type(subevt_t), pointer :: pptr type(string_t), pointer :: sptr procedure(obs_unary_int), pointer :: obs1_iptr procedure(obs_unary_real), pointer :: obs1_rptr procedure(obs_binary_int), pointer :: obs2_iptr procedure(obs_binary_real), pointer :: obs2_rptr procedure(obs_sev_int), pointer :: obsev_iptr procedure(obs_sev_real), pointer :: obsev_rptr type(prt_t), pointer :: p1, p2 if (debug_active (D_MODEL_F)) then print *, "read variable"; call parse_node_write (pn) end if if (present (var_type)) then select case (var_type) case (V_REAL, V_OBS1_REAL, V_OBS2_REAL, V_INT, V_OBS1_INT, & V_OBS2_INT, V_CMPLX) pn_name => pn case default pn_name => parse_node_get_sub_ptr (pn, 2) end select else pn_name => pn end if select case (char (parse_node_get_rule_key (pn_name))) case ("expr") call eval_node_compile_expr (en, pn_name, var_list) case ("lexpr") call eval_node_compile_lexpr (en, pn_name, var_list) case ("sexpr") call eval_node_compile_sexpr (en, pn_name, var_list) case ("pexpr") call eval_node_compile_pexpr (en, pn_name, var_list) case ("variable") var_name = parse_node_get_string (pn_name) if (present (var_type)) then select case (var_type) case (V_LOG); var_name = "?" // var_name case (V_SEV); var_name = "@" // var_name case (V_STR); var_name = "$" // var_name ! $ sign end select end if call var_list%get_var_properties & (var_name, req_type=var_type, type=type, is_defined=defined) allocate (en) if (defined) then select case (type) case (V_LOG) call var_list%get_lptr (var_name, lptr, known) call eval_node_init_log_ptr (en, var_name, lptr, known) case (V_INT) call var_list%get_iptr (var_name, iptr, known) call eval_node_init_int_ptr (en, var_name, iptr, known) case (V_REAL) call var_list%get_rptr (var_name, rptr, known) call eval_node_init_real_ptr (en, var_name, rptr, known) case (V_CMPLX) call var_list%get_cptr (var_name, cptr, known) call eval_node_init_cmplx_ptr (en, var_name, cptr, known) case (V_SEV) call var_list%get_pptr (var_name, pptr, known) call eval_node_init_subevt_ptr (en, var_name, pptr, known) case (V_STR) call var_list%get_sptr (var_name, sptr, known) call eval_node_init_string_ptr (en, var_name, sptr, known) case (V_OBS1_INT) call var_list%get_obs1_iptr (var_name, obs1_iptr, p1) call eval_node_init_obs1_int_ptr (en, var_name, obs1_iptr, p1) case (V_OBS2_INT) call var_list%get_obs2_iptr (var_name, obs2_iptr, p1, p2) call eval_node_init_obs2_int_ptr (en, var_name, obs2_iptr, p1, p2) case (V_OBSEV_INT) call var_list%get_obsev_iptr (var_name, obsev_iptr, pptr) call eval_node_init_obsev_int_ptr (en, var_name, obsev_iptr, pptr) case (V_OBS1_REAL) call var_list%get_obs1_rptr (var_name, obs1_rptr, p1) call eval_node_init_obs1_real_ptr (en, var_name, obs1_rptr, p1) case (V_OBS2_REAL) call var_list%get_obs2_rptr (var_name, obs2_rptr, p1, p2) call eval_node_init_obs2_real_ptr (en, var_name, obs2_rptr, p1, p2) case (V_OBSEV_REAL) call var_list%get_obsev_rptr (var_name, obsev_rptr, pptr) call eval_node_init_obsev_real_ptr (en, var_name, obsev_rptr, pptr) case default call parse_node_write (pn) call msg_fatal ("Variable of this type " // & "is not allowed in the present context") if (present (var_type)) then select case (var_type) case (V_LOG) call eval_node_init_log_ptr (en, var_name, no_lval, unknown) case (V_SEV) call eval_node_init_subevt_ptr & (en, var_name, no_pval, unknown) case (V_STR) call eval_node_init_string_ptr & (en, var_name, no_sval, unknown) end select else call eval_node_init_real_ptr (en, var_name, no_rval, unknown) end if end select else call parse_node_write (pn) call msg_error ("This variable is undefined at this point") if (present (var_type)) then select case (var_type) case (V_LOG) call eval_node_init_log_ptr (en, var_name, no_lval, unknown) case (V_SEV) call eval_node_init_subevt_ptr & (en, var_name, no_pval, unknown) case (V_STR) call eval_node_init_string_ptr (en, var_name, no_sval, unknown) end select else call eval_node_init_real_ptr (en, var_name, no_rval, unknown) end if end if end select if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done variable" end if end subroutine eval_node_compile_variable @ %def eval_node_compile_variable @ In a given context, a variable has to have a certain type. <>= subroutine check_var_type (pn, ok, type_actual, type_requested) type(parse_node_t), intent(in) :: pn logical, intent(out) :: ok integer, intent(in) :: type_actual integer, intent(in), optional :: type_requested if (present (type_requested)) then select case (type_requested) case (V_LOG) select case (type_actual) case (V_LOG) case default call parse_node_write (pn) call msg_fatal ("Variable type is invalid (should be logical)") ok = .false. end select case (V_SEV) select case (type_actual) case (V_SEV) case default call parse_node_write (pn) call msg_fatal & ("Variable type is invalid (should be particle set)") ok = .false. end select case (V_PDG) select case (type_actual) case (V_PDG) case default call parse_node_write (pn) call msg_fatal & ("Variable type is invalid (should be PDG array)") ok = .false. end select case (V_STR) select case (type_actual) case (V_STR) case default call parse_node_write (pn) call msg_fatal & ("Variable type is invalid (should be string)") ok = .false. end select case default call parse_node_write (pn) call msg_bug ("Variable type is unknown") end select else select case (type_actual) case (V_REAL, V_OBS1_REAL, V_OBS2_REAL, V_INT, V_OBS1_INT, & V_OBS2_INT, V_CMPLX) case default call parse_node_write (pn) call msg_fatal ("Variable type is invalid (should be numeric)") ok = .false. end select end if ok = .true. end subroutine check_var_type @ %def check_var_type @ Retrieve the result of an integration. If the requested process has been integrated, the results are available as special variables. (The variables cannot be accessed in the usual way since they contain brackets in their names.) Since this compilation step may occur before the processes have been loaded, we have to initialize the required variables before they are used. <>= subroutine eval_node_compile_result (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in), target :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_key, pn_prc_id type(string_t) :: key, prc_id, var_name integer, pointer :: iptr real(default), pointer :: rptr logical, pointer :: known if (debug_active (D_MODEL_F)) then print *, "read result"; call parse_node_write (pn) end if pn_key => parse_node_get_sub_ptr (pn) pn_prc_id => parse_node_get_next_ptr (pn_key) key = parse_node_get_key (pn_key) prc_id = parse_node_get_string (pn_prc_id) var_name = key // "(" // prc_id // ")" if (var_list%contains (var_name)) then allocate (en) select case (char(key)) case ("num_id", "n_calls") call var_list%get_iptr (var_name, iptr, known) call eval_node_init_int_ptr (en, var_name, iptr, known) case ("integral", "error") call var_list%get_rptr (var_name, rptr, known) call eval_node_init_real_ptr (en, var_name, rptr, known) end select else call msg_fatal ("Result variable '" // char (var_name) & // "' is undefined (call 'integrate' before use)") end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done result" end if end subroutine eval_node_compile_result @ %def eval_node_compile_result @ Functions with a single argument. For non-constant arguments, watch for functions which convert their argument to a different type. <>= recursive subroutine eval_node_compile_unary_function (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_fname, pn_arg type(eval_node_t), pointer :: en1 type(string_t) :: key integer :: t if (debug_active (D_MODEL_F)) then print *, "read unary function"; call parse_node_write (pn) end if pn_fname => parse_node_get_sub_ptr (pn) pn_arg => parse_node_get_next_ptr (pn_fname, tag="function_arg1") call eval_node_compile_expr & (en1, parse_node_get_sub_ptr (pn_arg, tag="expr"), var_list) t = en1%result_type allocate (en) key = parse_node_get_key (pn_fname) if (en1%type == EN_CONSTANT) then select case (char (key)) case ("complex") select case (t) case (V_INT); call eval_node_init_cmplx (en, cmplx_i (en1)) case (V_REAL); call eval_node_init_cmplx (en, cmplx_r (en1)) case (V_CMPLX); deallocate (en); en => en1; en1 => null () case default; call eval_type_error (pn, char (key), t) end select case ("real") select case (t) case (V_INT); call eval_node_init_real (en, real_i (en1)) case (V_REAL); deallocate (en); en => en1; en1 => null () case (V_CMPLX); call eval_node_init_real (en, real_c (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("int") select case (t) case (V_INT); deallocate (en); en => en1; en1 => null () case (V_REAL); call eval_node_init_int (en, int_r (en1)) case (V_CMPLX); call eval_node_init_int (en, int_c (en1)) end select case ("nint") select case (t) case (V_INT); deallocate (en); en => en1; en1 => null () case (V_REAL); call eval_node_init_int (en, nint_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("floor") select case (t) case (V_INT); deallocate (en); en => en1; en1 => null () case (V_REAL); call eval_node_init_int (en, floor_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("ceiling") select case (t) case (V_INT); deallocate (en); en => en1; en1 => null () case (V_REAL); call eval_node_init_int (en, ceiling_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("abs") select case (t) case (V_INT); call eval_node_init_int (en, abs_i (en1)) case (V_REAL); call eval_node_init_real (en, abs_r (en1)) case (V_CMPLX); call eval_node_init_real (en, abs_c (en1)) end select case ("conjg") select case (t) case (V_INT); call eval_node_init_int (en, conjg_i (en1)) case (V_REAL); call eval_node_init_real (en, conjg_r (en1)) case (V_CMPLX); call eval_node_init_cmplx (en, conjg_c (en1)) end select case ("sgn") select case (t) case (V_INT); call eval_node_init_int (en, sgn_i (en1)) case (V_REAL); call eval_node_init_real (en, sgn_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("sqrt") select case (t) case (V_REAL); call eval_node_init_real (en, sqrt_r (en1)) case (V_CMPLX); call eval_node_init_cmplx (en, sqrt_c (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("exp") select case (t) case (V_REAL); call eval_node_init_real (en, exp_r (en1)) case (V_CMPLX); call eval_node_init_cmplx (en, exp_c (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("log") select case (t) case (V_REAL); call eval_node_init_real (en, log_r (en1)) case (V_CMPLX); call eval_node_init_cmplx (en, log_c (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("log10") select case (t) case (V_REAL); call eval_node_init_real (en, log10_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("sin") select case (t) case (V_REAL); call eval_node_init_real (en, sin_r (en1)) case (V_CMPLX); call eval_node_init_cmplx (en, sin_c (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("cos") select case (t) case (V_REAL); call eval_node_init_real (en, cos_r (en1)) case (V_CMPLX); call eval_node_init_cmplx (en, cos_c (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("tan") select case (t) case (V_REAL); call eval_node_init_real (en, tan_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("asin") select case (t) case (V_REAL); call eval_node_init_real (en, asin_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("acos") select case (t) case (V_REAL); call eval_node_init_real (en, acos_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("atan") select case (t) case (V_REAL); call eval_node_init_real (en, atan_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("sinh") select case (t) case (V_REAL); call eval_node_init_real (en, sinh_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("cosh") select case (t) case (V_REAL); call eval_node_init_real (en, cosh_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("tanh") select case (t) case (V_REAL); call eval_node_init_real (en, tanh_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("asinh") select case (t) case (V_REAL); call eval_node_init_real (en, asinh_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("acosh") select case (t) case (V_REAL); call eval_node_init_real (en, acosh_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("atanh") select case (t) case (V_REAL); call eval_node_init_real (en, atanh_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case default call parse_node_mismatch ("function name", pn_fname) end select if (associated (en1)) then call eval_node_final_rec (en1) deallocate (en1) end if else select case (char (key)) case ("complex") call eval_node_init_branch (en, key, V_CMPLX, en1) case ("real") call eval_node_init_branch (en, key, V_REAL, en1) case ("int", "nint", "floor", "ceiling") call eval_node_init_branch (en, key, V_INT, en1) case default call eval_node_init_branch (en, key, t, en1) end select select case (char (key)) case ("complex") select case (t) case (V_INT); call eval_node_set_op1_cmplx (en, cmplx_i) case (V_REAL); call eval_node_set_op1_cmplx (en, cmplx_r) case (V_CMPLX); deallocate (en); en => en1 case default; call eval_type_error (pn, char (key), t) end select case ("real") select case (t) case (V_INT); call eval_node_set_op1_real (en, real_i) case (V_REAL); deallocate (en); en => en1 case (V_CMPLX); call eval_node_set_op1_real (en, real_c) case default; call eval_type_error (pn, char (key), t) end select case ("int") select case (t) case (V_INT); deallocate (en); en => en1 case (V_REAL); call eval_node_set_op1_int (en, int_r) case (V_CMPLX); call eval_node_set_op1_int (en, int_c) end select case ("nint") select case (t) case (V_INT); deallocate (en); en => en1 case (V_REAL); call eval_node_set_op1_int (en, nint_r) case default; call eval_type_error (pn, char (key), t) end select case ("floor") select case (t) case (V_INT); deallocate (en); en => en1 case (V_REAL); call eval_node_set_op1_int (en, floor_r) case default; call eval_type_error (pn, char (key), t) end select case ("ceiling") select case (t) case (V_INT); deallocate (en); en => en1 case (V_REAL); call eval_node_set_op1_int (en, ceiling_r) case default; call eval_type_error (pn, char (key), t) end select case ("abs") select case (t) case (V_INT); call eval_node_set_op1_int (en, abs_i) case (V_REAL); call eval_node_set_op1_real (en, abs_r) case (V_CMPLX); call eval_node_init_branch (en, key, V_REAL, en1) call eval_node_set_op1_real (en, abs_c) end select case ("conjg") select case (t) case (V_INT); call eval_node_set_op1_int (en, conjg_i) case (V_REAL); call eval_node_set_op1_real (en, conjg_r) case (V_CMPLX); call eval_node_set_op1_cmplx (en, conjg_c) end select case ("sgn") select case (t) case (V_INT); call eval_node_set_op1_int (en, sgn_i) case (V_REAL); call eval_node_set_op1_real (en, sgn_r) case default; call eval_type_error (pn, char (key), t) end select case ("sqrt") select case (t) case (V_REAL); call eval_node_set_op1_real (en, sqrt_r) case (V_CMPLX); call eval_node_set_op1_cmplx (en, sqrt_c) case default; call eval_type_error (pn, char (key), t) end select case ("exp") select case (t) case (V_REAL); call eval_node_set_op1_real (en, exp_r) case (V_CMPLX); call eval_node_set_op1_cmplx (en, exp_c) case default; call eval_type_error (pn, char (key), t) end select case ("log") select case (t) case (V_REAL); call eval_node_set_op1_real (en, log_r) case (V_CMPLX); call eval_node_set_op1_cmplx (en, log_c) case default; call eval_type_error (pn, char (key), t) end select case ("log10") select case (t) case (V_REAL); call eval_node_set_op1_real (en, log10_r) case default; call eval_type_error (pn, char (key), t) end select case ("sin") select case (t) case (V_REAL); call eval_node_set_op1_real (en, sin_r) case (V_CMPLX); call eval_node_set_op1_cmplx (en, sin_c) case default; call eval_type_error (pn, char (key), t) end select case ("cos") select case (t) case (V_REAL); call eval_node_set_op1_real (en, cos_r) case (V_CMPLX); call eval_node_set_op1_cmplx (en, cos_c) case default; call eval_type_error (pn, char (key), t) end select case ("tan") select case (t) case (V_REAL); call eval_node_set_op1_real (en, tan_r) case default; call eval_type_error (pn, char (key), t) end select case ("asin") select case (t) case (V_REAL); call eval_node_set_op1_real (en, asin_r) case default; call eval_type_error (pn, char (key), t) end select case ("acos") select case (t) case (V_REAL); call eval_node_set_op1_real (en, acos_r) case default; call eval_type_error (pn, char (key), t) end select case ("atan") select case (t) case (V_REAL); call eval_node_set_op1_real (en, atan_r) case default; call eval_type_error (pn, char (key), t) end select case ("sinh") select case (t) case (V_REAL); call eval_node_set_op1_real (en, sinh_r) case default; call eval_type_error (pn, char (key), t) end select case ("cosh") select case (t) case (V_REAL); call eval_node_set_op1_real (en, cosh_r) case default; call eval_type_error (pn, char (key), t) end select case ("tanh") select case (t) case (V_REAL); call eval_node_set_op1_real (en, tanh_r) case default; call eval_type_error (pn, char (key), t) end select case ("asinh") select case (t) case (V_REAL); call eval_node_set_op1_real (en, asinh_r) case default; call eval_type_error (pn, char (key), t) end select case ("acosh") select case (t) case (V_REAL); call eval_node_set_op1_real (en, acosh_r) case default; call eval_type_error (pn, char (key), t) end select case ("atanh") select case (t) case (V_REAL); call eval_node_set_op1_real (en, atanh_r) case default; call eval_type_error (pn, char (key), t) end select case default call parse_node_mismatch ("function name", pn_fname) end select end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done function" end if end subroutine eval_node_compile_unary_function @ %def eval_node_compile_unary_function @ Functions with two arguments. <>= recursive subroutine eval_node_compile_binary_function (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_fname, pn_arg, pn_arg1, pn_arg2 type(eval_node_t), pointer :: en1, en2 type(string_t) :: key integer :: t1, t2 if (debug_active (D_MODEL_F)) then print *, "read binary function"; call parse_node_write (pn) end if pn_fname => parse_node_get_sub_ptr (pn) pn_arg => parse_node_get_next_ptr (pn_fname, tag="function_arg2") pn_arg1 => parse_node_get_sub_ptr (pn_arg, tag="expr") pn_arg2 => parse_node_get_next_ptr (pn_arg1, tag="expr") call eval_node_compile_expr (en1, pn_arg1, var_list) call eval_node_compile_expr (en2, pn_arg2, var_list) t1 = en1%result_type t2 = en2%result_type allocate (en) key = parse_node_get_key (pn_fname) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then select case (char (key)) case ("max") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_int (en, max_ii (en1, en2)) case (V_REAL); call eval_node_init_real (en, max_ir (en1, en2)) case default; call eval_type_error (pn, char (key), t2) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_real (en, max_ri (en1, en2)) case (V_REAL); call eval_node_init_real (en, max_rr (en1, en2)) case default; call eval_type_error (pn, char (key), t2) end select case default; call eval_type_error (pn, char (key), t1) end select case ("min") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_int (en, min_ii (en1, en2)) case (V_REAL); call eval_node_init_real (en, min_ir (en1, en2)) case default; call eval_type_error (pn, char (key), t2) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_real (en, min_ri (en1, en2)) case (V_REAL); call eval_node_init_real (en, min_rr (en1, en2)) case default; call eval_type_error (pn, char (key), t2) end select case default; call eval_type_error (pn, char (key), t1) end select case ("mod") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_int (en, mod_ii (en1, en2)) case (V_REAL); call eval_node_init_real (en, mod_ir (en1, en2)) case default; call eval_type_error (pn, char (key), t2) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_real (en, mod_ri (en1, en2)) case (V_REAL); call eval_node_init_real (en, mod_rr (en1, en2)) case default; call eval_type_error (pn, char (key), t2) end select case default; call eval_type_error (pn, char (key), t1) end select case ("modulo") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_int (en, modulo_ii (en1, en2)) case (V_REAL); call eval_node_init_real (en, modulo_ir (en1, en2)) case default; call eval_type_error (pn, char (key), t2) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_real (en, modulo_ri (en1, en2)) case (V_REAL); call eval_node_init_real (en, modulo_rr (en1, en2)) case default; call eval_type_error (pn, char (key), t2) end select case default; call eval_type_error (pn, char (key), t2) end select case default call parse_node_mismatch ("function name", pn_fname) end select call eval_node_final_rec (en1) deallocate (en1) else call eval_node_init_branch (en, key, t1, en1, en2) select case (char (key)) case ("max") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_int (en, max_ii) case (V_REAL); call eval_node_set_op2_real (en, max_ir) case default; call eval_type_error (pn, char (key), t2) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_real (en, max_ri) case (V_REAL); call eval_node_set_op2_real (en, max_rr) case default; call eval_type_error (pn, char (key), t2) end select case default; call eval_type_error (pn, char (key), t2) end select case ("min") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_int (en, min_ii) case (V_REAL); call eval_node_set_op2_real (en, min_ir) case default; call eval_type_error (pn, char (key), t2) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_real (en, min_ri) case (V_REAL); call eval_node_set_op2_real (en, min_rr) case default; call eval_type_error (pn, char (key), t2) end select case default; call eval_type_error (pn, char (key), t2) end select case ("mod") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_int (en, mod_ii) case (V_REAL); call eval_node_set_op2_real (en, mod_ir) case default; call eval_type_error (pn, char (key), t2) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_real (en, mod_ri) case (V_REAL); call eval_node_set_op2_real (en, mod_rr) case default; call eval_type_error (pn, char (key), t2) end select case default; call eval_type_error (pn, char (key), t2) end select case ("modulo") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_int (en, modulo_ii) case (V_REAL); call eval_node_set_op2_real (en, modulo_ir) case default; call eval_type_error (pn, char (key), t2) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_real (en, modulo_ri) case (V_REAL); call eval_node_set_op2_real (en, modulo_rr) case default; call eval_type_error (pn, char (key), t2) end select case default; call eval_type_error (pn, char (key), t2) end select case default call parse_node_mismatch ("function name", pn_fname) end select end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done function" end if end subroutine eval_node_compile_binary_function @ %def eval_node_compile_binary_function @ \subsubsection{Variable definition} A block expression contains a variable definition (first argument) and an expression where the definition can be used (second argument). The [[result_type]] decides which type of expression is expected for the second argument. For numeric variables, if there is a mismatch between real and integer type, insert an extra node for type conversion. <>= recursive subroutine eval_node_compile_block_expr & (en, pn, var_list, result_type) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list integer, intent(in), optional :: result_type type(parse_node_t), pointer :: pn_var_spec, pn_var_subspec type(parse_node_t), pointer :: pn_var_type, pn_var_name, pn_var_expr type(parse_node_t), pointer :: pn_expr type(string_t) :: var_name type(eval_node_t), pointer :: en1, en2 integer :: var_type logical :: new if (debug_active (D_MODEL_F)) then print *, "read block expr"; call parse_node_write (pn) end if new = .false. pn_var_spec => parse_node_get_sub_ptr (pn, 2) select case (char (parse_node_get_rule_key (pn_var_spec))) case ("var_num"); var_type = V_NONE pn_var_name => parse_node_get_sub_ptr (pn_var_spec) case ("var_int"); var_type = V_INT new = .true. pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2) case ("var_real"); var_type = V_REAL new = .true. pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2) case ("var_cmplx"); var_type = V_CMPLX new = .true. pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2) case ("var_logical_new"); var_type = V_LOG new = .true. pn_var_subspec => parse_node_get_sub_ptr (pn_var_spec, 2) pn_var_name => parse_node_get_sub_ptr (pn_var_subspec, 2) case ("var_logical_spec"); var_type = V_LOG pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2) case ("var_plist_new"); var_type = V_SEV new = .true. pn_var_subspec => parse_node_get_sub_ptr (pn_var_spec, 2) pn_var_name => parse_node_get_sub_ptr (pn_var_subspec, 2) case ("var_plist_spec"); var_type = V_SEV new = .true. pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2) case ("var_alias"); var_type = V_PDG new = .true. pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2) case ("var_string_new"); var_type = V_STR new = .true. pn_var_subspec => parse_node_get_sub_ptr (pn_var_spec, 2) pn_var_name => parse_node_get_sub_ptr (pn_var_subspec, 2) case ("var_string_spec"); var_type = V_STR pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2) case default call parse_node_mismatch & ("logical|int|real|plist|alias", pn_var_type) end select pn_var_expr => parse_node_get_next_ptr (pn_var_name, 2) pn_expr => parse_node_get_next_ptr (pn_var_spec, 2) var_name = parse_node_get_string (pn_var_name) select case (var_type) case (V_LOG); var_name = "?" // var_name case (V_SEV); var_name = "@" // var_name case (V_STR); var_name = "$" // var_name ! $ sign end select - call var_list_check_user_var (var_list, var_name, var_type, new) + call var_list%check_user_var (var_name, var_type, new) call eval_node_compile_genexpr (en1, pn_var_expr, var_list, var_type) call insert_conversion_node (en1, var_type) allocate (en) call eval_node_init_block (en, var_name, var_type, en1, var_list) call eval_node_compile_genexpr (en2, pn_expr, en%var_list, result_type) call eval_node_set_expr (en, en2) if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done block expr" end if end subroutine eval_node_compile_block_expr @ %def eval_node_compile_block_expr @ Insert a conversion node for integer/real/complex transformation if necessary. What shall we do for the complex to integer/real conversion? <>= subroutine insert_conversion_node (en, result_type) type(eval_node_t), pointer :: en integer, intent(in) :: result_type type(eval_node_t), pointer :: en_conv select case (en%result_type) case (V_INT) select case (result_type) case (V_REAL) allocate (en_conv) call eval_node_init_branch (en_conv, var_str ("real"), V_REAL, en) call eval_node_set_op1_real (en_conv, real_i) en => en_conv case (V_CMPLX) allocate (en_conv) call eval_node_init_branch (en_conv, var_str ("complex"), V_CMPLX, en) call eval_node_set_op1_cmplx (en_conv, cmplx_i) en => en_conv end select case (V_REAL) select case (result_type) case (V_INT) allocate (en_conv) call eval_node_init_branch (en_conv, var_str ("int"), V_INT, en) call eval_node_set_op1_int (en_conv, int_r) en => en_conv case (V_CMPLX) allocate (en_conv) call eval_node_init_branch (en_conv, var_str ("complex"), V_CMPLX, en) call eval_node_set_op1_cmplx (en_conv, cmplx_r) en => en_conv end select case (V_CMPLX) select case (result_type) case (V_INT) allocate (en_conv) call eval_node_init_branch (en_conv, var_str ("int"), V_INT, en) call eval_node_set_op1_int (en_conv, int_c) en => en_conv case (V_REAL) allocate (en_conv) call eval_node_init_branch (en_conv, var_str ("real"), V_REAL, en) call eval_node_set_op1_real (en_conv, real_c) en => en_conv end select case default end select end subroutine insert_conversion_node @ %def insert_conversion_node @ \subsubsection{Conditionals} A conditional has the structure if lexpr then expr else expr. So we first evaluate the logical expression, then depending on the result the first or second expression. Note that the second expression is mandatory. The [[result_type]], if present, defines the requested type of the [[then]] and [[else]] clauses. Default is numeric (int/real). If there is a mismatch between real and integer result types, insert conversion nodes. <>= recursive subroutine eval_node_compile_conditional & (en, pn, var_list, result_type) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list integer, intent(in), optional :: result_type type(parse_node_t), pointer :: pn_condition, pn_expr type(parse_node_t), pointer :: pn_maybe_elsif, pn_elsif_branch type(parse_node_t), pointer :: pn_maybe_else, pn_else_branch, pn_else_expr type(eval_node_t), pointer :: en0, en1, en2 integer :: restype if (debug_active (D_MODEL_F)) then print *, "read conditional"; call parse_node_write (pn) end if pn_condition => parse_node_get_sub_ptr (pn, 2, tag="lexpr") pn_expr => parse_node_get_next_ptr (pn_condition, 2) call eval_node_compile_lexpr (en0, pn_condition, var_list) call eval_node_compile_genexpr (en1, pn_expr, var_list, result_type) if (present (result_type)) then restype = major_result_type (result_type, en1%result_type) else restype = en1%result_type end if pn_maybe_elsif => parse_node_get_next_ptr (pn_expr) select case (char (parse_node_get_rule_key (pn_maybe_elsif))) case ("maybe_elsif_expr", & "maybe_elsif_lexpr", & "maybe_elsif_pexpr", & "maybe_elsif_cexpr", & "maybe_elsif_sexpr") pn_elsif_branch => parse_node_get_sub_ptr (pn_maybe_elsif) pn_maybe_else => parse_node_get_next_ptr (pn_maybe_elsif) select case (char (parse_node_get_rule_key (pn_maybe_else))) case ("maybe_else_expr", & "maybe_else_lexpr", & "maybe_else_pexpr", & "maybe_else_cexpr", & "maybe_else_sexpr") pn_else_branch => parse_node_get_sub_ptr (pn_maybe_else) pn_else_expr => parse_node_get_sub_ptr (pn_else_branch, 2) case default pn_else_expr => null () end select call eval_node_compile_elsif & (en2, pn_elsif_branch, pn_else_expr, var_list, restype) case ("maybe_else_expr", & "maybe_else_lexpr", & "maybe_else_pexpr", & "maybe_else_cexpr", & "maybe_else_sexpr") pn_maybe_else => pn_maybe_elsif pn_maybe_elsif => null () pn_else_branch => parse_node_get_sub_ptr (pn_maybe_else) pn_else_expr => parse_node_get_sub_ptr (pn_else_branch, 2) call eval_node_compile_genexpr & (en2, pn_else_expr, var_list, restype) case ("endif") call eval_node_compile_default_else (en2, restype) case default call msg_bug ("Broken conditional: unexpected " & // char (parse_node_get_rule_key (pn_maybe_elsif))) end select call eval_node_create_conditional (en, en0, en1, en2, restype) call conditional_insert_conversion_nodes (en, restype) if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done conditional" end if end subroutine eval_node_compile_conditional @ %def eval_node_compile_conditional @ This recursively generates 'elsif' conditionals as a chain of sub-nodes of the main conditional. <>= recursive subroutine eval_node_compile_elsif & (en, pn, pn_else_expr, var_list, result_type) type(eval_node_t), pointer :: en type(parse_node_t), intent(in), target :: pn type(parse_node_t), pointer :: pn_else_expr type(var_list_t), intent(in), target :: var_list integer, intent(inout) :: result_type type(parse_node_t), pointer :: pn_next, pn_condition, pn_expr type(eval_node_t), pointer :: en0, en1, en2 pn_condition => parse_node_get_sub_ptr (pn, 2, tag="lexpr") pn_expr => parse_node_get_next_ptr (pn_condition, 2) call eval_node_compile_lexpr (en0, pn_condition, var_list) call eval_node_compile_genexpr (en1, pn_expr, var_list, result_type) result_type = major_result_type (result_type, en1%result_type) pn_next => parse_node_get_next_ptr (pn) if (associated (pn_next)) then call eval_node_compile_elsif & (en2, pn_next, pn_else_expr, var_list, result_type) result_type = major_result_type (result_type, en2%result_type) else if (associated (pn_else_expr)) then call eval_node_compile_genexpr & (en2, pn_else_expr, var_list, result_type) result_type = major_result_type (result_type, en2%result_type) else call eval_node_compile_default_else (en2, result_type) end if call eval_node_create_conditional (en, en0, en1, en2, result_type) end subroutine eval_node_compile_elsif @ %def eval_node_compile_elsif @ This makes a default 'else' branch in case it was omitted. The default value just depends on the expected type. <>= subroutine eval_node_compile_default_else (en, result_type) type(eval_node_t), pointer :: en integer, intent(in) :: result_type type(subevt_t) :: pval_empty type(pdg_array_t) :: aval_undefined allocate (en) select case (result_type) case (V_LOG); call eval_node_init_log (en, .false.) case (V_INT); call eval_node_init_int (en, 0) case (V_REAL); call eval_node_init_real (en, 0._default) case (V_CMPLX) call eval_node_init_cmplx (en, (0._default, 0._default)) case (V_SEV) call subevt_init (pval_empty) call eval_node_init_subevt (en, pval_empty) case (V_PDG) call eval_node_init_pdg_array (en, aval_undefined) case (V_STR) call eval_node_init_string (en, var_str ("")) case default call msg_bug ("Undefined type for 'else' branch in conditional") end select end subroutine eval_node_compile_default_else @ %def eval_node_compile_default_else @ If the logical expression is constant, we can simplify the conditional node by replacing it with the selected branch. Otherwise, we initialize a true branching. <>= subroutine eval_node_create_conditional (en, en0, en1, en2, result_type) type(eval_node_t), pointer :: en, en0, en1, en2 integer, intent(in) :: result_type if (en0%type == EN_CONSTANT) then if (en0%lval) then en => en1 call eval_node_final_rec (en2) deallocate (en2) else en => en2 call eval_node_final_rec (en1) deallocate (en1) end if else allocate (en) call eval_node_init_conditional (en, result_type, en0, en1, en2) end if end subroutine eval_node_create_conditional @ %def eval_node_create_conditional @ Return the numerical result type which should be used for the combination of the two result types. <>= function major_result_type (t1, t2) result (t) integer :: t integer, intent(in) :: t1, t2 select case (t1) case (V_INT) select case (t2) case (V_INT, V_REAL, V_CMPLX) t = t2 case default call type_mismatch () end select case (V_REAL) select case (t2) case (V_INT) t = t1 case (V_REAL, V_CMPLX) t = t2 case default call type_mismatch () end select case (V_CMPLX) select case (t2) case (V_INT, V_REAL, V_CMPLX) t = t1 case default call type_mismatch () end select case default if (t1 == t2) then t = t1 else call type_mismatch () end if end select contains subroutine type_mismatch () call msg_bug ("Type mismatch in branches of a conditional expression") end subroutine type_mismatch end function major_result_type @ %def major_result_type @ Recursively insert conversion nodes where necessary. <>= recursive subroutine conditional_insert_conversion_nodes (en, result_type) type(eval_node_t), intent(inout), target :: en integer, intent(in) :: result_type select case (result_type) case (V_INT, V_REAL, V_CMPLX) call insert_conversion_node (en%arg1, result_type) if (en%arg2%type == EN_CONDITIONAL) then call conditional_insert_conversion_nodes (en%arg2, result_type) else call insert_conversion_node (en%arg2, result_type) end if end select end subroutine conditional_insert_conversion_nodes @ %def conditional_insert_conversion_nodes @ \subsubsection{Logical expressions} A logical expression consists of one or more singlet logical expressions concatenated by [[;]]. This is for allowing side-effects, only the last value is used. <>= recursive subroutine eval_node_compile_lexpr (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_term, pn_sequel, pn_arg type(eval_node_t), pointer :: en1, en2 if (debug_active (D_MODEL_F)) then print *, "read lexpr"; call parse_node_write (pn) end if pn_term => parse_node_get_sub_ptr (pn, tag="lsinglet") call eval_node_compile_lsinglet (en, pn_term, var_list) pn_sequel => parse_node_get_next_ptr (pn_term, tag="lsequel") do while (associated (pn_sequel)) pn_arg => parse_node_get_sub_ptr (pn_sequel, 2, tag="lsinglet") en1 => en call eval_node_compile_lsinglet (en2, pn_arg, var_list) allocate (en) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then call eval_node_init_log (en, ignore_first_ll (en1, en2)) call eval_node_final_rec (en1) call eval_node_final_rec (en2) deallocate (en1, en2) else call eval_node_init_branch & (en, var_str ("lsequel"), V_LOG, en1, en2) call eval_node_set_op2_log (en, ignore_first_ll) end if pn_sequel => parse_node_get_next_ptr (pn_sequel) end do if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done lexpr" end if end subroutine eval_node_compile_lexpr @ %def eval_node_compile_lexpr @ A logical singlet expression consists of one or more logical terms concatenated by [[or]]. <>= recursive subroutine eval_node_compile_lsinglet (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_term, pn_alternative, pn_arg type(eval_node_t), pointer :: en1, en2 if (debug_active (D_MODEL_F)) then print *, "read lsinglet"; call parse_node_write (pn) end if pn_term => parse_node_get_sub_ptr (pn, tag="lterm") call eval_node_compile_lterm (en, pn_term, var_list) pn_alternative => parse_node_get_next_ptr (pn_term, tag="alternative") do while (associated (pn_alternative)) pn_arg => parse_node_get_sub_ptr (pn_alternative, 2, tag="lterm") en1 => en call eval_node_compile_lterm (en2, pn_arg, var_list) allocate (en) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then call eval_node_init_log (en, or_ll (en1, en2)) call eval_node_final_rec (en1) call eval_node_final_rec (en2) deallocate (en1, en2) else call eval_node_init_branch & (en, var_str ("alternative"), V_LOG, en1, en2) call eval_node_set_op2_log (en, or_ll) end if pn_alternative => parse_node_get_next_ptr (pn_alternative) end do if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done lsinglet" end if end subroutine eval_node_compile_lsinglet @ %def eval_node_compile_lsinglet @ A logical term consists of one or more logical values concatenated by [[and]]. <>= recursive subroutine eval_node_compile_lterm (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_term, pn_coincidence, pn_arg type(eval_node_t), pointer :: en1, en2 if (debug_active (D_MODEL_F)) then print *, "read lterm"; call parse_node_write (pn) end if pn_term => parse_node_get_sub_ptr (pn) call eval_node_compile_lvalue (en, pn_term, var_list) pn_coincidence => parse_node_get_next_ptr (pn_term, tag="coincidence") do while (associated (pn_coincidence)) pn_arg => parse_node_get_sub_ptr (pn_coincidence, 2) en1 => en call eval_node_compile_lvalue (en2, pn_arg, var_list) allocate (en) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then call eval_node_init_log (en, and_ll (en1, en2)) call eval_node_final_rec (en1) call eval_node_final_rec (en2) deallocate (en1, en2) else call eval_node_init_branch & (en, var_str ("coincidence"), V_LOG, en1, en2) call eval_node_set_op2_log (en, and_ll) end if pn_coincidence => parse_node_get_next_ptr (pn_coincidence) end do if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done lterm" end if end subroutine eval_node_compile_lterm @ %def eval_node_compile_lterm @ Logical variables are disabled, because they are confused with the l.h.s.\ of compared expressions. <>= recursive subroutine eval_node_compile_lvalue (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list if (debug_active (D_MODEL_F)) then print *, "read lvalue"; call parse_node_write (pn) end if select case (char (parse_node_get_rule_key (pn))) case ("true") allocate (en) call eval_node_init_log (en, .true.) case ("false") allocate (en) call eval_node_init_log (en, .false.) case ("negation") call eval_node_compile_negation (en, pn, var_list) case ("lvariable") call eval_node_compile_variable (en, pn, var_list, V_LOG) case ("lexpr") call eval_node_compile_lexpr (en, pn, var_list) case ("block_lexpr") call eval_node_compile_block_expr (en, pn, var_list, V_LOG) case ("conditional_lexpr") call eval_node_compile_conditional (en, pn, var_list, V_LOG) case ("compared_expr") call eval_node_compile_compared_expr (en, pn, var_list, V_REAL) case ("compared_sexpr") call eval_node_compile_compared_expr (en, pn, var_list, V_STR) case ("all_fun", "any_fun", "no_fun", "photon_isolation_fun") call eval_node_compile_log_function (en, pn, var_list) case ("record_cmd") call eval_node_compile_record_cmd (en, pn, var_list) case default call parse_node_mismatch & ("true|false|negation|lvariable|" // & "lexpr|block_lexpr|conditional_lexpr|" // & "compared_expr|compared_sexpr|logical_pexpr", pn) end select if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done lvalue" end if end subroutine eval_node_compile_lvalue @ %def eval_node_compile_lvalue @ A negation consists of the keyword [[not]] and a logical value. <>= recursive subroutine eval_node_compile_negation (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_arg type(eval_node_t), pointer :: en1 if (debug_active (D_MODEL_F)) then print *, "read negation"; call parse_node_write (pn) end if pn_arg => parse_node_get_sub_ptr (pn, 2) call eval_node_compile_lvalue (en1, pn_arg, var_list) allocate (en) if (en1%type == EN_CONSTANT) then call eval_node_init_log (en, not_l (en1)) call eval_node_final_rec (en1) deallocate (en1) else call eval_node_init_branch (en, var_str ("not"), V_LOG, en1) call eval_node_set_op1_log (en, not_l) end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done negation" end if end subroutine eval_node_compile_negation @ %def eval_node_compile_negation @ \subsubsection{Comparisons} Up to the loop, this is easy. There is always at least one comparison. This is evaluated, and the result is the logical node [[en]]. If it is constant, we keep its second sub-node as [[en2]]. (Thus, at the very end [[en2]] has to be deleted if [[en]] is (still) constant.) If there is another comparison, we first check if the first comparison was constant. In that case, there are two possibilities: (i) it was true. Then, its right-hand side is compared with the new right-hand side, and the result replaces the previous one which is deleted. (ii) it was false. In this case, the result of the whole comparison is false, and we can exit the loop without evaluating anything else. Now assume that the first comparison results in a valid branch, its second sub-node kept as [[en2]]. We first need a copy of this, which becomes the new left-hand side. If [[en2]] is constant, we make an identical constant node [[en1]]. Otherwise, we make [[en1]] an appropriate pointer node. Next, the first branch is saved as [[en0]] and we evaluate the comparison between [[en1]] and the a right-hand side. If this turns out to be constant, there are again two possibilities: (i) true, then we revert to the previous result. (ii) false, then the wh <>= recursive subroutine eval_node_compile_compared_expr (en, pn, var_list, type) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list integer, intent(in) :: type type(parse_node_t), pointer :: pn_comparison, pn_expr1 type(eval_node_t), pointer :: en0, en1, en2 if (debug_active (D_MODEL_F)) then print *, "read comparison"; call parse_node_write (pn) end if select case (type) case (V_INT, V_REAL) pn_expr1 => parse_node_get_sub_ptr (pn, tag="expr") call eval_node_compile_expr (en1, pn_expr1, var_list) pn_comparison => parse_node_get_next_ptr (pn_expr1, tag="comparison") case (V_STR) pn_expr1 => parse_node_get_sub_ptr (pn, tag="sexpr") call eval_node_compile_sexpr (en1, pn_expr1, var_list) pn_comparison => parse_node_get_next_ptr (pn_expr1, tag="str_comparison") end select call eval_node_compile_comparison & (en, en1, en2, pn_comparison, var_list, type) pn_comparison => parse_node_get_next_ptr (pn_comparison) SCAN_FURTHER: do while (associated (pn_comparison)) if (en%type == EN_CONSTANT) then if (en%lval) then en1 => en2 call eval_node_final_rec (en); deallocate (en) call eval_node_compile_comparison & (en, en1, en2, pn_comparison, var_list, type) else exit SCAN_FURTHER end if else allocate (en1) if (en2%type == EN_CONSTANT) then select case (en2%result_type) case (V_INT); call eval_node_init_int (en1, en2%ival) case (V_REAL); call eval_node_init_real (en1, en2%rval) case (V_STR); call eval_node_init_string (en1, en2%sval) end select else select case (en2%result_type) case (V_INT); call eval_node_init_int_ptr & (en1, var_str ("(previous)"), en2%ival, en2%value_is_known) case (V_REAL); call eval_node_init_real_ptr & (en1, var_str ("(previous)"), en2%rval, en2%value_is_known) case (V_STR); call eval_node_init_string_ptr & (en1, var_str ("(previous)"), en2%sval, en2%value_is_known) end select end if en0 => en call eval_node_compile_comparison & (en, en1, en2, pn_comparison, var_list, type) if (en%type == EN_CONSTANT) then if (en%lval) then call eval_node_final_rec (en); deallocate (en) en => en0 else call eval_node_final_rec (en0); deallocate (en0) exit SCAN_FURTHER end if else en1 => en allocate (en) call eval_node_init_branch (en, var_str ("and"), V_LOG, en0, en1) call eval_node_set_op2_log (en, and_ll) end if end if pn_comparison => parse_node_get_next_ptr (pn_comparison) end do SCAN_FURTHER if (en%type == EN_CONSTANT .and. associated (en2)) then call eval_node_final_rec (en2); deallocate (en2) end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done compared_expr" end if end subroutine eval_node_compile_compared_expr @ %dev eval_node_compile_compared_expr @ This takes two extra arguments: [[en1]], the left-hand-side of the comparison, is already allocated and evaluated. [[en2]] (the right-hand side) and [[en]] (the result) are allocated by the routine. [[pn]] is the parse node which contains the operator and the right-hand side as subnodes. If the result of the comparison is constant, [[en1]] is deleted but [[en2]] is kept, because it may be used in a subsequent comparison. [[en]] then becomes a constant. If the result is variable, [[en]] becomes a branch node which refers to [[en1]] and [[en2]]. <>= recursive subroutine eval_node_compile_comparison & (en, en1, en2, pn, var_list, type) type(eval_node_t), pointer :: en, en1, en2 type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list integer, intent(in) :: type type(parse_node_t), pointer :: pn_op, pn_arg type(string_t) :: key integer :: t1, t2 real(default), pointer :: tolerance_ptr pn_op => parse_node_get_sub_ptr (pn) key = parse_node_get_key (pn_op) select case (type) case (V_INT, V_REAL) pn_arg => parse_node_get_next_ptr (pn_op, tag="expr") call eval_node_compile_expr (en2, pn_arg, var_list) case (V_STR) pn_arg => parse_node_get_next_ptr (pn_op, tag="sexpr") call eval_node_compile_sexpr (en2, pn_arg, var_list) end select t1 = en1%result_type t2 = en2%result_type allocate (en) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then call var_list%get_rptr (var_str ("tolerance"), tolerance_ptr) en1%tolerance => tolerance_ptr select case (char (key)) case ("<") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_log (en, comp_lt_ii (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_ll_ir (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_log (en, comp_ll_ri (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_ll_rr (en1, en2)) end select end select case (">") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_log (en, comp_gt_ii (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_gg_ir (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_log (en, comp_gg_ri (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_gg_rr (en1, en2)) end select end select case ("<=") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_log (en, comp_le_ii (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_ls_ir (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_log (en, comp_ls_ri (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_ls_rr (en1, en2)) end select end select case (">=") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_log (en, comp_ge_ii (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_gs_ir (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_log (en, comp_gs_ri (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_gs_rr (en1, en2)) end select end select case ("==") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_log (en, comp_eq_ii (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_se_ir (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_log (en, comp_se_ri (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_se_rr (en1, en2)) end select case (V_STR) select case (t2) case (V_STR); call eval_node_init_log (en, comp_eq_ss (en1, en2)) end select end select case ("<>") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_log (en, comp_ne_ii (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_ns_ir (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_log (en, comp_ns_ri (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_ns_rr (en1, en2)) end select case (V_STR) select case (t2) case (V_STR); call eval_node_init_log (en, comp_ne_ss (en1, en2)) end select end select end select call eval_node_final_rec (en1) deallocate (en1) else call eval_node_init_branch (en, key, V_LOG, en1, en2) select case (char (key)) case ("<") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_lt_ii) case (V_REAL); call eval_node_set_op2_log (en, comp_ll_ir) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_ll_ri) case (V_REAL); call eval_node_set_op2_log (en, comp_ll_rr) end select end select case (">") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_gt_ii) case (V_REAL); call eval_node_set_op2_log (en, comp_gg_ir) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_gg_ri) case (V_REAL); call eval_node_set_op2_log (en, comp_gg_rr) end select end select case ("<=") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_le_ii) case (V_REAL); call eval_node_set_op2_log (en, comp_ls_ir) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_ls_ri) case (V_REAL); call eval_node_set_op2_log (en, comp_ls_rr) end select end select case (">=") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_ge_ii) case (V_REAL); call eval_node_set_op2_log (en, comp_gs_ir) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_gs_ri) case (V_REAL); call eval_node_set_op2_log (en, comp_gs_rr) end select end select case ("==") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_eq_ii) case (V_REAL); call eval_node_set_op2_log (en, comp_se_ir) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_se_ri) case (V_REAL); call eval_node_set_op2_log (en, comp_se_rr) end select case (V_STR) select case (t2) case (V_STR); call eval_node_set_op2_log (en, comp_eq_ss) end select end select case ("<>") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_ne_ii) case (V_REAL); call eval_node_set_op2_log (en, comp_ns_ir) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_ns_ri) case (V_REAL); call eval_node_set_op2_log (en, comp_ns_rr) end select case (V_STR) select case (t2) case (V_STR); call eval_node_set_op2_log (en, comp_ne_ss) end select end select end select call var_list%get_rptr (var_str ("tolerance"), tolerance_ptr) en1%tolerance => tolerance_ptr end if end subroutine eval_node_compile_comparison @ %def eval_node_compile_comparison @ \subsubsection{Recording analysis data} The [[record]] command is actually a logical expression which always evaluates [[true]]. <>= recursive subroutine eval_node_compile_record_cmd (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_key, pn_tag, pn_arg type(parse_node_t), pointer :: pn_arg1, pn_arg2, pn_arg3, pn_arg4 type(eval_node_t), pointer :: en0, en1, en2, en3, en4 real(default), pointer :: event_weight if (debug_active (D_MODEL_F)) then print *, "read record_cmd"; call parse_node_write (pn) end if pn_key => parse_node_get_sub_ptr (pn) pn_tag => parse_node_get_next_ptr (pn_key) pn_arg => parse_node_get_next_ptr (pn_tag) select case (char (parse_node_get_key (pn_key))) case ("record") call var_list%get_rptr (var_str ("event_weight"), event_weight) case ("record_unweighted") event_weight => null () case ("record_excess") call var_list%get_rptr (var_str ("event_excess"), event_weight) end select select case (char (parse_node_get_rule_key (pn_tag))) case ("analysis_id") allocate (en0) call eval_node_init_string (en0, parse_node_get_string (pn_tag)) case default call eval_node_compile_sexpr (en0, pn_tag, var_list) end select allocate (en) if (associated (pn_arg)) then pn_arg1 => parse_node_get_sub_ptr (pn_arg) call eval_node_compile_expr (en1, pn_arg1, var_list) if (en1%result_type == V_INT) & call insert_conversion_node (en1, V_REAL) pn_arg2 => parse_node_get_next_ptr (pn_arg1) if (associated (pn_arg2)) then call eval_node_compile_expr (en2, pn_arg2, var_list) if (en2%result_type == V_INT) & call insert_conversion_node (en2, V_REAL) pn_arg3 => parse_node_get_next_ptr (pn_arg2) if (associated (pn_arg3)) then call eval_node_compile_expr (en3, pn_arg3, var_list) if (en3%result_type == V_INT) & call insert_conversion_node (en3, V_REAL) pn_arg4 => parse_node_get_next_ptr (pn_arg3) if (associated (pn_arg4)) then call eval_node_compile_expr (en4, pn_arg4, var_list) if (en4%result_type == V_INT) & call insert_conversion_node (en4, V_REAL) call eval_node_init_record_cmd & (en, event_weight, en0, en1, en2, en3, en4) else call eval_node_init_record_cmd & (en, event_weight, en0, en1, en2, en3) end if else call eval_node_init_record_cmd (en, event_weight, en0, en1, en2) end if else call eval_node_init_record_cmd (en, event_weight, en0, en1) end if else call eval_node_init_record_cmd (en, event_weight, en0) end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done record_cmd" end if end subroutine eval_node_compile_record_cmd @ %def eval_node_compile_record_cmd @ \subsubsection{Particle-list expressions} A particle expression is a subevent or a concatenation of particle-list terms (using \verb|join|). <>= recursive subroutine eval_node_compile_pexpr (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_pterm, pn_concatenation, pn_op, pn_arg type(eval_node_t), pointer :: en1, en2 type(subevt_t) :: subevt if (debug_active (D_MODEL_F)) then print *, "read pexpr"; call parse_node_write (pn) end if pn_pterm => parse_node_get_sub_ptr (pn) call eval_node_compile_pterm (en, pn_pterm, var_list) pn_concatenation => & parse_node_get_next_ptr (pn_pterm, tag="pconcatenation") do while (associated (pn_concatenation)) pn_op => parse_node_get_sub_ptr (pn_concatenation) pn_arg => parse_node_get_next_ptr (pn_op) en1 => en call eval_node_compile_pterm (en2, pn_arg, var_list) allocate (en) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then call subevt_join (subevt, en1%pval, en2%pval) call eval_node_init_subevt (en, subevt) call eval_node_final_rec (en1) call eval_node_final_rec (en2) deallocate (en1, en2) else call eval_node_init_branch & (en, var_str ("join"), V_SEV, en1, en2) call eval_node_set_op2_sev (en, join_pp) end if pn_concatenation => parse_node_get_next_ptr (pn_concatenation) end do if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done pexpr" end if end subroutine eval_node_compile_pexpr @ %def eval_node_compile_pexpr @ A particle term is a subevent or a combination of particle-list values (using \verb|combine|). <>= recursive subroutine eval_node_compile_pterm (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_pvalue, pn_combination, pn_op, pn_arg type(eval_node_t), pointer :: en1, en2 type(subevt_t) :: subevt if (debug_active (D_MODEL_F)) then print *, "read pterm"; call parse_node_write (pn) end if pn_pvalue => parse_node_get_sub_ptr (pn) call eval_node_compile_pvalue (en, pn_pvalue, var_list) pn_combination => & parse_node_get_next_ptr (pn_pvalue, tag="pcombination") do while (associated (pn_combination)) pn_op => parse_node_get_sub_ptr (pn_combination) pn_arg => parse_node_get_next_ptr (pn_op) en1 => en call eval_node_compile_pvalue (en2, pn_arg, var_list) allocate (en) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then call subevt_combine (subevt, en1%pval, en2%pval) call eval_node_init_subevt (en, subevt) call eval_node_final_rec (en1) call eval_node_final_rec (en2) deallocate (en1, en2) else call eval_node_init_branch & (en, var_str ("combine"), V_SEV, en1, en2) call eval_node_set_op2_sev (en, combine_pp) end if pn_combination => parse_node_get_next_ptr (pn_combination) end do if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done pterm" end if end subroutine eval_node_compile_pterm @ %def eval_node_compile_pterm @ A particle-list value is a PDG-code array, a particle identifier, a variable, a (grouped) pexpr, a block pexpr, a conditional, or a particle-list function. The [[cexpr]] node is responsible for transforming a constant PDG-code array into a subevent. It takes the code array as its first argument, the event subevent as its second argument, and the requested particle type (incoming/outgoing) as its zero-th argument. The result is the list of particles in the event that match the code array. <>= recursive subroutine eval_node_compile_pvalue (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_prefix_cexpr type(eval_node_t), pointer :: en1, en2, en0 type(string_t) :: key type(subevt_t), pointer :: evt_ptr logical, pointer :: known if (debug_active (D_MODEL_F)) then print *, "read pvalue"; call parse_node_write (pn) end if select case (char (parse_node_get_rule_key (pn))) case ("pexpr_src") call eval_node_compile_prefix_cexpr (en1, pn, var_list) allocate (en2) if (var_list%contains (var_str ("@evt"))) then call var_list%get_pptr (var_str ("@evt"), evt_ptr, known) call eval_node_init_subevt_ptr (en2, var_str ("@evt"), evt_ptr, known) allocate (en) call eval_node_init_branch & (en, var_str ("prt_selection"), V_SEV, en1, en2) call eval_node_set_op2_sev (en, select_pdg_ca) allocate (en0) pn_prefix_cexpr => parse_node_get_sub_ptr (pn) key = parse_node_get_rule_key (pn_prefix_cexpr) select case (char (key)) case ("beam_prt") call eval_node_init_int (en0, PRT_BEAM) en%arg0 => en0 case ("incoming_prt") call eval_node_init_int (en0, PRT_INCOMING) en%arg0 => en0 case ("outgoing_prt") call eval_node_init_int (en0, PRT_OUTGOING) en%arg0 => en0 case ("unspecified_prt") call eval_node_init_int (en0, PRT_OUTGOING) en%arg0 => en0 end select else call parse_node_write (pn) call msg_bug (" Missing event data while compiling pvalue") end if case ("pvariable") call eval_node_compile_variable (en, pn, var_list, V_SEV) case ("pexpr") call eval_node_compile_pexpr (en, pn, var_list) case ("block_pexpr") call eval_node_compile_block_expr (en, pn, var_list, V_SEV) case ("conditional_pexpr") call eval_node_compile_conditional (en, pn, var_list, V_SEV) case ("join_fun", "combine_fun", "collect_fun", "cluster_fun", & "select_fun", "extract_fun", "sort_fun", "select_b_jet_fun", & "select_non_bjet_fun", "select_c_jet_fun", & "select_light_jet_fun", "photon_reco_fun") call eval_node_compile_prt_function (en, pn, var_list) case default call parse_node_mismatch & ("prefix_cexpr|pvariable|" // & "grouped_pexpr|block_pexpr|conditional_pexpr|" // & "prt_function", pn) end select if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done pvalue" end if end subroutine eval_node_compile_pvalue @ %def eval_node_compile_pvalue @ \subsubsection{Particle functions} This combines the treatment of 'join', 'combine', 'collect', 'cluster', 'select', and 'extract', as well as the functions for $b$, $c$ and light jet selection and photon recombnation which all have the same syntax. The one or two argument nodes are allocated. If there is a condition, the condition node is also allocated as a logical expression, for which the variable list is augmented by the appropriate (unary/binary) observables. <>= recursive subroutine eval_node_compile_prt_function (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_clause, pn_key, pn_cond, pn_args type(parse_node_t), pointer :: pn_arg0, pn_arg1, pn_arg2 type(eval_node_t), pointer :: en0, en1, en2 type(string_t) :: key if (debug_active (D_MODEL_F)) then print *, "read prt_function"; call parse_node_write (pn) end if pn_clause => parse_node_get_sub_ptr (pn) pn_key => parse_node_get_sub_ptr (pn_clause) pn_cond => parse_node_get_next_ptr (pn_key) if (associated (pn_cond)) & pn_arg0 => parse_node_get_sub_ptr (pn_cond, 2) pn_args => parse_node_get_next_ptr (pn_clause) pn_arg1 => parse_node_get_sub_ptr (pn_args) pn_arg2 => parse_node_get_next_ptr (pn_arg1) key = parse_node_get_key (pn_key) call eval_node_compile_pexpr (en1, pn_arg1, var_list) allocate (en) if (.not. associated (pn_arg2)) then select case (char (key)) case ("collect") call eval_node_init_prt_fun_unary (en, en1, key, collect_p) case ("cluster") if (fastjet_available ()) then call fastjet_init () else call msg_fatal & ("'cluster' function requires FastJet, which is not enabled") end if en1%var_list => var_list call eval_node_init_prt_fun_unary (en, en1, key, cluster_p) call var_list%get_iptr (var_str ("jet_algorithm"), en1%jet_algorithm) call var_list%get_rptr (var_str ("jet_r"), en1%jet_r) call var_list%get_rptr (var_str ("jet_p"), en1%jet_p) call var_list%get_rptr (var_str ("jet_ycut"), en1%jet_ycut) call var_list%get_rptr (var_str ("jet_dcut"), en1%jet_dcut) case ("photon_recombination") en1%var_list => var_list call eval_node_init_prt_fun_unary & (en, en1, key, photon_recombination_p) call var_list%get_rptr (var_str ("photon_rec_r0"), en1%photon_rec_r0) case ("select") call eval_node_init_prt_fun_unary (en, en1, key, select_p) case ("extract") call eval_node_init_prt_fun_unary (en, en1, key, extract_p) case ("sort") call eval_node_init_prt_fun_unary (en, en1, key, sort_p) case ("select_b_jet") call eval_node_init_prt_fun_unary (en, en1, key, select_b_jet_p) case ("select_non_b_jet") call eval_node_init_prt_fun_unary (en, en1, key, select_non_b_jet_p) case ("select_c_jet") call eval_node_init_prt_fun_unary (en, en1, key, select_c_jet_p) case ("select_light_jet") call eval_node_init_prt_fun_unary (en, en1, key, select_light_jet_p) case default call msg_bug (" Unary particle function '" // char (key) // & "' undefined") end select else call eval_node_compile_pexpr (en2, pn_arg2, var_list) select case (char (key)) case ("join") call eval_node_init_prt_fun_binary (en, en1, en2, key, join_pp) case ("combine") call eval_node_init_prt_fun_binary (en, en1, en2, key, combine_pp) case ("collect") call eval_node_init_prt_fun_binary (en, en1, en2, key, collect_pp) case ("select") call eval_node_init_prt_fun_binary (en, en1, en2, key, select_pp) case ("sort") call eval_node_init_prt_fun_binary (en, en1, en2, key, sort_pp) case default call msg_bug (" Binary particle function '" // char (key) // & "' undefined") end select end if if (associated (pn_cond)) then call eval_node_set_observables (en, var_list) select case (char (key)) case ("extract", "sort") call eval_node_compile_expr (en0, pn_arg0, en%var_list) case default call eval_node_compile_lexpr (en0, pn_arg0, en%var_list) end select en%arg0 => en0 end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done prt_function" end if end subroutine eval_node_compile_prt_function @ %def eval_node_compile_prt_function @ The [[eval]] expression is similar, but here the expression [[arg0]] is mandatory, and the whole thing evaluates to a numeric value. To guarantee initialization of variables defined on subevents instead of a single (namely the first) particle of a subevent, we make sure that [[en]] points to the subevent stored in [[en1]]. <>= recursive subroutine eval_node_compile_eval_function (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_key, pn_arg0, pn_args, pn_arg1, pn_arg2 type(eval_node_t), pointer :: en0, en1, en2 type(string_t) :: key if (debug_active (D_MODEL_F)) then print *, "read eval_function"; call parse_node_write (pn) end if pn_key => parse_node_get_sub_ptr (pn) pn_arg0 => parse_node_get_next_ptr (pn_key) pn_args => parse_node_get_next_ptr (pn_arg0) pn_arg1 => parse_node_get_sub_ptr (pn_args) pn_arg2 => parse_node_get_next_ptr (pn_arg1) key = parse_node_get_key (pn_key) call eval_node_compile_pexpr (en1, pn_arg1, var_list) allocate (en) if (.not. associated (pn_arg2)) then call eval_node_init_eval_fun_unary (en, en1, key) else call eval_node_compile_pexpr (en2, pn_arg2, var_list) call eval_node_init_eval_fun_binary (en, en1, en2, key) end if en%pval => en1%pval call eval_node_set_observables (en, var_list) call eval_node_compile_expr (en0, pn_arg0, en%var_list) if (en0%result_type == V_INT) & call insert_conversion_node (en0, V_REAL) if (en0%result_type /= V_REAL) & call msg_fatal (" 'eval' function does not result in real value") call eval_node_set_expr (en, en0) if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done eval_function" end if end subroutine eval_node_compile_eval_function @ %def eval_node_compile_eval_function @ Logical functions of subevents. For [[photon_isolation]] there is a conditional selection expression instead of a mandatory logical expression, so in the case of the absence of the selection we have to create a logical [[eval_node_t]] with value [[.true.]]. <>= recursive subroutine eval_node_compile_log_function (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_clause, pn_key, pn_str, pn_cond type(parse_node_t), pointer :: pn_arg0, pn_args, pn_arg1, pn_arg2 type(eval_node_t), pointer :: en0, en1, en2 type(string_t) :: key if (debug_active (D_MODEL_F)) then print *, "read log_function"; call parse_node_write (pn) end if select case (char (parse_node_get_rule_key (pn))) case ("all_fun", "any_fun", "no_fun") pn_key => parse_node_get_sub_ptr (pn) pn_arg0 => parse_node_get_next_ptr (pn_key) pn_args => parse_node_get_next_ptr (pn_arg0) case ("photon_isolation_fun") pn_clause => parse_node_get_sub_ptr (pn) pn_key => parse_node_get_sub_ptr (pn_clause) pn_cond => parse_node_get_next_ptr (pn_key) if (associated (pn_cond)) then pn_arg0 => parse_node_get_sub_ptr (pn_cond, 2) else pn_arg0 => null () end if pn_args => parse_node_get_next_ptr (pn_clause) case default call parse_node_mismatch ("all_fun|any_fun|" // & "no_fun|photon_isolation_fun", pn) end select pn_arg1 => parse_node_get_sub_ptr (pn_args) pn_arg2 => parse_node_get_next_ptr (pn_arg1) key = parse_node_get_key (pn_key) call eval_node_compile_pexpr (en1, pn_arg1, var_list) allocate (en) if (.not. associated (pn_arg2)) then select case (char (key)) case ("all") call eval_node_init_log_fun_unary (en, en1, key, all_p) case ("any") call eval_node_init_log_fun_unary (en, en1, key, any_p) case ("no") call eval_node_init_log_fun_unary (en, en1, key, no_p) case default call msg_bug ("Unary logical particle function '" // char (key) // & "' undefined") end select else call eval_node_compile_pexpr (en2, pn_arg2, var_list) select case (char (key)) case ("all") call eval_node_init_log_fun_binary (en, en1, en2, key, all_pp) case ("any") call eval_node_init_log_fun_binary (en, en1, en2, key, any_pp) case ("no") call eval_node_init_log_fun_binary (en, en1, en2, key, no_pp) case ("photon_isolation") en1%var_list => var_list call var_list%get_rptr (var_str ("photon_iso_eps"), en1%photon_iso_eps) call var_list%get_rptr (var_str ("photon_iso_n"), en1%photon_iso_n) call var_list%get_rptr (var_str ("photon_iso_r0"), en1%photon_iso_r0) call eval_node_init_log_fun_binary (en, en1, en2, key, photon_isolation_pp) case default call msg_bug ("Binary logical particle function '" // char (key) // & "' undefined") end select end if if (associated (pn_arg0)) then call eval_node_set_observables (en, var_list) select case (char (key)) case ("all", "any", "no", "photon_isolation") call eval_node_compile_lexpr (en0, pn_arg0, en%var_list) case default call msg_bug ("Compiling logical particle function: missing mode") end select call eval_node_set_expr (en, en0, V_LOG) else select case (char (key)) case ("photon_isolation") allocate (en0) call eval_node_init_log (en0, .true.) call eval_node_set_expr (en, en0, V_LOG) case default call msg_bug ("Only photon isolation can be called unconditionally") end select end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done log_function" end if end subroutine eval_node_compile_log_function @ %def eval_node_compile_log_function @ Count function of subevents. <>= recursive subroutine eval_node_compile_count_function (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_clause, pn_key, pn_cond, pn_args type(parse_node_t), pointer :: pn_arg0, pn_arg1, pn_arg2 type(eval_node_t), pointer :: en0, en1, en2 type(string_t) :: key if (debug_active (D_MODEL_F)) then print *, "read count_function"; call parse_node_write (pn) end if select case (char (parse_node_get_rule_key (pn))) case ("count_fun") pn_clause => parse_node_get_sub_ptr (pn) pn_key => parse_node_get_sub_ptr (pn_clause) pn_cond => parse_node_get_next_ptr (pn_key) if (associated (pn_cond)) then pn_arg0 => parse_node_get_sub_ptr (pn_cond, 2) else pn_arg0 => null () end if pn_args => parse_node_get_next_ptr (pn_clause) end select pn_arg1 => parse_node_get_sub_ptr (pn_args) pn_arg2 => parse_node_get_next_ptr (pn_arg1) key = parse_node_get_key (pn_key) call eval_node_compile_pexpr (en1, pn_arg1, var_list) allocate (en) if (.not. associated (pn_arg2)) then select case (char (key)) case ("count") call eval_node_init_int_fun_unary (en, en1, key, count_a) case default call msg_bug ("Unary subevent function '" // char (key) // & "' undefined") end select else call eval_node_compile_pexpr (en2, pn_arg2, var_list) select case (char (key)) case ("count") call eval_node_init_int_fun_binary (en, en1, en2, key, count_pp) case default call msg_bug ("Binary subevent function '" // char (key) // & "' undefined") end select end if if (associated (pn_arg0)) then call eval_node_set_observables (en, var_list) select case (char (key)) case ("count") call eval_node_compile_lexpr (en0, pn_arg0, en%var_list) call eval_node_set_expr (en, en0, V_INT) end select end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done count_function" end if end subroutine eval_node_compile_count_function @ %def eval_node_compile_count_function @ Numeric functions of subevents. <>= recursive subroutine eval_node_compile_numeric_function (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_key, pn_args type(parse_node_t), pointer :: pn_arg0, pn_arg1, pn_arg2 type(eval_node_t), pointer :: en0, en1 type(string_t) :: key - type(var_entry_t), pointer :: var if (debug_active (D_MODEL_F)) then print *, "read numeric_function"; call parse_node_write (pn) end if select case (char (parse_node_get_rule_key (pn))) case ("sum_fun", "prod_fun") if (debug_active (D_MODEL_F)) then print *, "read sum_fun"; call parse_node_write (pn) end if pn_key => parse_node_get_sub_ptr (pn) pn_arg0 => parse_node_get_next_ptr (pn_key) pn_args => parse_node_get_next_ptr (pn_arg0) end select pn_arg1 => parse_node_get_sub_ptr (pn_args) pn_arg2 => parse_node_get_next_ptr (pn_arg1) key = parse_node_get_key (pn_key) call eval_node_compile_pexpr (en1, pn_arg1, var_list) if (associated (pn_arg2)) then call msg_fatal ("The " // char (key) // & " function can only be used for unary observables.") end if allocate (en) select case (char (key)) case ("sum") call eval_node_init_real_fun_cum (en, en1, key, sum_a) case ("prod") call eval_node_init_real_fun_cum (en, en1, key, prod_a) case default call msg_bug ("Unary subevent function '" // char (key) // & "' undefined") end select call eval_node_set_observables (en, var_list) call eval_node_compile_expr (en0, pn_arg0, en%var_list) if (en0%result_type == V_INT) & call insert_conversion_node (en0, V_REAL) call eval_node_set_expr (en, en0, V_REAL) if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done numeric_function" end if end subroutine eval_node_compile_numeric_function @ %def eval_node_compile_numeric_function @ \subsubsection{PDG-code arrays} A PDG-code expression is (optionally) prefixed by [[beam]], [[incoming]], or [[outgoing]], a block, or a conditional. In any case, it evaluates to a constant. <>= recursive subroutine eval_node_compile_prefix_cexpr (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_avalue, pn_prt type(string_t) :: key if (debug_active (D_MODEL_F)) then print *, "read prefix_cexpr"; call parse_node_write (pn) end if pn_avalue => parse_node_get_sub_ptr (pn) key = parse_node_get_rule_key (pn_avalue) select case (char (key)) case ("beam_prt") pn_prt => parse_node_get_sub_ptr (pn_avalue, 2) call eval_node_compile_cexpr (en, pn_prt, var_list) case ("incoming_prt") pn_prt => parse_node_get_sub_ptr (pn_avalue, 2) call eval_node_compile_cexpr (en, pn_prt, var_list) case ("outgoing_prt") pn_prt => parse_node_get_sub_ptr (pn_avalue, 2) call eval_node_compile_cexpr (en, pn_prt, var_list) case ("unspecified_prt") pn_prt => parse_node_get_sub_ptr (pn_avalue, 1) call eval_node_compile_cexpr (en, pn_prt, var_list) case default call parse_node_mismatch & ("beam_prt|incoming_prt|outgoing_prt|unspecified_prt", & pn_avalue) end select if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done prefix_cexpr" end if end subroutine eval_node_compile_prefix_cexpr @ %def eval_node_compile_prefix_cexpr @ A PDG array is a string of PDG code definitions (or aliases), concatenated by ':'. The code definitions may be variables which are not defined at compile time, so we have to allocate sub-nodes. This analogous to [[eval_node_compile_term]]. <>= recursive subroutine eval_node_compile_cexpr (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_prt, pn_concatenation type(eval_node_t), pointer :: en1, en2 type(pdg_array_t) :: aval if (debug_active (D_MODEL_F)) then print *, "read cexpr"; call parse_node_write (pn) end if pn_prt => parse_node_get_sub_ptr (pn) call eval_node_compile_avalue (en, pn_prt, var_list) pn_concatenation => parse_node_get_next_ptr (pn_prt) do while (associated (pn_concatenation)) pn_prt => parse_node_get_sub_ptr (pn_concatenation, 2) en1 => en call eval_node_compile_avalue (en2, pn_prt, var_list) allocate (en) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then call concat_cc (aval, en1, en2) call eval_node_init_pdg_array (en, aval) call eval_node_final_rec (en1) call eval_node_final_rec (en2) deallocate (en1, en2) else call eval_node_init_branch (en, var_str (":"), V_PDG, en1, en2) call eval_node_set_op2_pdg (en, concat_cc) end if pn_concatenation => parse_node_get_next_ptr (pn_concatenation) end do if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done cexpr" end if end subroutine eval_node_compile_cexpr @ %def eval_node_compile_cexpr @ Compile a PDG-code type value. It may be either an integer expression or a variable of type PDG array, optionally quoted. <>= recursive subroutine eval_node_compile_avalue (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list if (debug_active (D_MODEL_F)) then print *, "read avalue"; call parse_node_write (pn) end if select case (char (parse_node_get_rule_key (pn))) case ("pdg_code") call eval_node_compile_pdg_code (en, pn, var_list) case ("cvariable", "variable", "prt_name") call eval_node_compile_cvariable (en, pn, var_list) case ("cexpr") call eval_node_compile_cexpr (en, pn, var_list) case ("block_cexpr") call eval_node_compile_block_expr (en, pn, var_list, V_PDG) case ("conditional_cexpr") call eval_node_compile_conditional (en, pn, var_list, V_PDG) case default call parse_node_mismatch & ("grouped_cexpr|block_cexpr|conditional_cexpr|" // & "pdg_code|cvariable|prt_name", pn) end select if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done avalue" end if end subroutine eval_node_compile_avalue @ %def eval_node_compile_avalue @ Compile a PDG-code expression, which is the key [[PDG]] with an integer expression as argument. The procedure is analogous to [[eval_node_compile_unary_function]]. <>= subroutine eval_node_compile_pdg_code (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in), target :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_arg type(eval_node_t), pointer :: en1 type(string_t) :: key type(pdg_array_t) :: aval integer :: t if (debug_active (D_MODEL_F)) then print *, "read PDG code"; call parse_node_write (pn) end if pn_arg => parse_node_get_sub_ptr (pn, 2) call eval_node_compile_expr & (en1, parse_node_get_sub_ptr (pn_arg, tag="expr"), var_list) t = en1%result_type allocate (en) key = "PDG" if (en1%type == EN_CONSTANT) then select case (t) case (V_INT) call pdg_i (aval, en1) call eval_node_init_pdg_array (en, aval) case default; call eval_type_error (pn, char (key), t) end select call eval_node_final_rec (en1) deallocate (en1) else select case (t) case (V_INT); call eval_node_set_op1_pdg (en, pdg_i) case default; call eval_type_error (pn, char (key), t) end select end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done function" end if end subroutine eval_node_compile_pdg_code @ %def eval_node_compile_pdg_code @ This is entirely analogous to [[eval_node_compile_variable]]. However, PDG-array variables occur in different contexts. To avoid name clashes between PDG-array variables and ordinary variables, we prepend a character ([[*]]). This is not visible to the user. <>= subroutine eval_node_compile_cvariable (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in), target :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_name type(string_t) :: var_name type(pdg_array_t), pointer :: aptr type(pdg_array_t), target, save :: no_aval logical, pointer :: known logical, target, save :: unknown = .false. if (debug_active (D_MODEL_F)) then print *, "read cvariable"; call parse_node_write (pn) end if pn_name => pn var_name = parse_node_get_string (pn_name) allocate (en) if (var_list%contains (var_name)) then call var_list%get_aptr (var_name, aptr, known) call eval_node_init_pdg_array_ptr (en, var_name, aptr, known) else call parse_node_write (pn) call msg_error ("This PDG-array variable is undefined at this point") call eval_node_init_pdg_array_ptr (en, var_name, no_aval, unknown) end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done cvariable" end if end subroutine eval_node_compile_cvariable @ %def eval_node_compile_cvariable @ \subsubsection{String expressions} A string expression is either a string value or a concatenation of string values. <>= recursive subroutine eval_node_compile_sexpr (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_svalue, pn_concatenation, pn_op, pn_arg type(eval_node_t), pointer :: en1, en2 type(string_t) :: string if (debug_active (D_MODEL_F)) then print *, "read sexpr"; call parse_node_write (pn) end if pn_svalue => parse_node_get_sub_ptr (pn) call eval_node_compile_svalue (en, pn_svalue, var_list) pn_concatenation => & parse_node_get_next_ptr (pn_svalue, tag="str_concatenation") do while (associated (pn_concatenation)) pn_op => parse_node_get_sub_ptr (pn_concatenation) pn_arg => parse_node_get_next_ptr (pn_op) en1 => en call eval_node_compile_svalue (en2, pn_arg, var_list) allocate (en) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then call concat_ss (string, en1, en2) call eval_node_init_string (en, string) call eval_node_final_rec (en1) call eval_node_final_rec (en2) deallocate (en1, en2) else call eval_node_init_branch & (en, var_str ("concat"), V_STR, en1, en2) call eval_node_set_op2_str (en, concat_ss) end if pn_concatenation => parse_node_get_next_ptr (pn_concatenation) end do if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done sexpr" end if end subroutine eval_node_compile_sexpr @ %def eval_node_compile_sexpr @ A string value is a string literal, a variable, a (grouped) sexpr, a block sexpr, or a conditional. <>= recursive subroutine eval_node_compile_svalue (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list if (debug_active (D_MODEL_F)) then print *, "read svalue"; call parse_node_write (pn) end if select case (char (parse_node_get_rule_key (pn))) case ("svariable") call eval_node_compile_variable (en, pn, var_list, V_STR) case ("sexpr") call eval_node_compile_sexpr (en, pn, var_list) case ("block_sexpr") call eval_node_compile_block_expr (en, pn, var_list, V_STR) case ("conditional_sexpr") call eval_node_compile_conditional (en, pn, var_list, V_STR) case ("sprintf_fun") call eval_node_compile_sprintf (en, pn, var_list) case ("string_literal") allocate (en) call eval_node_init_string (en, parse_node_get_string (pn)) case default call parse_node_mismatch & ("svariable|" // & "grouped_sexpr|block_sexpr|conditional_sexpr|" // & "string_function|string_literal", pn) end select if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done svalue" end if end subroutine eval_node_compile_svalue @ %def eval_node_compile_svalue @ There is currently one string function, [[sprintf]]. For [[sprintf]], the first argument (no brackets) is the format string, the optional arguments in brackets are the expressions or variables to be formatted. <>= recursive subroutine eval_node_compile_sprintf (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_clause, pn_key, pn_args type(parse_node_t), pointer :: pn_arg0 type(eval_node_t), pointer :: en0, en1 integer :: n_args type(string_t) :: key if (debug_active (D_MODEL_F)) then print *, "read sprintf_fun"; call parse_node_write (pn) end if pn_clause => parse_node_get_sub_ptr (pn) pn_key => parse_node_get_sub_ptr (pn_clause) pn_arg0 => parse_node_get_next_ptr (pn_key) pn_args => parse_node_get_next_ptr (pn_clause) call eval_node_compile_sexpr (en0, pn_arg0, var_list) if (associated (pn_args)) then call eval_node_compile_sprintf_args (en1, pn_args, var_list, n_args) else n_args = 0 en1 => null () end if allocate (en) key = parse_node_get_key (pn_key) call eval_node_init_format_string (en, en0, en1, key, n_args) if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done sprintf_fun" end if end subroutine eval_node_compile_sprintf @ %def eval_node_compile_sprintf <>= subroutine eval_node_compile_sprintf_args (en, pn, var_list, n_args) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list integer, intent(out) :: n_args type(parse_node_t), pointer :: pn_arg integer :: i type(eval_node_t), pointer :: en1, en2 n_args = parse_node_get_n_sub (pn) en => null () do i = n_args, 1, -1 pn_arg => parse_node_get_sub_ptr (pn, i) select case (char (parse_node_get_rule_key (pn_arg))) case ("lvariable") call eval_node_compile_variable (en1, pn_arg, var_list, V_LOG) case ("svariable") call eval_node_compile_variable (en1, pn_arg, var_list, V_STR) case ("expr") call eval_node_compile_expr (en1, pn_arg, var_list) case default call parse_node_mismatch ("variable|svariable|lvariable|expr", pn_arg) end select if (associated (en)) then en2 => en allocate (en) call eval_node_init_branch & (en, var_str ("sprintf_arg"), V_NONE, en1, en2) else allocate (en) call eval_node_init_branch & (en, var_str ("sprintf_arg"), V_NONE, en1) end if end do end subroutine eval_node_compile_sprintf_args @ %def eval_node_compile_sprintf_args @ Evaluation. We allocate the argument list and apply the Fortran wrapper for the [[sprintf]] function. <>= subroutine evaluate_sprintf (string, n_args, en_fmt, en_arg) type(string_t), intent(out) :: string integer, intent(in) :: n_args type(eval_node_t), pointer :: en_fmt type(eval_node_t), intent(in), optional, target :: en_arg type(eval_node_t), pointer :: en_branch, en_var type(sprintf_arg_t), dimension(:), allocatable :: arg type(string_t) :: fmt logical :: autoformat integer :: i, j, sprintf_argc autoformat = .not. associated (en_fmt) if (autoformat) fmt = "" if (present (en_arg)) then sprintf_argc = 0 en_branch => en_arg do i = 1, n_args select case (en_branch%arg1%result_type) case (V_CMPLX); sprintf_argc = sprintf_argc + 2 case default ; sprintf_argc = sprintf_argc + 1 end select en_branch => en_branch%arg2 end do allocate (arg (sprintf_argc)) j = 1 en_branch => en_arg do i = 1, n_args en_var => en_branch%arg1 select case (en_var%result_type) case (V_LOG) call sprintf_arg_init (arg(j), en_var%lval) if (autoformat) fmt = fmt // "%s " case (V_INT); call sprintf_arg_init (arg(j), en_var%ival) if (autoformat) fmt = fmt // "%i " case (V_REAL); call sprintf_arg_init (arg(j), en_var%rval) if (autoformat) fmt = fmt // "%g " case (V_STR) call sprintf_arg_init (arg(j), en_var%sval) if (autoformat) fmt = fmt // "%s " case (V_CMPLX) call sprintf_arg_init (arg(j), real (en_var%cval, default)) j = j + 1 call sprintf_arg_init (arg(j), aimag (en_var%cval)) if (autoformat) fmt = fmt // "(%g + %g * I) " case default call eval_node_write (en_var) call msg_error ("sprintf is implemented " & // "for logical, integer, real, and string values only") end select j = j + 1 en_branch => en_branch%arg2 end do else allocate (arg(0)) end if if (autoformat) then string = sprintf (trim (fmt), arg) else string = sprintf (en_fmt%sval, arg) end if end subroutine evaluate_sprintf @ %def evaluate_sprintf @ \subsection{Auxiliary functions for the compiler} Issue an error that the current node could not be compiled because of type mismatch: <>= subroutine eval_type_error (pn, string, t) type(parse_node_t), intent(in) :: pn character(*), intent(in) :: string integer, intent(in) :: t type(string_t) :: type select case (t) case (V_NONE); type = "(none)" case (V_LOG); type = "'logical'" case (V_INT); type = "'integer'" case (V_REAL); type = "'real'" case (V_CMPLX); type = "'complex'" case default; type = "(unknown)" end select call parse_node_write (pn) call msg_fatal (" The " // string // & " operation is not defined for the given argument type " // & char (type)) end subroutine eval_type_error @ %def eval_type_error @ If two numerics are combined, the result is integer if both arguments are integer, if one is integer and the other real or both are real, than its argument is real, otherwise complex. <>= function numeric_result_type (t1, t2) result (t) integer, intent(in) :: t1, t2 integer :: t if (t1 == V_INT .and. t2 == V_INT) then t = V_INT else if (t1 == V_INT .and. t2 == V_REAL) then t = V_REAL else if (t1 == V_REAL .and. t2 == V_INT) then t = V_REAL else if (t1 == V_REAL .and. t2 == V_REAL) then t = V_REAL else t = V_CMPLX end if end function numeric_result_type @ %def numeric_type @ \subsection{Evaluation} Evaluation is done recursively. For leaf nodes nothing is to be done. Evaluating particle-list functions: First, we evaluate the particle lists. If a condition is present, we assign the particle pointers of the condition node to the allocated particle entries in the parent node, keeping in mind that the observables in the variable stack used for the evaluation of the condition also contain pointers to these entries. Then, the assigned procedure is evaluated, which sets the subevent in the parent node. If required, the procedure evaluates the condition node once for each (pair of) particles to determine the result. <>= recursive subroutine eval_node_evaluate (en) type(eval_node_t), intent(inout) :: en logical :: exist select case (en%type) case (EN_UNARY) if (associated (en%arg1)) then call eval_node_evaluate (en%arg1) en%value_is_known = en%arg1%value_is_known else en%value_is_known = .false. end if if (en%value_is_known) then select case (en%result_type) case (V_LOG); en%lval = en%op1_log (en%arg1) case (V_INT); en%ival = en%op1_int (en%arg1) case (V_REAL); en%rval = en%op1_real (en%arg1) case (V_CMPLX); en%cval = en%op1_cmplx (en%arg1) case (V_PDG); call en%op1_pdg (en%aval, en%arg1) case (V_SEV) if (associated (en%arg0)) then call en%op1_sev (en%pval, en%arg1, en%arg0) else call en%op1_sev (en%pval, en%arg1) end if case (V_STR) call en%op1_str (en%sval, en%arg1) end select end if case (EN_BINARY) if (associated (en%arg1) .and. associated (en%arg2)) then call eval_node_evaluate (en%arg1) call eval_node_evaluate (en%arg2) en%value_is_known = & en%arg1%value_is_known .and. en%arg2%value_is_known else en%value_is_known = .false. end if if (en%value_is_known) then select case (en%result_type) case (V_LOG); en%lval = en%op2_log (en%arg1, en%arg2) case (V_INT); en%ival = en%op2_int (en%arg1, en%arg2) case (V_REAL); en%rval = en%op2_real (en%arg1, en%arg2) case (V_CMPLX); en%cval = en%op2_cmplx (en%arg1, en%arg2) case (V_PDG) call en%op2_pdg (en%aval, en%arg1, en%arg2) case (V_SEV) if (associated (en%arg0)) then call en%op2_sev (en%pval, en%arg1, en%arg2, en%arg0) else call en%op2_sev (en%pval, en%arg1, en%arg2) end if case (V_STR) call en%op2_str (en%sval, en%arg1, en%arg2) end select end if case (EN_BLOCK) if (associated (en%arg1) .and. associated (en%arg0)) then call eval_node_evaluate (en%arg1) call eval_node_evaluate (en%arg0) en%value_is_known = en%arg0%value_is_known else en%value_is_known = .false. end if if (en%value_is_known) then select case (en%result_type) case (V_LOG); en%lval = en%arg0%lval case (V_INT); en%ival = en%arg0%ival case (V_REAL); en%rval = en%arg0%rval case (V_CMPLX); en%cval = en%arg0%cval case (V_PDG); en%aval = en%arg0%aval case (V_SEV); en%pval = en%arg0%pval case (V_STR); en%sval = en%arg0%sval end select end if case (EN_CONDITIONAL) if (associated (en%arg0)) then call eval_node_evaluate (en%arg0) en%value_is_known = en%arg0%value_is_known else en%value_is_known = .false. end if if (en%arg0%value_is_known) then if (en%arg0%lval) then call eval_node_evaluate (en%arg1) en%value_is_known = en%arg1%value_is_known if (en%value_is_known) then select case (en%result_type) case (V_LOG); en%lval = en%arg1%lval case (V_INT); en%ival = en%arg1%ival case (V_REAL); en%rval = en%arg1%rval case (V_CMPLX); en%cval = en%arg1%cval case (V_PDG); en%aval = en%arg1%aval case (V_SEV); en%pval = en%arg1%pval case (V_STR); en%sval = en%arg1%sval end select end if else call eval_node_evaluate (en%arg2) en%value_is_known = en%arg2%value_is_known if (en%value_is_known) then select case (en%result_type) case (V_LOG); en%lval = en%arg2%lval case (V_INT); en%ival = en%arg2%ival case (V_REAL); en%rval = en%arg2%rval case (V_CMPLX); en%cval = en%arg2%cval case (V_PDG); en%aval = en%arg2%aval case (V_SEV); en%pval = en%arg2%pval case (V_STR); en%sval = en%arg2%sval end select end if end if end if case (EN_RECORD_CMD) exist = .true. en%lval = .false. call eval_node_evaluate (en%arg0) if (en%arg0%value_is_known) then if (associated (en%arg1)) then call eval_node_evaluate (en%arg1) if (en%arg1%value_is_known) then if (associated (en%arg2)) then call eval_node_evaluate (en%arg2) if (en%arg2%value_is_known) then if (associated (en%arg3)) then call eval_node_evaluate (en%arg3) if (en%arg3%value_is_known) then if (associated (en%arg4)) then call eval_node_evaluate (en%arg4) if (en%arg4%value_is_known) then if (associated (en%rval)) then call analysis_record_data (en%arg0%sval, & en%arg1%rval, en%arg2%rval, & en%arg3%rval, en%arg4%rval, & weight=en%rval, exist=exist, & success=en%lval) else call analysis_record_data (en%arg0%sval, & en%arg1%rval, en%arg2%rval, & en%arg3%rval, en%arg4%rval, & exist=exist, success=en%lval) end if end if else if (associated (en%rval)) then call analysis_record_data (en%arg0%sval, & en%arg1%rval, en%arg2%rval, & en%arg3%rval, & weight=en%rval, exist=exist, & success=en%lval) else call analysis_record_data (en%arg0%sval, & en%arg1%rval, en%arg2%rval, & en%arg3%rval, & exist=exist, success=en%lval) end if end if end if else if (associated (en%rval)) then call analysis_record_data (en%arg0%sval, & en%arg1%rval, en%arg2%rval, & weight=en%rval, exist=exist, & success=en%lval) else call analysis_record_data (en%arg0%sval, & en%arg1%rval, en%arg2%rval, & exist=exist, success=en%lval) end if end if end if else if (associated (en%rval)) then call analysis_record_data (en%arg0%sval, & en%arg1%rval, & weight=en%rval, exist=exist, success=en%lval) else call analysis_record_data (en%arg0%sval, & en%arg1%rval, & exist=exist, success=en%lval) end if end if end if else if (associated (en%rval)) then call analysis_record_data (en%arg0%sval, 1._default, & weight=en%rval, exist=exist, success=en%lval) else call analysis_record_data (en%arg0%sval, 1._default, & exist=exist, success=en%lval) end if end if if (.not. exist) then call msg_error ("Analysis object '" // char (en%arg0%sval) & // "' is undefined") en%arg0%value_is_known = .false. end if end if case (EN_OBS1_INT) en%ival = en%obs1_int (en%prt1) en%value_is_known = .true. case (EN_OBS2_INT) en%ival = en%obs2_int (en%prt1, en%prt2) en%value_is_known = .true. case (EN_OBSEV_INT) en%ival = en%obsev_int (en%pval) en%value_is_known = .true. case (EN_OBS1_REAL) en%rval = en%obs1_real (en%prt1) en%value_is_known = .true. case (EN_OBS2_REAL) en%rval = en%obs2_real (en%prt1, en%prt2) en%value_is_known = .true. case (EN_OBSEV_REAL) en%rval = en%obsev_real (en%pval) en%value_is_known = .true. case (EN_PRT_FUN_UNARY) call eval_node_evaluate (en%arg1) en%value_is_known = en%arg1%value_is_known if (en%value_is_known) then if (associated (en%arg0)) then en%arg0%index => en%index en%arg0%prt1 => en%prt1 call en%op1_sev (en%pval, en%arg1, en%arg0) else call en%op1_sev (en%pval, en%arg1) end if end if case (EN_PRT_FUN_BINARY) call eval_node_evaluate (en%arg1) call eval_node_evaluate (en%arg2) en%value_is_known = & en%arg1%value_is_known .and. en%arg2%value_is_known if (en%value_is_known) then if (associated (en%arg0)) then en%arg0%index => en%index en%arg0%prt1 => en%prt1 en%arg0%prt2 => en%prt2 call en%op2_sev (en%pval, en%arg1, en%arg2, en%arg0) else call en%op2_sev (en%pval, en%arg1, en%arg2) end if end if case (EN_EVAL_FUN_UNARY) call eval_node_evaluate (en%arg1) en%value_is_known = en%arg1%pval%is_nonempty () if (en%value_is_known) then en%arg0%index => en%index en%index = 1 en%arg0%prt1 => en%prt1 en%prt1 = en%arg1%pval%get_prt (1) call eval_node_evaluate (en%arg0) en%rval = en%arg0%rval end if case (EN_EVAL_FUN_BINARY) call eval_node_evaluate (en%arg1) call eval_node_evaluate (en%arg2) en%value_is_known = & en%arg1%pval%is_nonempty () .and. en%arg2%pval%is_nonempty () if (en%value_is_known) then en%arg0%index => en%index en%arg0%prt1 => en%prt1 en%arg0%prt2 => en%prt2 en%index = 1 call eval_pp (en%arg1, en%arg2, en%arg0, en%rval, en%value_is_known) end if case (EN_LOG_FUN_UNARY) call eval_node_evaluate (en%arg1) en%value_is_known = .true. if (en%value_is_known) then en%arg0%index => en%index en%arg0%prt1 => en%prt1 en%lval = en%op1_cut (en%arg1, en%arg0) end if case (EN_LOG_FUN_BINARY) call eval_node_evaluate (en%arg1) call eval_node_evaluate (en%arg2) en%value_is_known = .true. if (en%value_is_known) then en%arg0%index => en%index en%arg0%prt1 => en%prt1 en%arg0%prt2 => en%prt2 en%lval = en%op2_cut (en%arg1, en%arg2, en%arg0) end if case (EN_INT_FUN_UNARY) call eval_node_evaluate (en%arg1) en%value_is_known = en%arg1%value_is_known if (en%value_is_known) then if (associated (en%arg0)) then en%arg0%index => en%index en%arg0%prt1 => en%prt1 call en%op1_evi (en%ival, en%arg1, en%arg0) else call en%op1_evi (en%ival, en%arg1) end if end if case (EN_INT_FUN_BINARY) call eval_node_evaluate (en%arg1) call eval_node_evaluate (en%arg2) en%value_is_known = & en%arg1%value_is_known .and. & en%arg2%value_is_known if (en%value_is_known) then if (associated (en%arg0)) then en%arg0%index => en%index en%arg0%prt1 => en%prt1 en%arg0%prt2 => en%prt2 call en%op2_evi (en%ival, en%arg1, en%arg2, en%arg0) else call en%op2_evi (en%ival, en%arg1, en%arg2) end if end if case (EN_REAL_FUN_UNARY) call eval_node_evaluate (en%arg1) en%value_is_known = en%arg1%value_is_known if (en%value_is_known) then if (associated (en%arg0)) then en%arg0%index => en%index en%arg0%prt1 => en%prt1 call en%op1_evr (en%rval, en%arg1, en%arg0) else call en%op1_evr (en%rval, en%arg1) end if end if case (EN_REAL_FUN_BINARY) call eval_node_evaluate (en%arg1) call eval_node_evaluate (en%arg2) en%value_is_known = & en%arg1%value_is_known .and. & en%arg2%value_is_known if (en%value_is_known) then if (associated (en%arg0)) then en%arg0%index => en%index en%arg0%prt1 => en%prt1 en%arg0%prt2 => en%prt2 call en%op2_evr (en%rval, en%arg1, en%arg2, en%arg0) else call en%op2_evr (en%rval, en%arg1, en%arg2) end if end if case (EN_REAL_FUN_CUM) call eval_node_evaluate (en%arg1) en%value_is_known = .true. if (en%value_is_known) then en%arg0%index => en%index en%arg0%prt1 => en%prt1 en%rval = en%opcum_evr (en%arg1, en%arg0) end if case (EN_FORMAT_STR) if (associated (en%arg0)) then call eval_node_evaluate (en%arg0) en%value_is_known = en%arg0%value_is_known else en%value_is_known = .true. end if if (associated (en%arg1)) then call eval_node_evaluate (en%arg1) en%value_is_known = & en%value_is_known .and. en%arg1%value_is_known if (en%value_is_known) then call evaluate_sprintf (en%sval, en%ival, en%arg0, en%arg1) end if else if (en%value_is_known) then call evaluate_sprintf (en%sval, en%ival, en%arg0) end if end if end select if (debug2_active (D_MODEL_F)) then print *, "eval_node_evaluate" call eval_node_write (en) end if end subroutine eval_node_evaluate @ %def eval_node_evaluate @ \subsubsection{Test method} This is called from a unit test: initialize a particular observable. <>= procedure :: test_obs => eval_node_test_obs <>= subroutine eval_node_test_obs (node, var_list, var_name) class(eval_node_t), intent(inout) :: node type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: var_name procedure(obs_unary_int), pointer :: obs1_iptr type(prt_t), pointer :: p1 call var_list%get_obs1_iptr (var_name, obs1_iptr, p1) call eval_node_init_obs1_int_ptr (node, var_name, obs1_iptr, p1) end subroutine eval_node_test_obs @ %def eval_node_test_obs @ \subsection{Evaluation syntax} We have two different flavors of the syntax: with and without particles. <>= public :: syntax_expr public :: syntax_pexpr <>= type(syntax_t), target, save :: syntax_expr type(syntax_t), target, save :: syntax_pexpr @ %def syntax_expr syntax_pexpr @ These are for testing only and may be removed: <>= public :: syntax_expr_init public :: syntax_pexpr_init <>= subroutine syntax_expr_init () type(ifile_t) :: ifile call define_expr_syntax (ifile, particles=.false., analysis=.false.) call syntax_init (syntax_expr, ifile) call ifile_final (ifile) end subroutine syntax_expr_init subroutine syntax_pexpr_init () type(ifile_t) :: ifile call define_expr_syntax (ifile, particles=.true., analysis=.false.) call syntax_init (syntax_pexpr, ifile) call ifile_final (ifile) end subroutine syntax_pexpr_init @ %def syntax_expr_init syntax_pexpr_init <>= public :: syntax_expr_final public :: syntax_pexpr_final <>= subroutine syntax_expr_final () call syntax_final (syntax_expr) end subroutine syntax_expr_final subroutine syntax_pexpr_final () call syntax_final (syntax_pexpr) end subroutine syntax_pexpr_final @ %def syntax_expr_final syntax_pexpr_final <>= public :: syntax_pexpr_write <>= subroutine syntax_pexpr_write (unit) integer, intent(in), optional :: unit call syntax_write (syntax_pexpr, unit) end subroutine syntax_pexpr_write @ %def syntax_pexpr_write <>= public :: define_expr_syntax @ Numeric expressions. <>= subroutine define_expr_syntax (ifile, particles, analysis) type(ifile_t), intent(inout) :: ifile logical, intent(in) :: particles, analysis type(string_t) :: numeric_pexpr type(string_t) :: var_plist, var_alias if (particles) then numeric_pexpr = " | numeric_pexpr" var_plist = " | var_plist" var_alias = " | var_alias" else numeric_pexpr = "" var_plist = "" var_alias = "" end if call ifile_append (ifile, "SEQ expr = subexpr addition*") call ifile_append (ifile, "ALT subexpr = addition | term") call ifile_append (ifile, "SEQ addition = plus_or_minus term") call ifile_append (ifile, "SEQ term = factor multiplication*") call ifile_append (ifile, "SEQ multiplication = times_or_over factor") call ifile_append (ifile, "SEQ factor = value exponentiation?") call ifile_append (ifile, "SEQ exponentiation = to_the value") call ifile_append (ifile, "ALT plus_or_minus = '+' | '-'") call ifile_append (ifile, "ALT times_or_over = '*' | '/'") call ifile_append (ifile, "ALT to_the = '^' | '**'") call ifile_append (ifile, "KEY '+'") call ifile_append (ifile, "KEY '-'") call ifile_append (ifile, "KEY '*'") call ifile_append (ifile, "KEY '/'") call ifile_append (ifile, "KEY '^'") call ifile_append (ifile, "KEY '**'") call ifile_append (ifile, "ALT value = signed_value | unsigned_value") call ifile_append (ifile, "SEQ signed_value = '-' unsigned_value") call ifile_append (ifile, "ALT unsigned_value = " // & "numeric_value | constant | variable | " // & "result | " // & "grouped_expr | block_expr | conditional_expr | " // & "unary_function | binary_function" // & numeric_pexpr) call ifile_append (ifile, "ALT numeric_value = integer_value | " & // "real_value | complex_value") call ifile_append (ifile, "SEQ integer_value = integer_literal unit_expr?") call ifile_append (ifile, "SEQ real_value = real_literal unit_expr?") call ifile_append (ifile, "SEQ complex_value = complex_literal unit_expr?") call ifile_append (ifile, "INT integer_literal") call ifile_append (ifile, "REA real_literal") call ifile_append (ifile, "COM complex_literal") call ifile_append (ifile, "SEQ unit_expr = unit unit_power?") call ifile_append (ifile, "ALT unit = " // & "TeV | GeV | MeV | keV | eV | meV | " // & "nbarn | pbarn | fbarn | abarn | " // & "rad | mrad | degree | '%'") call ifile_append (ifile, "KEY TeV") call ifile_append (ifile, "KEY GeV") call ifile_append (ifile, "KEY MeV") call ifile_append (ifile, "KEY keV") call ifile_append (ifile, "KEY eV") call ifile_append (ifile, "KEY meV") call ifile_append (ifile, "KEY nbarn") call ifile_append (ifile, "KEY pbarn") call ifile_append (ifile, "KEY fbarn") call ifile_append (ifile, "KEY abarn") call ifile_append (ifile, "KEY rad") call ifile_append (ifile, "KEY mrad") call ifile_append (ifile, "KEY degree") call ifile_append (ifile, "KEY '%'") call ifile_append (ifile, "SEQ unit_power = '^' frac_expr") call ifile_append (ifile, "ALT frac_expr = frac | grouped_frac") call ifile_append (ifile, "GRO grouped_frac = ( frac_expr )") call ifile_append (ifile, "SEQ frac = signed_int div?") call ifile_append (ifile, "ALT signed_int = " & // "neg_int | pos_int | integer_literal") call ifile_append (ifile, "SEQ neg_int = '-' integer_literal") call ifile_append (ifile, "SEQ pos_int = '+' integer_literal") call ifile_append (ifile, "SEQ div = '/' integer_literal") call ifile_append (ifile, "ALT constant = pi | I") call ifile_append (ifile, "KEY pi") call ifile_append (ifile, "KEY I") call ifile_append (ifile, "IDE variable") call ifile_append (ifile, "SEQ result = result_key result_arg") call ifile_append (ifile, "ALT result_key = " // & "num_id | integral | error") call ifile_append (ifile, "KEY num_id") call ifile_append (ifile, "KEY integral") call ifile_append (ifile, "KEY error") call ifile_append (ifile, "GRO result_arg = ( process_id )") call ifile_append (ifile, "IDE process_id") call ifile_append (ifile, "SEQ unary_function = fun_unary function_arg1") call ifile_append (ifile, "SEQ binary_function = fun_binary function_arg2") call ifile_append (ifile, "ALT fun_unary = " // & "complex | real | int | nint | floor | ceiling | abs | conjg | sgn | " // & "sqrt | exp | log | log10 | " // & "sin | cos | tan | asin | acos | atan | " // & "sinh | cosh | tanh | asinh | acosh | atanh") call ifile_append (ifile, "KEY complex") call ifile_append (ifile, "KEY real") call ifile_append (ifile, "KEY int") call ifile_append (ifile, "KEY nint") call ifile_append (ifile, "KEY floor") call ifile_append (ifile, "KEY ceiling") call ifile_append (ifile, "KEY abs") call ifile_append (ifile, "KEY conjg") call ifile_append (ifile, "KEY sgn") call ifile_append (ifile, "KEY sqrt") call ifile_append (ifile, "KEY exp") call ifile_append (ifile, "KEY log") call ifile_append (ifile, "KEY log10") call ifile_append (ifile, "KEY sin") call ifile_append (ifile, "KEY cos") call ifile_append (ifile, "KEY tan") call ifile_append (ifile, "KEY asin") call ifile_append (ifile, "KEY acos") call ifile_append (ifile, "KEY atan") call ifile_append (ifile, "KEY sinh") call ifile_append (ifile, "KEY cosh") call ifile_append (ifile, "KEY tanh") call ifile_append (ifile, "KEY asinh") call ifile_append (ifile, "KEY acosh") call ifile_append (ifile, "KEY atanh") call ifile_append (ifile, "ALT fun_binary = max | min | mod | modulo") call ifile_append (ifile, "KEY max") call ifile_append (ifile, "KEY min") call ifile_append (ifile, "KEY mod") call ifile_append (ifile, "KEY modulo") call ifile_append (ifile, "ARG function_arg1 = ( expr )") call ifile_append (ifile, "ARG function_arg2 = ( expr, expr )") call ifile_append (ifile, "GRO grouped_expr = ( expr )") call ifile_append (ifile, "SEQ block_expr = let var_spec in expr") call ifile_append (ifile, "KEY let") call ifile_append (ifile, "ALT var_spec = " // & "var_num | var_int | var_real | var_complex | " // & "var_logical" // var_plist // var_alias // " | var_string") call ifile_append (ifile, "SEQ var_num = var_name '=' expr") call ifile_append (ifile, "SEQ var_int = int var_name '=' expr") call ifile_append (ifile, "SEQ var_real = real var_name '=' expr") call ifile_append (ifile, "SEQ var_complex = complex var_name '=' complex_expr") call ifile_append (ifile, "ALT complex_expr = " // & "cexpr_real | cexpr_complex") call ifile_append (ifile, "ARG cexpr_complex = ( expr, expr )") call ifile_append (ifile, "SEQ cexpr_real = expr") call ifile_append (ifile, "IDE var_name") call ifile_append (ifile, "KEY '='") call ifile_append (ifile, "KEY in") call ifile_append (ifile, "SEQ conditional_expr = " // & "if lexpr then expr maybe_elsif_expr maybe_else_expr endif") call ifile_append (ifile, "SEQ maybe_elsif_expr = elsif_expr*") call ifile_append (ifile, "SEQ maybe_else_expr = else_expr?") call ifile_append (ifile, "SEQ elsif_expr = elsif lexpr then expr") call ifile_append (ifile, "SEQ else_expr = else expr") call ifile_append (ifile, "KEY if") call ifile_append (ifile, "KEY then") call ifile_append (ifile, "KEY elsif") call ifile_append (ifile, "KEY else") call ifile_append (ifile, "KEY endif") call define_lexpr_syntax (ifile, particles, analysis) call define_sexpr_syntax (ifile) if (particles) then call define_pexpr_syntax (ifile) call define_cexpr_syntax (ifile) call define_var_plist_syntax (ifile) call define_var_alias_syntax (ifile) call define_numeric_pexpr_syntax (ifile) call define_logical_pexpr_syntax (ifile) end if end subroutine define_expr_syntax @ %def define_expr_syntax @ Logical expressions. <>= subroutine define_lexpr_syntax (ifile, particles, analysis) type(ifile_t), intent(inout) :: ifile logical, intent(in) :: particles, analysis type(string_t) :: logical_pexpr, record_cmd if (particles) then logical_pexpr = " | logical_pexpr" else logical_pexpr = "" end if if (analysis) then record_cmd = " | record_cmd" else record_cmd = "" end if call ifile_append (ifile, "SEQ lexpr = lsinglet lsequel*") call ifile_append (ifile, "SEQ lsequel = ';' lsinglet") call ifile_append (ifile, "SEQ lsinglet = lterm alternative*") call ifile_append (ifile, "SEQ alternative = or lterm") call ifile_append (ifile, "SEQ lterm = lvalue coincidence*") call ifile_append (ifile, "SEQ coincidence = and lvalue") call ifile_append (ifile, "KEY ';'") call ifile_append (ifile, "KEY or") call ifile_append (ifile, "KEY and") call ifile_append (ifile, "ALT lvalue = " // & "true | false | lvariable | negation | " // & "grouped_lexpr | block_lexpr | conditional_lexpr | " // & "compared_expr | compared_sexpr" // & logical_pexpr // record_cmd) call ifile_append (ifile, "KEY true") call ifile_append (ifile, "KEY false") call ifile_append (ifile, "SEQ lvariable = '?' alt_lvariable") call ifile_append (ifile, "KEY '?'") call ifile_append (ifile, "ALT alt_lvariable = variable | grouped_lexpr") call ifile_append (ifile, "SEQ negation = not lvalue") call ifile_append (ifile, "KEY not") call ifile_append (ifile, "GRO grouped_lexpr = ( lexpr )") call ifile_append (ifile, "SEQ block_lexpr = let var_spec in lexpr") call ifile_append (ifile, "ALT var_logical = " // & "var_logical_new | var_logical_spec") call ifile_append (ifile, "SEQ var_logical_new = logical var_logical_spec") call ifile_append (ifile, "KEY logical") call ifile_append (ifile, "SEQ var_logical_spec = '?' var_name = lexpr") call ifile_append (ifile, "SEQ conditional_lexpr = " // & "if lexpr then lexpr maybe_elsif_lexpr maybe_else_lexpr endif") call ifile_append (ifile, "SEQ maybe_elsif_lexpr = elsif_lexpr*") call ifile_append (ifile, "SEQ maybe_else_lexpr = else_lexpr?") call ifile_append (ifile, "SEQ elsif_lexpr = elsif lexpr then lexpr") call ifile_append (ifile, "SEQ else_lexpr = else lexpr") call ifile_append (ifile, "SEQ compared_expr = expr comparison+") call ifile_append (ifile, "SEQ comparison = compare expr") call ifile_append (ifile, "ALT compare = " // & "'<' | '>' | '<=' | '>=' | '==' | '<>'") call ifile_append (ifile, "KEY '<'") call ifile_append (ifile, "KEY '>'") call ifile_append (ifile, "KEY '<='") call ifile_append (ifile, "KEY '>='") call ifile_append (ifile, "KEY '=='") call ifile_append (ifile, "KEY '<>'") call ifile_append (ifile, "SEQ compared_sexpr = sexpr str_comparison+") call ifile_append (ifile, "SEQ str_comparison = str_compare sexpr") call ifile_append (ifile, "ALT str_compare = '==' | '<>'") if (analysis) then call ifile_append (ifile, "SEQ record_cmd = " // & "record_key analysis_tag record_arg?") call ifile_append (ifile, "ALT record_key = " // & "record | record_unweighted | record_excess") call ifile_append (ifile, "KEY record") call ifile_append (ifile, "KEY record_unweighted") call ifile_append (ifile, "KEY record_excess") call ifile_append (ifile, "ALT analysis_tag = analysis_id | sexpr") call ifile_append (ifile, "IDE analysis_id") call ifile_append (ifile, "ARG record_arg = ( expr+ )") end if end subroutine define_lexpr_syntax @ %def define_lexpr_syntax @ String expressions. <>= subroutine define_sexpr_syntax (ifile) type(ifile_t), intent(inout) :: ifile call ifile_append (ifile, "SEQ sexpr = svalue str_concatenation*") call ifile_append (ifile, "SEQ str_concatenation = '&' svalue") call ifile_append (ifile, "KEY '&'") call ifile_append (ifile, "ALT svalue = " // & "grouped_sexpr | block_sexpr | conditional_sexpr | " // & "svariable | string_function | string_literal") call ifile_append (ifile, "GRO grouped_sexpr = ( sexpr )") call ifile_append (ifile, "SEQ block_sexpr = let var_spec in sexpr") call ifile_append (ifile, "SEQ conditional_sexpr = " // & "if lexpr then sexpr maybe_elsif_sexpr maybe_else_sexpr endif") call ifile_append (ifile, "SEQ maybe_elsif_sexpr = elsif_sexpr*") call ifile_append (ifile, "SEQ maybe_else_sexpr = else_sexpr?") call ifile_append (ifile, "SEQ elsif_sexpr = elsif lexpr then sexpr") call ifile_append (ifile, "SEQ else_sexpr = else sexpr") call ifile_append (ifile, "SEQ svariable = '$' alt_svariable") call ifile_append (ifile, "KEY '$'") call ifile_append (ifile, "ALT alt_svariable = variable | grouped_sexpr") call ifile_append (ifile, "ALT var_string = " // & "var_string_new | var_string_spec") call ifile_append (ifile, "SEQ var_string_new = string var_string_spec") call ifile_append (ifile, "KEY string") call ifile_append (ifile, "SEQ var_string_spec = '$' var_name = sexpr") ! $ call ifile_append (ifile, "ALT string_function = sprintf_fun") call ifile_append (ifile, "SEQ sprintf_fun = sprintf_clause sprintf_args?") call ifile_append (ifile, "SEQ sprintf_clause = sprintf sexpr") call ifile_append (ifile, "KEY sprintf") call ifile_append (ifile, "ARG sprintf_args = ( sprintf_arg* )") call ifile_append (ifile, "ALT sprintf_arg = " & // "lvariable | svariable | expr") call ifile_append (ifile, "QUO string_literal = '""'...'""'") end subroutine define_sexpr_syntax @ %def define_sexpr_syntax @ Eval trees that evaluate to subevents. <>= subroutine define_pexpr_syntax (ifile) type(ifile_t), intent(inout) :: ifile call ifile_append (ifile, "SEQ pexpr = pterm pconcatenation*") call ifile_append (ifile, "SEQ pconcatenation = '&' pterm") ! call ifile_append (ifile, "KEY '&'") !!! (Key exists already) call ifile_append (ifile, "SEQ pterm = pvalue pcombination*") call ifile_append (ifile, "SEQ pcombination = '+' pvalue") ! call ifile_append (ifile, "KEY '+'") !!! (Key exists already) call ifile_append (ifile, "ALT pvalue = " // & "pexpr_src | pvariable | " // & "grouped_pexpr | block_pexpr | conditional_pexpr | " // & "prt_function") call ifile_append (ifile, "SEQ pexpr_src = prefix_cexpr") call ifile_append (ifile, "ALT prefix_cexpr = " // & "beam_prt | incoming_prt | outgoing_prt | unspecified_prt") call ifile_append (ifile, "SEQ beam_prt = beam cexpr") call ifile_append (ifile, "KEY beam") call ifile_append (ifile, "SEQ incoming_prt = incoming cexpr") call ifile_append (ifile, "KEY incoming") call ifile_append (ifile, "SEQ outgoing_prt = outgoing cexpr") call ifile_append (ifile, "KEY outgoing") call ifile_append (ifile, "SEQ unspecified_prt = cexpr") call ifile_append (ifile, "SEQ pvariable = '@' alt_pvariable") call ifile_append (ifile, "KEY '@'") call ifile_append (ifile, "ALT alt_pvariable = variable | grouped_pexpr") call ifile_append (ifile, "GRO grouped_pexpr = '[' pexpr ']'") call ifile_append (ifile, "SEQ block_pexpr = let var_spec in pexpr") call ifile_append (ifile, "SEQ conditional_pexpr = " // & "if lexpr then pexpr maybe_elsif_pexpr maybe_else_pexpr endif") call ifile_append (ifile, "SEQ maybe_elsif_pexpr = elsif_pexpr*") call ifile_append (ifile, "SEQ maybe_else_pexpr = else_pexpr?") call ifile_append (ifile, "SEQ elsif_pexpr = elsif lexpr then pexpr") call ifile_append (ifile, "SEQ else_pexpr = else pexpr") call ifile_append (ifile, "ALT prt_function = " // & "join_fun | combine_fun | collect_fun | cluster_fun | " // & "photon_reco_fun | " // & "select_fun | extract_fun | sort_fun | " // & "select_b_jet_fun | select_non_b_jet_fun | " // & "select_c_jet_fun | select_light_jet_fun") call ifile_append (ifile, "SEQ join_fun = join_clause pargs2") call ifile_append (ifile, "SEQ combine_fun = combine_clause pargs2") call ifile_append (ifile, "SEQ collect_fun = collect_clause pargs1") call ifile_append (ifile, "SEQ cluster_fun = cluster_clause pargs1") call ifile_append (ifile, "SEQ photon_reco_fun = photon_reco_clause pargs1") call ifile_append (ifile, "SEQ select_fun = select_clause pargs1") call ifile_append (ifile, "SEQ extract_fun = extract_clause pargs1") call ifile_append (ifile, "SEQ sort_fun = sort_clause pargs1") call ifile_append (ifile, "SEQ select_b_jet_fun = " // & "select_b_jet_clause pargs1") call ifile_append (ifile, "SEQ select_non_b_jet_fun = " // & "select_non_b_jet_clause pargs1") call ifile_append (ifile, "SEQ select_c_jet_fun = " // & "select_c_jet_clause pargs1") call ifile_append (ifile, "SEQ select_light_jet_fun = " // & "select_light_jet_clause pargs1") call ifile_append (ifile, "SEQ join_clause = join condition?") call ifile_append (ifile, "SEQ combine_clause = combine condition?") call ifile_append (ifile, "SEQ collect_clause = collect condition?") call ifile_append (ifile, "SEQ cluster_clause = cluster condition?") call ifile_append (ifile, "SEQ photon_reco_clause = photon_recombination condition?") call ifile_append (ifile, "SEQ select_clause = select condition?") call ifile_append (ifile, "SEQ extract_clause = extract position?") call ifile_append (ifile, "SEQ sort_clause = sort criterion?") call ifile_append (ifile, "SEQ select_b_jet_clause = " // & "select_b_jet condition?") call ifile_append (ifile, "SEQ select_non_b_jet_clause = " // & "select_non_b_jet condition?") call ifile_append (ifile, "SEQ select_c_jet_clause = " // & "select_c_jet condition?") call ifile_append (ifile, "SEQ select_light_jet_clause = " // & "select_light_jet condition?") call ifile_append (ifile, "KEY join") call ifile_append (ifile, "KEY combine") call ifile_append (ifile, "KEY collect") call ifile_append (ifile, "KEY cluster") call ifile_append (ifile, "KEY photon_recombination") call ifile_append (ifile, "KEY select") call ifile_append (ifile, "SEQ condition = if lexpr") call ifile_append (ifile, "KEY extract") call ifile_append (ifile, "SEQ position = index expr") call ifile_append (ifile, "KEY sort") call ifile_append (ifile, "KEY select_b_jet") call ifile_append (ifile, "KEY select_non_b_jet") call ifile_append (ifile, "KEY select_c_jet") call ifile_append (ifile, "KEY select_light_jet") call ifile_append (ifile, "SEQ criterion = by expr") call ifile_append (ifile, "KEY index") call ifile_append (ifile, "KEY by") call ifile_append (ifile, "ARG pargs2 = '[' pexpr, pexpr ']'") call ifile_append (ifile, "ARG pargs1 = '[' pexpr, pexpr? ']'") end subroutine define_pexpr_syntax @ %def define_pexpr_syntax @ Eval trees that evaluate to PDG-code arrays. <>= subroutine define_cexpr_syntax (ifile) type(ifile_t), intent(inout) :: ifile call ifile_append (ifile, "SEQ cexpr = avalue concatenation*") call ifile_append (ifile, "SEQ concatenation = ':' avalue") call ifile_append (ifile, "KEY ':'") call ifile_append (ifile, "ALT avalue = " // & "grouped_cexpr | block_cexpr | conditional_cexpr | " // & "variable | pdg_code | prt_name") call ifile_append (ifile, "GRO grouped_cexpr = ( cexpr )") call ifile_append (ifile, "SEQ block_cexpr = let var_spec in cexpr") call ifile_append (ifile, "SEQ conditional_cexpr = " // & "if lexpr then cexpr maybe_elsif_cexpr maybe_else_cexpr endif") call ifile_append (ifile, "SEQ maybe_elsif_cexpr = elsif_cexpr*") call ifile_append (ifile, "SEQ maybe_else_cexpr = else_cexpr?") call ifile_append (ifile, "SEQ elsif_cexpr = elsif lexpr then cexpr") call ifile_append (ifile, "SEQ else_cexpr = else cexpr") call ifile_append (ifile, "SEQ pdg_code = pdg pdg_arg") call ifile_append (ifile, "KEY pdg") call ifile_append (ifile, "ARG pdg_arg = ( expr )") call ifile_append (ifile, "QUO prt_name = '""'...'""'") end subroutine define_cexpr_syntax @ %def define_cexpr_syntax @ Extra variable types. <>= subroutine define_var_plist_syntax (ifile) type(ifile_t), intent(inout) :: ifile call ifile_append (ifile, "ALT var_plist = var_plist_new | var_plist_spec") call ifile_append (ifile, "SEQ var_plist_new = subevt var_plist_spec") call ifile_append (ifile, "KEY subevt") call ifile_append (ifile, "SEQ var_plist_spec = '@' var_name '=' pexpr") end subroutine define_var_plist_syntax subroutine define_var_alias_syntax (ifile) type(ifile_t), intent(inout) :: ifile call ifile_append (ifile, "SEQ var_alias = alias var_name '=' cexpr") call ifile_append (ifile, "KEY alias") end subroutine define_var_alias_syntax @ %def define_var_plist_syntax define_var_alias_syntax @ Particle-list expressions that evaluate to numeric values <>= subroutine define_numeric_pexpr_syntax (ifile) type(ifile_t), intent(inout) :: ifile call ifile_append (ifile, "ALT numeric_pexpr = " & // "eval_fun | count_fun | sum_fun | " & // "prod_fun") call ifile_append (ifile, "SEQ eval_fun = eval expr pargs1") call ifile_append (ifile, "SEQ count_fun = count_clause pargs1") call ifile_append (ifile, "SEQ count_clause = count condition?") call ifile_append (ifile, "SEQ sum_fun = sum expr pargs1") call ifile_append (ifile, "SEQ prod_fun = prod expr pargs1") call ifile_append (ifile, "KEY eval") call ifile_append (ifile, "KEY count") call ifile_append (ifile, "KEY sum") call ifile_append (ifile, "KEY prod") end subroutine define_numeric_pexpr_syntax @ %def define_numeric_pexpr_syntax @ Particle-list functions that evaluate to logical values. <>= subroutine define_logical_pexpr_syntax (ifile) type(ifile_t), intent(inout) :: ifile call ifile_append (ifile, "ALT logical_pexpr = " // & "all_fun | any_fun | no_fun | " // & "photon_isolation_fun") call ifile_append (ifile, "SEQ all_fun = all lexpr pargs1") call ifile_append (ifile, "SEQ any_fun = any lexpr pargs1") call ifile_append (ifile, "SEQ no_fun = no lexpr pargs1") call ifile_append (ifile, "SEQ photon_isolation_fun = " // & "photon_isolation_clause pargs2") call ifile_append (ifile, "SEQ photon_isolation_clause = " // & "photon_isolation condition?") call ifile_append (ifile, "KEY all") call ifile_append (ifile, "KEY any") call ifile_append (ifile, "KEY no") call ifile_append (ifile, "KEY photon_isolation") end subroutine define_logical_pexpr_syntax @ %def define_logical_pexpr_syntax @ All characters that can occur in expressions (apart from alphanumeric). <>= subroutine lexer_init_eval_tree (lexer, particles) type(lexer_t), intent(out) :: lexer logical, intent(in) :: particles type(keyword_list_t), pointer :: keyword_list if (particles) then keyword_list => syntax_get_keyword_list_ptr (syntax_pexpr) else keyword_list => syntax_get_keyword_list_ptr (syntax_expr) end if call lexer_init (lexer, & comment_chars = "#!", & quote_chars = '"', & quote_match = '"', & single_chars = "()[],;:&%?$@", & special_class = [ "+-*/^", "<>=~ " ] , & keyword_list = keyword_list) end subroutine lexer_init_eval_tree @ %def lexer_init_eval_tree @ \subsection{Set up appropriate parse trees} Parse an input stream as a specific flavor of expression. The appropriate expression syntax has to be available. <>= public :: parse_tree_init_expr public :: parse_tree_init_lexpr public :: parse_tree_init_pexpr public :: parse_tree_init_cexpr public :: parse_tree_init_sexpr <>= subroutine parse_tree_init_expr (parse_tree, stream, particles) type(parse_tree_t), intent(out) :: parse_tree type(stream_t), intent(inout), target :: stream logical, intent(in) :: particles type(lexer_t) :: lexer call lexer_init_eval_tree (lexer, particles) call lexer_assign_stream (lexer, stream) if (particles) then call parse_tree_init & (parse_tree, syntax_pexpr, lexer, var_str ("expr")) else call parse_tree_init & (parse_tree, syntax_expr, lexer, var_str ("expr")) end if call lexer_final (lexer) end subroutine parse_tree_init_expr subroutine parse_tree_init_lexpr (parse_tree, stream, particles) type(parse_tree_t), intent(out) :: parse_tree type(stream_t), intent(inout), target :: stream logical, intent(in) :: particles type(lexer_t) :: lexer call lexer_init_eval_tree (lexer, particles) call lexer_assign_stream (lexer, stream) if (particles) then call parse_tree_init & (parse_tree, syntax_pexpr, lexer, var_str ("lexpr")) else call parse_tree_init & (parse_tree, syntax_expr, lexer, var_str ("lexpr")) end if call lexer_final (lexer) end subroutine parse_tree_init_lexpr subroutine parse_tree_init_pexpr (parse_tree, stream) type(parse_tree_t), intent(out) :: parse_tree type(stream_t), intent(inout), target :: stream type(lexer_t) :: lexer call lexer_init_eval_tree (lexer, .true.) call lexer_assign_stream (lexer, stream) call parse_tree_init & (parse_tree, syntax_pexpr, lexer, var_str ("pexpr")) call lexer_final (lexer) end subroutine parse_tree_init_pexpr subroutine parse_tree_init_cexpr (parse_tree, stream) type(parse_tree_t), intent(out) :: parse_tree type(stream_t), intent(inout), target :: stream type(lexer_t) :: lexer call lexer_init_eval_tree (lexer, .true.) call lexer_assign_stream (lexer, stream) call parse_tree_init & (parse_tree, syntax_pexpr, lexer, var_str ("cexpr")) call lexer_final (lexer) end subroutine parse_tree_init_cexpr subroutine parse_tree_init_sexpr (parse_tree, stream, particles) type(parse_tree_t), intent(out) :: parse_tree type(stream_t), intent(inout), target :: stream logical, intent(in) :: particles type(lexer_t) :: lexer call lexer_init_eval_tree (lexer, particles) call lexer_assign_stream (lexer, stream) if (particles) then call parse_tree_init & (parse_tree, syntax_pexpr, lexer, var_str ("sexpr")) else call parse_tree_init & (parse_tree, syntax_expr, lexer, var_str ("sexpr")) end if call lexer_final (lexer) end subroutine parse_tree_init_sexpr @ %def parse_tree_init_expr @ %def parse_tree_init_lexpr @ %def parse_tree_init_pexpr @ %def parse_tree_init_cexpr @ %def parse_tree_init_sexpr @ \subsection{The evaluation tree} The evaluation tree contains the initial variable list and the root node. <>= public :: eval_tree_t <>= type, extends (expr_t) :: eval_tree_t private type(parse_node_t), pointer :: pn => null () type(var_list_t) :: var_list type(eval_node_t), pointer :: root => null () contains <> end type eval_tree_t @ %def eval_tree_t @ Init from stream, using a temporary parse tree. <>= procedure :: init_stream => eval_tree_init_stream <>= subroutine eval_tree_init_stream & (eval_tree, stream, var_list, subevt, result_type) class(eval_tree_t), intent(out), target :: eval_tree type(stream_t), intent(inout), target :: stream type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), target, optional :: subevt integer, intent(in), optional :: result_type type(parse_tree_t) :: parse_tree type(parse_node_t), pointer :: nd_root integer :: type type = V_REAL; if (present (result_type)) type = result_type select case (type) case (V_INT, V_REAL, V_CMPLX) call parse_tree_init_expr (parse_tree, stream, present (subevt)) case (V_LOG) call parse_tree_init_lexpr (parse_tree, stream, present (subevt)) case (V_SEV) call parse_tree_init_pexpr (parse_tree, stream) case (V_PDG) call parse_tree_init_cexpr (parse_tree, stream) case (V_STR) call parse_tree_init_sexpr (parse_tree, stream, present (subevt)) end select nd_root => parse_tree%get_root_ptr () if (associated (nd_root)) then select case (type) case (V_INT, V_REAL, V_CMPLX) call eval_tree_init_expr (eval_tree, nd_root, var_list, subevt) case (V_LOG) call eval_tree_init_lexpr (eval_tree, nd_root, var_list, subevt) case (V_SEV) call eval_tree_init_pexpr (eval_tree, nd_root, var_list, subevt) case (V_PDG) call eval_tree_init_cexpr (eval_tree, nd_root, var_list, subevt) case (V_STR) call eval_tree_init_sexpr (eval_tree, nd_root, var_list, subevt) end select end if call parse_tree_final (parse_tree) end subroutine eval_tree_init_stream @ %def eval_tree_init_stream @ API (to be superseded by the methods below): Init from a given parse-tree node. If we evaluate an expression that contains particle-list references, the original subevent has to be supplied. The initial variable list is optional. <>= procedure :: init_expr => eval_tree_init_expr procedure :: init_lexpr => eval_tree_init_lexpr procedure :: init_pexpr => eval_tree_init_pexpr procedure :: init_cexpr => eval_tree_init_cexpr procedure :: init_sexpr => eval_tree_init_sexpr <>= subroutine eval_tree_init_expr & (expr, parse_node, var_list, subevt) class(eval_tree_t), intent(out), target :: expr type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt call eval_tree_link_var_list (expr, var_list) if (present (subevt)) call eval_tree_set_subevt (expr, subevt) call eval_node_compile_expr & (expr%root, parse_node, expr%var_list) end subroutine eval_tree_init_expr subroutine eval_tree_init_lexpr & (expr, parse_node, var_list, subevt) class(eval_tree_t), intent(out), target :: expr type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt call eval_tree_link_var_list (expr, var_list) if (present (subevt)) call eval_tree_set_subevt (expr, subevt) call eval_node_compile_lexpr & (expr%root, parse_node, expr%var_list) end subroutine eval_tree_init_lexpr subroutine eval_tree_init_pexpr & (expr, parse_node, var_list, subevt) class(eval_tree_t), intent(out), target :: expr type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt call eval_tree_link_var_list (expr, var_list) if (present (subevt)) call eval_tree_set_subevt (expr, subevt) call eval_node_compile_pexpr & (expr%root, parse_node, expr%var_list) end subroutine eval_tree_init_pexpr subroutine eval_tree_init_cexpr & (expr, parse_node, var_list, subevt) class(eval_tree_t), intent(out), target :: expr type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt call eval_tree_link_var_list (expr, var_list) if (present (subevt)) call eval_tree_set_subevt (expr, subevt) call eval_node_compile_cexpr & (expr%root, parse_node, expr%var_list) end subroutine eval_tree_init_cexpr subroutine eval_tree_init_sexpr & (expr, parse_node, var_list, subevt) class(eval_tree_t), intent(out), target :: expr type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt call eval_tree_link_var_list (expr, var_list) if (present (subevt)) call eval_tree_set_subevt (expr, subevt) call eval_node_compile_sexpr & (expr%root, parse_node, expr%var_list) end subroutine eval_tree_init_sexpr @ %def eval_tree_init_expr @ %def eval_tree_init_lexpr @ %def eval_tree_init_pexpr @ %def eval_tree_init_cexpr @ %def eval_tree_init_sexpr @ Alternative: set up the expression using the parse node that has already been stored. We assume that the [[subevt]] or any other variable that may be referred to has already been added to the local variable list. <>= procedure :: setup_expr => eval_tree_setup_expr procedure :: setup_lexpr => eval_tree_setup_lexpr procedure :: setup_pexpr => eval_tree_setup_pexpr procedure :: setup_cexpr => eval_tree_setup_cexpr procedure :: setup_sexpr => eval_tree_setup_sexpr <>= subroutine eval_tree_setup_expr (expr, vars) class(eval_tree_t), intent(inout), target :: expr class(vars_t), intent(in), target :: vars call eval_tree_link_var_list (expr, vars) call eval_node_compile_expr (expr%root, expr%pn, expr%var_list) end subroutine eval_tree_setup_expr subroutine eval_tree_setup_lexpr (expr, vars) class(eval_tree_t), intent(inout), target :: expr class(vars_t), intent(in), target :: vars call eval_tree_link_var_list (expr, vars) call eval_node_compile_lexpr (expr%root, expr%pn, expr%var_list) end subroutine eval_tree_setup_lexpr subroutine eval_tree_setup_pexpr (expr, vars) class(eval_tree_t), intent(inout), target :: expr class(vars_t), intent(in), target :: vars call eval_tree_link_var_list (expr, vars) call eval_node_compile_pexpr (expr%root, expr%pn, expr%var_list) end subroutine eval_tree_setup_pexpr subroutine eval_tree_setup_cexpr (expr, vars) class(eval_tree_t), intent(inout), target :: expr class(vars_t), intent(in), target :: vars call eval_tree_link_var_list (expr, vars) call eval_node_compile_cexpr (expr%root, expr%pn, expr%var_list) end subroutine eval_tree_setup_cexpr subroutine eval_tree_setup_sexpr (expr, vars) class(eval_tree_t), intent(inout), target :: expr class(vars_t), intent(in), target :: vars call eval_tree_link_var_list (expr, vars) call eval_node_compile_sexpr (expr%root, expr%pn, expr%var_list) end subroutine eval_tree_setup_sexpr @ %def eval_tree_setup_expr @ %def eval_tree_setup_lexpr @ %def eval_tree_setup_pexpr @ %def eval_tree_setup_cexpr @ %def eval_tree_setup_sexpr @ This extra API function handles numerical constant expressions only. The only nontrivial part is the optional unit. <>= procedure :: init_numeric_value => eval_tree_init_numeric_value <>= subroutine eval_tree_init_numeric_value (eval_tree, parse_node) class(eval_tree_t), intent(out), target :: eval_tree type(parse_node_t), intent(in), target :: parse_node call eval_node_compile_numeric_value (eval_tree%root, parse_node) end subroutine eval_tree_init_numeric_value @ %def eval_tree_init_numeric_value @ Initialize the variable list, linking it to a context variable list. <>= subroutine eval_tree_link_var_list (eval_tree, vars) type(eval_tree_t), intent(inout), target :: eval_tree class(vars_t), intent(in), target :: vars call eval_tree%var_list%link (vars) end subroutine eval_tree_link_var_list @ %def eval_tree_link_var_list @ Include a subevent object in the initialization. We add a pointer to this as variable [[@evt]] in the local variable list. <>= subroutine eval_tree_set_subevt (eval_tree, subevt) type(eval_tree_t), intent(inout), target :: eval_tree type(subevt_t), intent(in), target :: subevt logical, save, target :: known = .true. - call var_list_append_subevt_ptr & - (eval_tree%var_list, var_str ("@evt"), subevt, known, & - intrinsic=.true.) + call eval_tree%var_list%append_subevt_ptr & + (var_str ("@evt"), subevt, known, intrinsic=.true.) end subroutine eval_tree_set_subevt @ %def eval_tree_set_subevt @ Finalizer. <>= procedure :: final => eval_tree_final <>= subroutine eval_tree_final (expr) class(eval_tree_t), intent(inout) :: expr call expr%var_list%final () if (associated (expr%root)) then call eval_node_final_rec (expr%root) deallocate (expr%root) end if end subroutine eval_tree_final @ %def eval_tree_final @ <>= procedure :: evaluate => eval_tree_evaluate <>= subroutine eval_tree_evaluate (expr) class(eval_tree_t), intent(inout) :: expr if (associated (expr%root)) then call eval_node_evaluate (expr%root) end if end subroutine eval_tree_evaluate @ %def eval_tree_evaluate @ Check if the eval tree is allocated. <>= function eval_tree_is_defined (eval_tree) result (flag) logical :: flag type(eval_tree_t), intent(in) :: eval_tree flag = associated (eval_tree%root) end function eval_tree_is_defined @ %def eval_tree_is_defined @ Check if the eval tree result is constant. <>= function eval_tree_is_constant (eval_tree) result (flag) logical :: flag type(eval_tree_t), intent(in) :: eval_tree if (associated (eval_tree%root)) then flag = eval_tree%root%type == EN_CONSTANT else flag = .false. end if end function eval_tree_is_constant @ %def eval_tree_is_constant @ Insert a conversion node at the root, if necessary (only for real/int conversion) <>= subroutine eval_tree_convert_result (eval_tree, result_type) type(eval_tree_t), intent(inout) :: eval_tree integer, intent(in) :: result_type if (associated (eval_tree%root)) then call insert_conversion_node (eval_tree%root, result_type) end if end subroutine eval_tree_convert_result @ %def eval_tree_convert_result @ Return the value of the top node, after evaluation. If the tree is empty, return the type of [[V_NONE]]. When extracting the value, no check for existence is done. For numeric values, the functions are safe against real/integer mismatch. <>= procedure :: is_known => eval_tree_result_is_known procedure :: get_log => eval_tree_get_log procedure :: get_int => eval_tree_get_int procedure :: get_real => eval_tree_get_real procedure :: get_cmplx => eval_tree_get_cmplx procedure :: get_pdg_array => eval_tree_get_pdg_array procedure :: get_subevt => eval_tree_get_subevt procedure :: get_string => eval_tree_get_string <>= function eval_tree_get_result_type (expr) result (type) integer :: type class(eval_tree_t), intent(in) :: expr if (associated (expr%root)) then type = expr%root%result_type else type = V_NONE end if end function eval_tree_get_result_type function eval_tree_result_is_known (expr) result (flag) logical :: flag class(eval_tree_t), intent(in) :: expr if (associated (expr%root)) then select case (expr%root%result_type) case (V_LOG, V_INT, V_REAL) flag = expr%root%value_is_known case default flag = .true. end select else flag = .false. end if end function eval_tree_result_is_known function eval_tree_result_is_known_ptr (expr) result (ptr) logical, pointer :: ptr class(eval_tree_t), intent(in) :: expr logical, target, save :: known = .true. if (associated (expr%root)) then select case (expr%root%result_type) case (V_LOG, V_INT, V_REAL) ptr => expr%root%value_is_known case default ptr => known end select else ptr => null () end if end function eval_tree_result_is_known_ptr function eval_tree_get_log (expr) result (lval) logical :: lval class(eval_tree_t), intent(in) :: expr if (associated (expr%root)) lval = expr%root%lval end function eval_tree_get_log function eval_tree_get_int (expr) result (ival) integer :: ival class(eval_tree_t), intent(in) :: expr if (associated (expr%root)) then select case (expr%root%result_type) case (V_INT); ival = expr%root%ival case (V_REAL); ival = expr%root%rval case (V_CMPLX); ival = expr%root%cval end select end if end function eval_tree_get_int function eval_tree_get_real (expr) result (rval) real(default) :: rval class(eval_tree_t), intent(in) :: expr if (associated (expr%root)) then select case (expr%root%result_type) case (V_REAL); rval = expr%root%rval case (V_INT); rval = expr%root%ival case (V_CMPLX); rval = expr%root%cval end select end if end function eval_tree_get_real function eval_tree_get_cmplx (expr) result (cval) complex(default) :: cval class(eval_tree_t), intent(in) :: expr if (associated (expr%root)) then select case (expr%root%result_type) case (V_CMPLX); cval = expr%root%cval case (V_REAL); cval = expr%root%rval case (V_INT); cval = expr%root%ival end select end if end function eval_tree_get_cmplx function eval_tree_get_pdg_array (expr) result (aval) type(pdg_array_t) :: aval class(eval_tree_t), intent(in) :: expr if (associated (expr%root)) then aval = expr%root%aval end if end function eval_tree_get_pdg_array function eval_tree_get_subevt (expr) result (pval) type(subevt_t) :: pval class(eval_tree_t), intent(in) :: expr if (associated (expr%root)) then pval = expr%root%pval end if end function eval_tree_get_subevt function eval_tree_get_string (expr) result (sval) type(string_t) :: sval class(eval_tree_t), intent(in) :: expr if (associated (expr%root)) then sval = expr%root%sval end if end function eval_tree_get_string @ %def eval_tree_get_result_type @ %def eval_tree_result_is_known @ %def eval_tree_get_log eval_tree_get_int eval_tree_get_real @ %def eval_tree_get_cmplx @ %def eval_tree_get_pdg_expr @ %def eval_tree_get_pdg_array @ %def eval_tree_get_subevt @ %def eval_tree_get_string @ Return a pointer to the value of the top node. <>= function eval_tree_get_log_ptr (eval_tree) result (lval) logical, pointer :: lval type(eval_tree_t), intent(in) :: eval_tree if (associated (eval_tree%root)) then lval => eval_tree%root%lval else lval => null () end if end function eval_tree_get_log_ptr function eval_tree_get_int_ptr (eval_tree) result (ival) integer, pointer :: ival type(eval_tree_t), intent(in) :: eval_tree if (associated (eval_tree%root)) then ival => eval_tree%root%ival else ival => null () end if end function eval_tree_get_int_ptr function eval_tree_get_real_ptr (eval_tree) result (rval) real(default), pointer :: rval type(eval_tree_t), intent(in) :: eval_tree if (associated (eval_tree%root)) then rval => eval_tree%root%rval else rval => null () end if end function eval_tree_get_real_ptr function eval_tree_get_cmplx_ptr (eval_tree) result (cval) complex(default), pointer :: cval type(eval_tree_t), intent(in) :: eval_tree if (associated (eval_tree%root)) then cval => eval_tree%root%cval else cval => null () end if end function eval_tree_get_cmplx_ptr function eval_tree_get_subevt_ptr (eval_tree) result (pval) type(subevt_t), pointer :: pval type(eval_tree_t), intent(in) :: eval_tree if (associated (eval_tree%root)) then pval => eval_tree%root%pval else pval => null () end if end function eval_tree_get_subevt_ptr function eval_tree_get_pdg_array_ptr (eval_tree) result (aval) type(pdg_array_t), pointer :: aval type(eval_tree_t), intent(in) :: eval_tree if (associated (eval_tree%root)) then aval => eval_tree%root%aval else aval => null () end if end function eval_tree_get_pdg_array_ptr function eval_tree_get_string_ptr (eval_tree) result (sval) type(string_t), pointer :: sval type(eval_tree_t), intent(in) :: eval_tree if (associated (eval_tree%root)) then sval => eval_tree%root%sval else sval => null () end if end function eval_tree_get_string_ptr @ %def eval_tree_get_log_ptr eval_tree_get_int_ptr eval_tree_get_real_ptr @ %def eval_tree_get_cmplx_ptr @ %def eval_tree_get_subevt_ptr eval_tree_get_pdg_array_ptr @ %def eval_tree_get_string_ptr <>= procedure :: write => eval_tree_write <>= subroutine eval_tree_write (expr, unit, write_vars) class(eval_tree_t), intent(in) :: expr integer, intent(in), optional :: unit logical, intent(in), optional :: write_vars integer :: u logical :: vl u = given_output_unit (unit); if (u < 0) return vl = .false.; if (present (write_vars)) vl = write_vars write (u, "(1x,A)") "Evaluation tree:" if (associated (expr%root)) then call eval_node_write_rec (expr%root, unit) else write (u, "(3x,A)") "[empty]" end if - if (vl) call var_list_write (expr%var_list, unit) + if (vl) call expr%var_list%write (unit) end subroutine eval_tree_write @ %def eval_tree_write @ Use the written representation for generating an MD5 sum: <>= function eval_tree_get_md5sum (eval_tree) result (md5sum_et) character(32) :: md5sum_et type(eval_tree_t), intent(in) :: eval_tree integer :: u u = free_unit () open (unit = u, status = "scratch", action = "readwrite") call eval_tree_write (eval_tree, unit=u) rewind (u) md5sum_et = md5sum (u) close (u) end function eval_tree_get_md5sum @ %def eval_tree_get_md5sum @ \subsection{Direct evaluation} These procedures create an eval tree and evaluate it on-the-fly, returning only the final value. The evaluation must yield a well-defined value, unless the [[is_known]] flag is present, which will be set accordingly. <>= public :: eval_log public :: eval_int public :: eval_real public :: eval_cmplx public :: eval_subevt public :: eval_pdg_array public :: eval_string <>= function eval_log & (parse_node, var_list, subevt, is_known) result (lval) logical :: lval type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt logical, intent(out), optional :: is_known type(eval_tree_t), target :: eval_tree call eval_tree_init_lexpr & (eval_tree, parse_node, var_list, subevt) call eval_tree_evaluate (eval_tree) if (eval_tree_result_is_known (eval_tree)) then if (present (is_known)) is_known = .true. lval = eval_tree_get_log (eval_tree) else if (present (is_known)) then is_known = .false. else call eval_tree_unknown (eval_tree, parse_node) lval = .false. end if call eval_tree_final (eval_tree) end function eval_log function eval_int & (parse_node, var_list, subevt, is_known) result (ival) integer :: ival type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt logical, intent(out), optional :: is_known type(eval_tree_t), target :: eval_tree call eval_tree_init_expr & (eval_tree, parse_node, var_list, subevt) call eval_tree_evaluate (eval_tree) if (eval_tree_result_is_known (eval_tree)) then if (present (is_known)) is_known = .true. ival = eval_tree_get_int (eval_tree) else if (present (is_known)) then is_known = .false. else call eval_tree_unknown (eval_tree, parse_node) ival = 0 end if call eval_tree_final (eval_tree) end function eval_int function eval_real & (parse_node, var_list, subevt, is_known) result (rval) real(default) :: rval type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt logical, intent(out), optional :: is_known type(eval_tree_t), target :: eval_tree call eval_tree_init_expr & (eval_tree, parse_node, var_list, subevt) call eval_tree_evaluate (eval_tree) if (eval_tree_result_is_known (eval_tree)) then if (present (is_known)) is_known = .true. rval = eval_tree_get_real (eval_tree) else if (present (is_known)) then is_known = .false. else call eval_tree_unknown (eval_tree, parse_node) rval = 0 end if call eval_tree_final (eval_tree) end function eval_real function eval_cmplx & (parse_node, var_list, subevt, is_known) result (cval) complex(default) :: cval type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt logical, intent(out), optional :: is_known type(eval_tree_t), target :: eval_tree call eval_tree_init_expr & (eval_tree, parse_node, var_list, subevt) call eval_tree_evaluate (eval_tree) if (eval_tree_result_is_known (eval_tree)) then if (present (is_known)) is_known = .true. cval = eval_tree_get_cmplx (eval_tree) else if (present (is_known)) then is_known = .false. else call eval_tree_unknown (eval_tree, parse_node) cval = 0 end if call eval_tree_final (eval_tree) end function eval_cmplx function eval_subevt & (parse_node, var_list, subevt, is_known) result (pval) type(subevt_t) :: pval type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt logical, intent(out), optional :: is_known type(eval_tree_t), target :: eval_tree call eval_tree_init_pexpr & (eval_tree, parse_node, var_list, subevt) call eval_tree_evaluate (eval_tree) if (eval_tree_result_is_known (eval_tree)) then if (present (is_known)) is_known = .true. pval = eval_tree_get_subevt (eval_tree) else if (present (is_known)) then is_known = .false. else call eval_tree_unknown (eval_tree, parse_node) end if call eval_tree_final (eval_tree) end function eval_subevt function eval_pdg_array & (parse_node, var_list, subevt, is_known) result (aval) type(pdg_array_t) :: aval type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt logical, intent(out), optional :: is_known type(eval_tree_t), target :: eval_tree call eval_tree_init_cexpr & (eval_tree, parse_node, var_list, subevt) call eval_tree_evaluate (eval_tree) if (eval_tree_result_is_known (eval_tree)) then if (present (is_known)) is_known = .true. aval = eval_tree_get_pdg_array (eval_tree) else if (present (is_known)) then is_known = .false. else call eval_tree_unknown (eval_tree, parse_node) end if call eval_tree_final (eval_tree) end function eval_pdg_array function eval_string & (parse_node, var_list, subevt, is_known) result (sval) type(string_t) :: sval type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt logical, intent(out), optional :: is_known type(eval_tree_t), target :: eval_tree call eval_tree_init_sexpr & (eval_tree, parse_node, var_list, subevt) call eval_tree_evaluate (eval_tree) if (eval_tree_result_is_known (eval_tree)) then if (present (is_known)) is_known = .true. sval = eval_tree_get_string (eval_tree) else if (present (is_known)) then is_known = .false. else call eval_tree_unknown (eval_tree, parse_node) sval = "" end if call eval_tree_final (eval_tree) end function eval_string @ %def eval_log eval_int eval_real eval_cmplx @ %def eval_subevt eval_pdg_array eval_string @ %def eval_tree_unknown @ Here is a variant that returns numeric values of all possible kinds, the appropriate kind to be selected later: <>= public :: eval_numeric <>= subroutine eval_numeric & (parse_node, var_list, subevt, ival, rval, cval, & is_known, result_type) type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt integer, intent(out), optional :: ival real(default), intent(out), optional :: rval complex(default), intent(out), optional :: cval logical, intent(out), optional :: is_known integer, intent(out), optional :: result_type type(eval_tree_t), target :: eval_tree call eval_tree_init_expr & (eval_tree, parse_node, var_list, subevt) call eval_tree_evaluate (eval_tree) if (eval_tree_result_is_known (eval_tree)) then if (present (ival)) ival = eval_tree_get_int (eval_tree) if (present (rval)) rval = eval_tree_get_real (eval_tree) if (present (cval)) cval = eval_tree_get_cmplx (eval_tree) if (present (is_known)) is_known = .true. else call eval_tree_unknown (eval_tree, parse_node) if (present (ival)) ival = 0 if (present (rval)) rval = 0 if (present (cval)) cval = 0 if (present (is_known)) is_known = .false. end if if (present (result_type)) & result_type = eval_tree_get_result_type (eval_tree) call eval_tree_final (eval_tree) end subroutine eval_numeric @ %def eval_numeric @ Error message with debugging info: <>= subroutine eval_tree_unknown (eval_tree, parse_node) type(eval_tree_t), intent(in) :: eval_tree type(parse_node_t), intent(in) :: parse_node call parse_node_write_rec (parse_node) call eval_tree_write (eval_tree) call msg_error ("Evaluation yields an undefined result, inserting default") end subroutine eval_tree_unknown @ %def eval_tree_unknown @ \subsection{Factory Type} Since [[eval_tree_t]] is an implementation of [[expr_t]], we also need a matching factory type and build method. <>= public :: eval_tree_factory_t <>= type, extends (expr_factory_t) :: eval_tree_factory_t private type(parse_node_t), pointer :: pn => null () contains <> end type eval_tree_factory_t @ %def eval_tree_factory_t @ Output: delegate to the output of the embedded parse node. <>= procedure :: write => eval_tree_factory_write <>= subroutine eval_tree_factory_write (expr_factory, unit) class(eval_tree_factory_t), intent(in) :: expr_factory integer, intent(in), optional :: unit if (associated (expr_factory%pn)) then call parse_node_write_rec (expr_factory%pn, unit) end if end subroutine eval_tree_factory_write @ %def eval_tree_factory_write @ Initializer: take a parse node and hide it thus from the environment. <>= procedure :: init => eval_tree_factory_init <>= subroutine eval_tree_factory_init (expr_factory, pn) class(eval_tree_factory_t), intent(out) :: expr_factory type(parse_node_t), intent(in), pointer :: pn expr_factory%pn => pn end subroutine eval_tree_factory_init @ %def eval_tree_factory_init @ Factory method: allocate expression with correct eval tree type. If the stored parse node is not associate, don't allocate. <>= procedure :: build => eval_tree_factory_build <>= subroutine eval_tree_factory_build (expr_factory, expr) class(eval_tree_factory_t), intent(in) :: expr_factory class(expr_t), intent(out), allocatable :: expr if (associated (expr_factory%pn)) then allocate (eval_tree_t :: expr) select type (expr) type is (eval_tree_t) expr%pn => expr_factory%pn end select end if end subroutine eval_tree_factory_build @ %def eval_tree_factory_build @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[eval_trees_ut.f90]]>>= <> module eval_trees_ut use unit_tests use eval_trees_uti <> <> contains <> end module eval_trees_ut @ %def eval_trees_ut @ <<[[eval_trees_uti.f90]]>>= <> module eval_trees_uti <> <> use ifiles use lexers use lorentz use syntax_rules, only: syntax_write use pdg_arrays use subevents use variables use observables use eval_trees <> <> contains <> end module eval_trees_uti @ %def eval_trees_ut @ API: driver for the unit tests below. <>= public :: expressions_test <>= subroutine expressions_test (u, results) integer, intent(in) :: u type (test_results_t), intent(inout) :: results <> end subroutine expressions_test @ %def expressions_test @ Testing the routines of the expressions module. First a simple unary observable and the node evaluation. <>= call test (expressions_1, "expressions_1", & "check simple observable", & u, results) <>= public :: expressions_1 <>= subroutine expressions_1 (u) integer, intent(in) :: u type(var_list_t), pointer :: var_list => null () type(eval_node_t), pointer :: node => null () type(prt_t), pointer :: prt => null () type(string_t) :: var_name write (u, "(A)") "* Test output: Expressions" write (u, "(A)") "* Purpose: test simple observable and node evaluation" write (u, "(A)") write (u, "(A)") "* Setting a unary observable:" write (u, "(A)") allocate (var_list) allocate (prt) call var_list_set_observables_unary (var_list, prt) call var_list%write (u) write (u, "(A)") "* Evaluating the observable node:" write (u, "(A)") var_name = "PDG" allocate (node) call node%test_obs (var_list, var_name) call node%write (u) write (u, "(A)") "* Cleanup" write (u, "(A)") call node%final_rec () deallocate (node) !!! Workaround for NAGFOR 6.2 ! call var_list%final () deallocate (var_list) deallocate (prt) write (u, "(A)") write (u, "(A)") "* Test output end: expressions_1" end subroutine expressions_1 @ %def expressions_1 @ Parse a complicated expression, transfer it to a parse tree and evaluate. <>= call test (expressions_2, "expressions_2", & "check expression transfer to parse tree", & u, results) <>= public :: expressions_2 <>= subroutine expressions_2 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(stream_t) :: stream type(eval_tree_t) :: eval_tree type(string_t) :: expr_text type(var_list_t), pointer :: var_list => null () write (u, "(A)") "* Test output: Expressions" write (u, "(A)") "* Purpose: test parse routines" write (u, "(A)") call syntax_expr_init () call syntax_write (syntax_expr, u) allocate (var_list) - call var_list_append_real (var_list, var_str ("tolerance"), 0._default) - call var_list_append_real (var_list, var_str ("x"), -5._default) - call var_list_append_int (var_list, var_str ("foo"), -27) - call var_list_append_real (var_list, var_str ("mb"), 4._default) + call var_list%append_real (var_str ("tolerance"), 0._default) + call var_list%append_real (var_str ("x"), -5._default) + call var_list%append_int (var_str ("foo"), -27) + call var_list%append_real (var_str ("mb"), 4._default) expr_text = & "let real twopi = 2 * pi in" // & " twopi * sqrt (25.d0 - mb^2)" // & " / (let int mb_or_0 = max (mb, 0) in" // & " 1 + (if -1 TeV <= x < mb_or_0 then abs(x) else x endif))" call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call var_list%write (u) call eval_tree%init_stream (stream, var_list=var_list) call eval_tree%evaluate () call eval_tree%write (u) write (u, "(A)") "* Input string:" write (u, "(A,A)") " ", char (expr_text) write (u, "(A)") write (u, "(A)") "* Cleanup" call stream_final (stream) call ifile_final (ifile) call eval_tree%final () call var_list%final () deallocate (var_list) call syntax_expr_final () write (u, "(A)") write (u, "(A)") "* Test output end: expressions_2" end subroutine expressions_2 @ %def expressions_2 @ Test a subevent expression. <>= call test (expressions_3, "expressions_3", & "check subevent expressions", & u, results) <>= public :: expressions_3 <>= subroutine expressions_3 (u) integer, intent(in) :: u type(subevt_t) :: subevt write (u, "(A)") "* Test output: Expressions" write (u, "(A)") "* Purpose: test subevent expressions" write (u, "(A)") write (u, "(A)") "* Initialize subevent:" write (u, "(A)") call subevt_init (subevt) call subevt%reset (1) call subevt%set_incoming (1, 22, & vector4_moving (1.e3_default, 1.e3_default, 1), 0._default, [2]) call subevt%write (u) call subevt%reset (4) call subevt%reset (3) call subevt%set_incoming (1, 21, & vector4_moving (1.e3_default, 1.e3_default, 3), 0._default, [1]) call subevt_polarize (subevt, 1, -1) call subevt%set_outgoing (2, 1, & vector4_moving (0._default, 1.e3_default, 3), & -1.e6_default, [7]) call subevt%set_composite (3, & vector4_moving (-1.e3_default, 0._default, 3), [2, 7]) call subevt%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: expressions_3" end subroutine expressions_3 @ %def expressions_3 @ Test expressions from a PDG array. <>= call test (expressions_4, "expressions_4", & "check pdg array expressions", & u, results) <>= public :: expressions_4 <>= subroutine expressions_4 (u) integer, intent(in) :: u type(subevt_t), target :: subevt type(string_t) :: expr_text type(ifile_t) :: ifile type(stream_t) :: stream type(eval_tree_t) :: eval_tree type(var_list_t), pointer :: var_list => null () type(pdg_array_t) :: aval write (u, "(A)") "* Test output: Expressions" write (u, "(A)") "* Purpose: test pdg array expressions" write (u, "(A)") write (u, "(A)") "* Initialization:" write (u, "(A)") call syntax_pexpr_init () call syntax_write (syntax_pexpr, u) allocate (var_list) - call var_list_append_real (var_list, var_str ("tolerance"), 0._default) + call var_list%append_real (var_str ("tolerance"), 0._default) aval = 0 - call var_list_append_pdg_array (var_list, var_str ("particle"), aval) + call var_list%append_pdg_array (var_str ("particle"), aval) aval = [11,-11] - call var_list_append_pdg_array (var_list, var_str ("lepton"), aval) + call var_list%append_pdg_array (var_str ("lepton"), aval) aval = 22 - call var_list_append_pdg_array (var_list, var_str ("photon"), aval) + call var_list%append_pdg_array (var_str ("photon"), aval) aval = 1 - call var_list_append_pdg_array (var_list, var_str ("u"), aval) + call var_list%append_pdg_array (var_str ("u"), aval) call subevt_init (subevt) call subevt%reset (6) call subevt%set_incoming (1, 1, & vector4_moving (1._default, 1._default, 1), 0._default) call subevt%set_incoming (2, -1, & vector4_moving (2._default, 2._default, 1), 0._default) call subevt%set_outgoing (3, 22, & vector4_moving (3._default, 3._default, 1), 0._default) call subevt%set_outgoing (4, 22, & vector4_moving (4._default, 4._default, 1), 0._default) call subevt%set_outgoing (5, 11, & vector4_moving (5._default, 5._default, 1), 0._default) call subevt%set_outgoing (6, -11, & vector4_moving (6._default, 6._default, 1), 0._default) write (u, "(A)") write (u, "(A)") "* Expression:" expr_text = & "let alias quark = pdg(1):pdg(2):pdg(3) in" // & " any E > 3 GeV " // & " [sort by - Pt " // & " [select if Index < 6 " // & " [photon:pdg(-11):pdg(3):quark " // & " & incoming particle]]]" // & " and" // & " eval Theta [extract index -1 [photon]] > 45 degree" // & " and" // & " count [incoming photon] * 3 > 0" write (u, "(A,A)") " ", char (expr_text) write (u, "(A)") write (u, "(A)") write (u, "(A)") "* Extract the evaluation tree:" write (u, "(A)") call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call eval_tree%init_stream (stream, var_list, subevt, V_LOG) call eval_tree%write (u) call eval_tree%evaluate () write (u, "(A)") write (u, "(A)") "* Evaluate the tree:" write (u, "(A)") call eval_tree%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" write (u, "(A)") call stream_final (stream) call ifile_final (ifile) call eval_tree%final () call var_list%final () deallocate (var_list) call syntax_pexpr_final () write (u, "(A)") write (u, "(A)") "* Test output end: expressions_4" end subroutine expressions_4 @ %def expressions_4 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Physics Models} A model object represents a physics model. It contains a table of particle data, a list of parameters, and a vertex table. The list of parameters is a variable list which includes the real parameters (which are pointers to the particle data table) and PDG array variables for the particles themselves. The vertex list is used for phase-space generation, not for calculating the matrix element. The actual numeric model data are in the base type [[model_data_t]], as part of the [[qft]] section. We implement the [[model_t]] as an extension of this, for convenient direct access to the base-type methods via inheritance. (Alternatively, we could delegate these calls explicitly.) The extension contains administrative additions, such as the methods for recalculating derived data and keeping the parameter set consistent. It thus acts as a proxy of the actual model-data object towards the \whizard\ package. There are further proxy objects, such as the [[parameter_t]] array which provides the interface to the actual numeric parameters. Model definitions are read from model files. Therefore, this module contains a parser for model files. The parameter definitions (derived parameters) are Sindarin expressions. The models, as read from file, are stored in a model library which is a simple list of model definitions. For setting up a process object we should make a copy (an instance) of a model, which gets the current parameter values from the global variable list. \subsection{Module} <<[[models.f90]]>>= <> module models use, intrinsic :: iso_c_binding !NODEP! <> use kinds, only: c_default_float <> use io_units use diagnostics use md5 use os_interface use physics_defs, only: UNDEFINED use model_data use ifiles use syntax_rules use lexers use parser use pdg_arrays use variables use expr_base use eval_trees use ttv_formfactors, only: init_parameters <> <> <> <> <> <> contains <> end module models @ %def models @ \subsection{Physics Parameters} A parameter has a name, a value. Derived parameters also have a definition in terms of other parameters, which is stored as an [[eval_tree]]. External parameters are set by an external program. This parameter object should be considered as a proxy object. The parameter name and value are stored in a corresponding [[modelpar_data_t]] object which is located in a [[model_data_t]] object. The latter is a component of the [[model_t]] handler. Methods of [[parameter_t]] can be delegated to the [[par_data_t]] component. The [[block_name]] and [[block_index]] values, if nonempty, indicate the possibility of reading this parameter from a SLHA-type input file. (Within the [[parameter_t]] object, this info is just used for I/O, the actual block register is located in the parent [[model_t]] object.) The [[pn]] component is a pointer to the parameter definition inside the model parse tree. It allows us to recreate the [[eval_tree]] when making copies (instances) of the parameter object. <>= integer, parameter :: PAR_NONE = 0, PAR_UNUSED = -1 integer, parameter :: PAR_INDEPENDENT = 1, PAR_DERIVED = 2 integer, parameter :: PAR_EXTERNAL = 3 @ %def PAR_NONE PAR_INDEPENDENT PAR_DERIVED PAR_EXTERNAL PAR_UNUSED <>= type :: parameter_t private integer :: type = PAR_NONE class(modelpar_data_t), pointer :: data => null () type(string_t) :: block_name integer, dimension(:), allocatable :: block_index type(parse_node_t), pointer :: pn => null () class(expr_t), allocatable :: expr contains <> end type parameter_t @ %def parameter_t @ Initialization depends on parameter type. Independent parameters are initialized by a constant value or a constant numerical expression (which may contain a unit). Derived parameters are initialized by an arbitrary numerical expression, which makes use of the current variable list. The expression is evaluated by the function [[parameter_reset]]. This implementation supports only real parameters and real values. <>= procedure :: init_independent_value => parameter_init_independent_value procedure :: init_independent => parameter_init_independent procedure :: init_derived => parameter_init_derived procedure :: init_external => parameter_init_external procedure :: init_unused => parameter_init_unused <>= subroutine parameter_init_independent_value (par, par_data, name, value) class(parameter_t), intent(out) :: par class(modelpar_data_t), intent(in), target :: par_data type(string_t), intent(in) :: name real(default), intent(in) :: value par%type = PAR_INDEPENDENT par%data => par_data call par%data%init (name, value) end subroutine parameter_init_independent_value subroutine parameter_init_independent (par, par_data, name, pn) class(parameter_t), intent(out) :: par class(modelpar_data_t), intent(in), target :: par_data type(string_t), intent(in) :: name type(parse_node_t), intent(in), target :: pn par%type = PAR_INDEPENDENT par%pn => pn allocate (eval_tree_t :: par%expr) select type (expr => par%expr) type is (eval_tree_t) call expr%init_numeric_value (pn) end select par%data => par_data call par%data%init (name, par%expr%get_real ()) end subroutine parameter_init_independent subroutine parameter_init_derived (par, par_data, name, pn, var_list) class(parameter_t), intent(out) :: par class(modelpar_data_t), intent(in), target :: par_data type(string_t), intent(in) :: name type(parse_node_t), intent(in), target :: pn type(var_list_t), intent(in), target :: var_list par%type = PAR_DERIVED par%pn => pn allocate (eval_tree_t :: par%expr) select type (expr => par%expr) type is (eval_tree_t) call expr%init_expr (pn, var_list=var_list) end select par%data => par_data ! call par%expr%evaluate () call par%data%init (name, 0._default) end subroutine parameter_init_derived subroutine parameter_init_external (par, par_data, name) class(parameter_t), intent(out) :: par class(modelpar_data_t), intent(in), target :: par_data type(string_t), intent(in) :: name par%type = PAR_EXTERNAL par%data => par_data call par%data%init (name, 0._default) end subroutine parameter_init_external subroutine parameter_init_unused (par, par_data, name) class(parameter_t), intent(out) :: par class(modelpar_data_t), intent(in), target :: par_data type(string_t), intent(in) :: name par%type = PAR_UNUSED par%data => par_data call par%data%init (name, 0._default) end subroutine parameter_init_unused @ %def parameter_init_independent_value @ %def parameter_init_independent @ %def parameter_init_derived @ %def parameter_init_external @ %def parameter_init_unused @ The finalizer is needed for the evaluation tree in the definition. <>= procedure :: final => parameter_final <>= subroutine parameter_final (par) class(parameter_t), intent(inout) :: par if (allocated (par%expr)) then call par%expr%final () end if end subroutine parameter_final @ %def parameter_final @ All derived parameters should be recalculated if some independent parameters have changed: <>= procedure :: reset_derived => parameter_reset_derived <>= subroutine parameter_reset_derived (par) class(parameter_t), intent(inout) :: par select case (par%type) case (PAR_DERIVED) call par%expr%evaluate () par%data = par%expr%get_real () end select end subroutine parameter_reset_derived @ %def parameter_reset_derived parameter_reset_external @ Output. [We should have a formula format for the eval tree, suitable for input and output!] <>= procedure :: write => parameter_write <>= subroutine parameter_write (par, unit, write_defs) class(parameter_t), intent(in) :: par integer, intent(in), optional :: unit logical, intent(in), optional :: write_defs logical :: defs integer :: u u = given_output_unit (unit); if (u < 0) return defs = .false.; if (present (write_defs)) defs = write_defs select case (par%type) case (PAR_INDEPENDENT) write (u, "(3x,A)", advance="no") "parameter" call par%data%write (u) case (PAR_DERIVED) write (u, "(3x,A)", advance="no") "derived" call par%data%write (u) case (PAR_EXTERNAL) write (u, "(3x,A)", advance="no") "external" call par%data%write (u) case (PAR_UNUSED) write (u, "(3x,A)", advance="no") "unused" write (u, "(1x,A)", advance="no") char (par%data%get_name ()) end select select case (par%type) case (PAR_INDEPENDENT) if (allocated (par%block_index)) then write (u, "(1x,A,1x,A,*(1x,I0))") & "slha_entry", char (par%block_name), par%block_index else write (u, "(A)") end if case (PAR_DERIVED) if (defs) then call par%expr%write (unit) else write (u, "(A)") end if case default write (u, "(A)") end select end subroutine parameter_write @ %def parameter_write @ Screen output variant. Restrict output to the given parameter type. <>= procedure :: show => parameter_show <>= subroutine parameter_show (par, l, u, partype) class(parameter_t), intent(in) :: par integer, intent(in) :: l, u integer, intent(in) :: partype if (par%type == partype) then call par%data%show (l, u) end if end subroutine parameter_show @ %def parameter_show @ \subsection{SLHA block register} For the optional SLHA interface, the model record contains a register of SLHA-type block names together with index values, which point to a particular parameter. These are private types: <>= type :: slha_entry_t integer, dimension(:), allocatable :: block_index integer :: i_par = 0 end type slha_entry_t @ %def slha_entry_t <>= type :: slha_block_t type(string_t) :: name integer :: n_entry = 0 type(slha_entry_t), dimension(:), allocatable :: entry end type slha_block_t @ %def slha_block_t @ \subsection{Model Object} A model object holds all information about parameters, particles, and vertices. For models that require an external program for parameter calculation, there is the pointer to a function that does this calculation, given the set of independent and derived parameters. As explained above, the type inherits from [[model_data_t]], which is the actual storage for the model data. When reading a model, we create a parse tree. Parameter definitions are available via parse nodes. Since we may need those later when making model instances, we keep the whole parse tree in the model definition (but not in the instances). <>= public :: model_t <>= type, extends (model_data_t) :: model_t private character(32) :: md5sum = "" logical :: ufo_model = .false. type(string_t) :: ufo_path type(string_t), dimension(:), allocatable :: schemes type(string_t), allocatable :: selected_scheme type(parameter_t), dimension(:), allocatable :: par integer :: n_slha_block = 0 type(slha_block_t), dimension(:), allocatable :: slha_block integer :: max_par_name_length = 0 integer :: max_field_name_length = 0 type(var_list_t) :: var_list type(string_t) :: dlname procedure(model_init_external_parameters), nopass, pointer :: & init_external_parameters => null () type(dlaccess_t) :: dlaccess type(parse_tree_t) :: parse_tree contains <> end type model_t @ %def model_t @ This is the interface for a procedure that initializes the calculation of external parameters, given the array of all parameters. <>= abstract interface subroutine model_init_external_parameters (par) bind (C) import real(c_default_float), dimension(*), intent(inout) :: par end subroutine model_init_external_parameters end interface @ %def model_init_external_parameters @ Initialization: Specify the number of parameters, particles, vertices and allocate memory. If an associated DL library is specified, load this library. The model may already carry scheme information, so we have to save and restore the scheme number when actually initializing the [[model_data_t]] base. <>= generic :: init => model_init procedure, private :: model_init <>= subroutine model_init & (model, name, libname, os_data, n_par, n_prt, n_vtx, ufo) class(model_t), intent(inout) :: model type(string_t), intent(in) :: name, libname type(os_data_t), intent(in) :: os_data integer, intent(in) :: n_par, n_prt, n_vtx logical, intent(in), optional :: ufo type(c_funptr) :: c_fptr type(string_t) :: libpath integer :: scheme_num scheme_num = model%get_scheme_num () call model%basic_init (name, n_par, n_prt, n_vtx) if (present (ufo)) model%ufo_model = ufo call model%set_scheme_num (scheme_num) if (libname /= "") then if (.not. os_data%use_testfiles) then libpath = os_data%whizard_models_libpath_local model%dlname = os_get_dlname ( & libpath // "/" // libname, os_data, ignore=.true.) end if if (model%dlname == "") then libpath = os_data%whizard_models_libpath model%dlname = os_get_dlname (libpath // "/" // libname, os_data) end if else model%dlname = "" end if if (model%dlname /= "") then if (.not. dlaccess_is_open (model%dlaccess)) then if (logging) & call msg_message ("Loading model auxiliary library '" & // char (libpath) // "/" // char (model%dlname) // "'") call dlaccess_init (model%dlaccess, os_data%whizard_models_libpath, & model%dlname, os_data) if (dlaccess_has_error (model%dlaccess)) then call msg_message (char (dlaccess_get_error (model%dlaccess))) call msg_fatal ("Loading model auxiliary library '" & // char (model%dlname) // "' failed") return end if c_fptr = dlaccess_get_c_funptr (model%dlaccess, & var_str ("init_external_parameters")) if (dlaccess_has_error (model%dlaccess)) then call msg_message (char (dlaccess_get_error (model%dlaccess))) call msg_fatal ("Loading function from auxiliary library '" & // char (model%dlname) // "' failed") return end if call c_f_procpointer (c_fptr, model% init_external_parameters) end if end if end subroutine model_init @ %def model_init @ For a model instance, we do not attempt to load a DL library. This is the core of the full initializer above. <>= procedure, private :: basic_init => model_basic_init <>= subroutine model_basic_init (model, name, n_par, n_prt, n_vtx) class(model_t), intent(inout) :: model type(string_t), intent(in) :: name integer, intent(in) :: n_par, n_prt, n_vtx allocate (model%par (n_par)) call model%model_data_t%init (name, n_par, 0, n_prt, n_vtx) end subroutine model_basic_init @ %def model_basic_init @ Finalization: The variable list contains allocated pointers, also the parse tree. We also close the DL access object, if any, that enables external parameter calculation. <>= procedure :: final => model_final <>= subroutine model_final (model) class(model_t), intent(inout) :: model integer :: i if (allocated (model%par)) then do i = 1, size (model%par) call model%par(i)%final () end do end if call model%var_list%final (follow_link=.false.) if (model%dlname /= "") call dlaccess_final (model%dlaccess) call parse_tree_final (model%parse_tree) call model%model_data_t%final () end subroutine model_final @ %def model_final @ Output. By default, the output is in the form of an input file. If [[verbose]] is true, for each derived parameter the definition (eval tree) is displayed, and the vertex hash table is shown. <>= procedure :: write => model_write <>= subroutine model_write (model, unit, verbose, & show_md5sum, show_variables, show_parameters, & show_particles, show_vertices, show_scheme) class(model_t), intent(in) :: model integer, intent(in), optional :: unit logical, intent(in), optional :: verbose logical, intent(in), optional :: show_md5sum logical, intent(in), optional :: show_variables logical, intent(in), optional :: show_parameters logical, intent(in), optional :: show_particles logical, intent(in), optional :: show_vertices logical, intent(in), optional :: show_scheme logical :: verb, show_md5, show_par, show_var integer :: u, i u = given_output_unit (unit); if (u < 0) return verb = .false.; if (present (verbose)) verb = verbose show_md5 = .true.; if (present (show_md5sum)) & show_md5 = show_md5sum show_par = .true.; if (present (show_parameters)) & show_par = show_parameters show_var = verb; if (present (show_variables)) & show_var = show_variables write (u, "(A,A,A)") 'model "', char (model%get_name ()), '"' if (show_md5 .and. model%md5sum /= "") & write (u, "(1x,A,A,A)") "! md5sum = '", model%md5sum, "'" if (model%is_ufo_model ()) then write (u, "(1x,A)") "! model derived from UFO source" else if (model%has_schemes ()) then write (u, "(1x,A)", advance="no") "! schemes =" do i = 1, size (model%schemes) if (i > 1) write (u, "(',')", advance="no") write (u, "(1x,A,A,A)", advance="no") & "'", char (model%schemes(i)), "'" end do write (u, *) if (allocated (model%selected_scheme)) then write (u, "(1x,A,A,A,I0,A)") & "! selected scheme = '", char (model%get_scheme ()), & "' (", model%get_scheme_num (), ")" end if end if if (show_par) then write (u, "(A)") do i = 1, size (model%par) call model%par(i)%write (u, write_defs=verbose) end do end if call model%model_data_t%write (unit, verbose, & show_md5sum, show_variables, & show_parameters=.false., & show_particles=show_particles, & show_vertices=show_vertices, & show_scheme=show_scheme) if (show_var) then write (u, "(A)") - call var_list_write (model%var_list, unit, follow_link=.false.) + call model%var_list%write (unit, follow_link=.false.) end if end subroutine model_write @ %def model_write @ Screen output, condensed form. <>= procedure :: show => model_show <>= subroutine model_show (model, unit) class(model_t), intent(in) :: model integer, intent(in), optional :: unit integer :: i, u, l u = given_output_unit (unit) write (u, "(A,1x,A)") "Model:", char (model%get_name ()) if (model%has_schemes ()) then write (u, "(2x,A,A,A,I0,A)") "Scheme: '", & char (model%get_scheme ()), "' (", model%get_scheme_num (), ")" end if l = model%max_field_name_length call model%show_fields (l, u) l = model%max_par_name_length if (any (model%par%type == PAR_INDEPENDENT)) then write (u, "(2x,A)") "Independent parameters:" do i = 1, size (model%par) call model%par(i)%show (l, u, PAR_INDEPENDENT) end do end if if (any (model%par%type == PAR_DERIVED)) then write (u, "(2x,A)") "Derived parameters:" do i = 1, size (model%par) call model%par(i)%show (l, u, PAR_DERIVED) end do end if if (any (model%par%type == PAR_EXTERNAL)) then write (u, "(2x,A)") "External parameters:" do i = 1, size (model%par) call model%par(i)%show (l, u, PAR_EXTERNAL) end do end if if (any (model%par%type == PAR_UNUSED)) then write (u, "(2x,A)") "Unused parameters:" do i = 1, size (model%par) call model%par(i)%show (l, u, PAR_UNUSED) end do end if end subroutine model_show @ %def model_show @ Show all fields/particles. <>= procedure :: show_fields => model_show_fields <>= subroutine model_show_fields (model, l, unit) class(model_t), intent(in), target :: model integer, intent(in) :: l integer, intent(in), optional :: unit type(field_data_t), pointer :: field integer :: u, i u = given_output_unit (unit) write (u, "(2x,A)") "Particles:" do i = 1, model%get_n_field () field => model%get_field_ptr_by_index (i) call field%show (l, u) end do end subroutine model_show_fields @ %def model_data_show_fields @ Show the list of stable, unstable, polarized, or unpolarized particles, respectively. <>= procedure :: show_stable => model_show_stable procedure :: show_unstable => model_show_unstable procedure :: show_polarized => model_show_polarized procedure :: show_unpolarized => model_show_unpolarized <>= subroutine model_show_stable (model, unit) class(model_t), intent(in), target :: model integer, intent(in), optional :: unit type(field_data_t), pointer :: field integer :: u, i u = given_output_unit (unit) write (u, "(A,1x)", advance="no") "Stable particles:" do i = 1, model%get_n_field () field => model%get_field_ptr_by_index (i) if (field%is_stable (.false.)) then write (u, "(1x,A)", advance="no") char (field%get_name (.false.)) end if if (field%has_antiparticle ()) then if (field%is_stable (.true.)) then write (u, "(1x,A)", advance="no") char (field%get_name (.true.)) end if end if end do write (u, *) end subroutine model_show_stable subroutine model_show_unstable (model, unit) class(model_t), intent(in), target :: model integer, intent(in), optional :: unit type(field_data_t), pointer :: field integer :: u, i u = given_output_unit (unit) write (u, "(A,1x)", advance="no") "Unstable particles:" do i = 1, model%get_n_field () field => model%get_field_ptr_by_index (i) if (.not. field%is_stable (.false.)) then write (u, "(1x,A)", advance="no") char (field%get_name (.false.)) end if if (field%has_antiparticle ()) then if (.not. field%is_stable (.true.)) then write (u, "(1x,A)", advance="no") char (field%get_name (.true.)) end if end if end do write (u, *) end subroutine model_show_unstable subroutine model_show_polarized (model, unit) class(model_t), intent(in), target :: model integer, intent(in), optional :: unit type(field_data_t), pointer :: field integer :: u, i u = given_output_unit (unit) write (u, "(A,1x)", advance="no") "Polarized particles:" do i = 1, model%get_n_field () field => model%get_field_ptr_by_index (i) if (field%is_polarized (.false.)) then write (u, "(1x,A)", advance="no") char (field%get_name (.false.)) end if if (field%has_antiparticle ()) then if (field%is_polarized (.true.)) then write (u, "(1x,A)", advance="no") char (field%get_name (.true.)) end if end if end do write (u, *) end subroutine model_show_polarized subroutine model_show_unpolarized (model, unit) class(model_t), intent(in), target :: model integer, intent(in), optional :: unit type(field_data_t), pointer :: field integer :: u, i u = given_output_unit (unit) write (u, "(A,1x)", advance="no") "Unpolarized particles:" do i = 1, model%get_n_field () field => model%get_field_ptr_by_index (i) if (.not. field%is_polarized (.false.)) then write (u, "(1x,A)", advance="no") & char (field%get_name (.false.)) end if if (field%has_antiparticle ()) then if (.not. field%is_polarized (.true.)) then write (u, "(1x,A)", advance="no") char (field%get_name (.true.)) end if end if end do write (u, *) end subroutine model_show_unpolarized @ %def model_show_stable @ %def model_show_unstable @ %def model_show_polarized @ %def model_show_unpolarized @ Retrieve the MD5 sum of a model (actually, of the model file). <>= procedure :: get_md5sum => model_get_md5sum <>= function model_get_md5sum (model) result (md5sum) character(32) :: md5sum class(model_t), intent(in) :: model md5sum = model%md5sum end function model_get_md5sum @ %def model_get_md5sum @ Parameters are defined by an expression which may be constant or arbitrary. <>= procedure :: & set_parameter_constant => model_set_parameter_constant procedure, private :: & set_parameter_parse_node => model_set_parameter_parse_node procedure :: & set_parameter_external => model_set_parameter_external procedure :: & set_parameter_unused => model_set_parameter_unused <>= subroutine model_set_parameter_constant (model, i, name, value) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(string_t), intent(in) :: name real(default), intent(in) :: value logical, save, target :: known = .true. class(modelpar_data_t), pointer :: par_data real(default), pointer :: value_ptr par_data => model%get_par_real_ptr (i) call model%par(i)%init_independent_value (par_data, name, value) value_ptr => par_data%get_real_ptr () - call var_list_append_real_ptr (model%var_list, & - name, value_ptr, & + call model%var_list%append_real_ptr (name, value_ptr, & is_known=known, intrinsic=.true.) model%max_par_name_length = max (model%max_par_name_length, len (name)) end subroutine model_set_parameter_constant subroutine model_set_parameter_parse_node (model, i, name, pn, constant) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(string_t), intent(in) :: name type(parse_node_t), intent(in), target :: pn logical, intent(in) :: constant logical, save, target :: known = .true. class(modelpar_data_t), pointer :: par_data real(default), pointer :: value_ptr par_data => model%get_par_real_ptr (i) if (constant) then call model%par(i)%init_independent (par_data, name, pn) else call model%par(i)%init_derived (par_data, name, pn, model%var_list) end if value_ptr => par_data%get_real_ptr () - call var_list_append_real_ptr (model%var_list, & - name, value_ptr, & + call model%var_list%append_real_ptr (name, value_ptr, & is_known=known, locked=.not.constant, intrinsic=.true.) model%max_par_name_length = max (model%max_par_name_length, len (name)) end subroutine model_set_parameter_parse_node subroutine model_set_parameter_external (model, i, name) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(string_t), intent(in) :: name logical, save, target :: known = .true. class(modelpar_data_t), pointer :: par_data real(default), pointer :: value_ptr par_data => model%get_par_real_ptr (i) call model%par(i)%init_external (par_data, name) value_ptr => par_data%get_real_ptr () - call var_list_append_real_ptr (model%var_list, & - name, value_ptr, & + call model%var_list%append_real_ptr (name, value_ptr, & is_known=known, locked=.true., intrinsic=.true.) model%max_par_name_length = max (model%max_par_name_length, len (name)) end subroutine model_set_parameter_external subroutine model_set_parameter_unused (model, i, name) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(string_t), intent(in) :: name class(modelpar_data_t), pointer :: par_data par_data => model%get_par_real_ptr (i) call model%par(i)%init_unused (par_data, name) - call var_list_append_real (model%var_list, & - name, locked=.true., intrinsic=.true.) + call model%var_list%append_real (name, locked=.true., intrinsic=.true.) model%max_par_name_length = max (model%max_par_name_length, len (name)) end subroutine model_set_parameter_unused @ %def model_set_parameter @ Make a copy of a parameter. We assume that the [[model_data_t]] parameter arrays have already been copied, so names and values are available in the current model, and can be used as targets. The eval tree should not be copied, since it should refer to the new variable list. The safe solution is to make use of the above initializers, which also take care of the building a new variable list. <>= procedure, private :: copy_parameter => model_copy_parameter <>= subroutine model_copy_parameter (model, i, par) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(parameter_t), intent(in) :: par type(string_t) :: name real(default) :: value name = par%data%get_name () select case (par%type) case (PAR_INDEPENDENT) if (associated (par%pn)) then call model%set_parameter_parse_node (i, name, par%pn, & constant = .true.) else value = par%data%get_real () call model%set_parameter_constant (i, name, value) end if if (allocated (par%block_index)) then model%par(i)%block_name = par%block_name model%par(i)%block_index = par%block_index end if case (PAR_DERIVED) call model%set_parameter_parse_node (i, name, par%pn, & constant = .false.) case (PAR_EXTERNAL) call model%set_parameter_external (i, name) case (PAR_UNUSED) call model%set_parameter_unused (i, name) end select end subroutine model_copy_parameter @ %def model_copy_parameter @ Recalculate all derived parameters. <>= procedure :: update_parameters => model_parameters_update <>= subroutine model_parameters_update (model) class(model_t), intent(inout) :: model integer :: i real(default), dimension(:), allocatable :: par do i = 1, size (model%par) call model%par(i)%reset_derived () end do if (associated (model%init_external_parameters)) then allocate (par (model%get_n_real ())) call model%real_parameters_to_c_array (par) call model%init_external_parameters (par) call model%real_parameters_from_c_array (par) if (model%get_name() == var_str ("SM_tt_threshold")) & call set_threshold_parameters () end if contains subroutine set_threshold_parameters () real(default) :: mpole, wtop !!! !!! !!! Workaround for OS-X and BSD which do not load !!! !!! !!! the global values created previously. Therefore !!! !!! !!! a second initialization for the threshold model, !!! !!! !!! where M1S is required to compute the top mass. call init_parameters (mpole, wtop, & par(20), par(21), par(22), & par(19), par(39), par(4), par(1), & par(2), par(10), par(24), par(25), & par(23), par(26), par(27), par(29), & par(30), par(31), par(32), par(33), & par(36) > 0._default, par(28)) end subroutine set_threshold_parameters end subroutine model_parameters_update @ %def model_parameters_update @ Initialize field data with PDG long name and PDG code. <>= procedure, private :: init_field => model_init_field <>= subroutine model_init_field (model, i, longname, pdg) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(string_t), intent(in) :: longname integer, intent(in) :: pdg type(field_data_t), pointer :: field field => model%get_field_ptr_by_index (i) call field%init (longname, pdg) end subroutine model_init_field @ %def model_init_field @ Copy field data for index [[i]] from another particle which serves as a template. The name should be the unique long name. <>= procedure, private :: copy_field => model_copy_field <>= subroutine model_copy_field (model, i, name_src) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(string_t), intent(in) :: name_src type(field_data_t), pointer :: field_src, field field_src => model%get_field_ptr (name_src) field => model%get_field_ptr_by_index (i) call field%copy_from (field_src) end subroutine model_copy_field @ %def model_copy_field @ \subsection{Model Access via Variables} Write the model variable list. <>= procedure :: write_var_list => model_write_var_list <>= subroutine model_write_var_list (model, unit, follow_link) class(model_t), intent(in) :: model integer, intent(in), optional :: unit logical, intent(in), optional :: follow_link - call var_list_write (model%var_list, unit, follow_link) + call model%var_list%write (unit, follow_link) end subroutine model_write_var_list @ %def model_write_var_list @ Link a variable list to the model variables. <>= procedure :: link_var_list => model_link_var_list <>= subroutine model_link_var_list (model, var_list) class(model_t), intent(inout) :: model type(var_list_t), intent(in), target :: var_list call model%var_list%link (var_list) end subroutine model_link_var_list @ %def model_link_var_list @ Check if the model contains a named variable. <>= procedure :: var_exists => model_var_exists <>= function model_var_exists (model, name) result (flag) class(model_t), intent(in) :: model type(string_t), intent(in) :: name logical :: flag flag = model%var_list%contains (name, follow_link=.false.) end function model_var_exists @ %def model_var_exists @ Check if the model variable is a derived parameter, i.e., locked. <>= procedure :: var_is_locked => model_var_is_locked <>= function model_var_is_locked (model, name) result (flag) class(model_t), intent(in) :: model type(string_t), intent(in) :: name logical :: flag flag = model%var_list%is_locked (name, follow_link=.false.) end function model_var_is_locked @ %def model_var_is_locked @ Set a model parameter via the named variable. We assume that the variable exists and is writable, i.e., non-locked. We update the model and variable list, so independent and derived parameters are always synchronized. <>= procedure :: set_real => model_var_set_real <>= subroutine model_var_set_real (model, name, rval, verbose, pacified) class(model_t), intent(inout) :: model type(string_t), intent(in) :: name real(default), intent(in) :: rval logical, intent(in), optional :: verbose, pacified call model%var_list%set_real (name, rval, & is_known=.true., ignore=.false., & verbose=verbose, model_name=model%get_name (), pacified=pacified) call model%update_parameters () end subroutine model_var_set_real @ %def model_var_set_real @ Retrieve a model parameter value. <>= procedure :: get_rval => model_var_get_rval <>= function model_var_get_rval (model, name) result (rval) class(model_t), intent(in) :: model type(string_t), intent(in) :: name real(default) :: rval rval = model%var_list%get_rval (name, follow_link=.false.) end function model_var_get_rval @ %def model_var_get_rval @ [To be deleted] Return a pointer to the variable list. <>= procedure :: get_var_list_ptr => model_get_var_list_ptr <>= function model_get_var_list_ptr (model) result (var_list) type(var_list_t), pointer :: var_list class(model_t), intent(in), target :: model var_list => model%var_list end function model_get_var_list_ptr @ %def model_get_var_list_ptr @ \subsection{UFO models} A single flag identifies a model as a UFO model. There is no other distinction, but the flag allows us to handle built-in and UFO models with the same name in parallel. <>= procedure :: is_ufo_model => model_is_ufo_model <>= function model_is_ufo_model (model) result (flag) class(model_t), intent(in) :: model logical :: flag flag = model%ufo_model end function model_is_ufo_model @ %def model_is_ufo_model @ Return the UFO path used for fetching the UFO source. <>= procedure :: get_ufo_path => model_get_ufo_path <>= function model_get_ufo_path (model) result (path) class(model_t), intent(in) :: model type(string_t) :: path if (model%ufo_model) then path = model%ufo_path else path = "" end if end function model_get_ufo_path @ %def model_get_ufo_path @ Call OMega and generate a model file from an UFO source file. We start with a file name; the model name is expected to be the base name, stripping extensions. The path search either takes [[ufo_path_requested]], or searches first in the working directory, then in a hard-coded UFO model directory. <>= subroutine model_generate_ufo (filename, os_data, ufo_path, & ufo_path_requested) type(string_t), intent(in) :: filename type(os_data_t), intent(in) :: os_data type(string_t), intent(out) :: ufo_path type(string_t), intent(in), optional :: ufo_path_requested type(string_t) :: model_name, omega_path, ufo_dir, ufo_init logical :: exist call get_model_name (filename, model_name) call msg_message ("Model: Generating model '" // char (model_name) & // "' from UFO sources") if (present (ufo_path_requested)) then call msg_message ("Model: Searching for UFO sources in '" & // char (ufo_path_requested) // "'") ufo_path = ufo_path_requested ufo_dir = ufo_path_requested // "/" // model_name ufo_init = ufo_dir // "/" // "__init__.py" inquire (file = char (ufo_init), exist = exist) else call msg_message ("Model: Searching for UFO sources in & &working directory") ufo_path = "." ufo_dir = ufo_path // "/" // model_name ufo_init = ufo_dir // "/" // "__init__.py" inquire (file = char (ufo_init), exist = exist) if (.not. exist) then ufo_path = char (os_data%whizard_modelpath_ufo) ufo_dir = ufo_path // "/" // model_name ufo_init = ufo_dir // "/" // "__init__.py" call msg_message ("Model: Searching for UFO sources in '" & // char (os_data%whizard_modelpath_ufo) // "'") inquire (file = char (ufo_init), exist = exist) end if end if if (exist) then call msg_message ("Model: Found UFO sources for model '" & // char (model_name) // "'") else call msg_fatal ("Model: UFO sources for model '" & // char (model_name) // "' not found") end if omega_path = os_data%whizard_omega_binpath // "/omega_UFO.opt" call os_system_call (omega_path & // " -model:UFO_dir " // ufo_dir & // " -model:exec" & // " -model:write_WHIZARD" & // " > " // filename) inquire (file = char (filename), exist = exist) if (exist) then call msg_message ("Model: Model file '" // char (filename) //& "' generated") else call msg_fatal ("Model: Model file '" // char (filename) & // "' could not be generated") end if contains subroutine get_model_name (filename, model_name) type(string_t), intent(in) :: filename type(string_t), intent(out) :: model_name type(string_t) :: string string = filename call split (string, model_name, ".") end subroutine get_model_name end subroutine model_generate_ufo @ %def model_generate_ufo @ \subsection{Scheme handling} A model can specify a set of allowed schemes that steer the setup of model variables. The model file can contain scheme-specific declarations that are selected by a [[select scheme]] clause. Scheme support is optional. If enabled, the model object contains a list of allowed schemes, and the model reader takes the active scheme as an argument. After the model has been read, the scheme is fixed and can no longer be modified. The model supports schemes if the scheme array is allocated. <>= procedure :: has_schemes => model_has_schemes <>= function model_has_schemes (model) result (flag) logical :: flag class(model_t), intent(in) :: model flag = allocated (model%schemes) end function model_has_schemes @ %def model_has_schemes @ Enable schemes: fix the list of allowed schemes. <>= procedure :: enable_schemes => model_enable_schemes <>= subroutine model_enable_schemes (model, scheme) class(model_t), intent(inout) :: model type(string_t), dimension(:), intent(in) :: scheme allocate (model%schemes (size (scheme)), source = scheme) end subroutine model_enable_schemes @ %def model_enable_schemes @ Find the scheme. Check if the scheme is allowed. The numeric index of the selected scheme is stored in the [[model_data_t]] base object. If no argument is given, select the first scheme. The numeric scheme ID will then be $1$, while a model without schemes retains $0$. <>= procedure :: set_scheme => model_set_scheme <>= subroutine model_set_scheme (model, scheme) class(model_t), intent(inout) :: model type(string_t), intent(in), optional :: scheme logical :: ok integer :: i if (model%has_schemes ()) then if (present (scheme)) then ok = .false. CHECK_SCHEME: do i = 1, size (model%schemes) if (scheme == model%schemes(i)) then allocate (model%selected_scheme, source = scheme) call model%set_scheme_num (i) ok = .true. exit CHECK_SCHEME end if end do CHECK_SCHEME if (.not. ok) then call msg_fatal & ("Model '" // char (model%get_name ()) & // "': scheme '" // char (scheme) // "' not supported") end if else allocate (model%selected_scheme, source = model%schemes(1)) call model%set_scheme_num (1) end if else if (present (scheme)) then call msg_error & ("Model '" // char (model%get_name ()) & // "' does not support schemes") end if end if end subroutine model_set_scheme @ %def model_set_scheme @ Get the scheme. Note that the base [[model_data_t]] provides a [[get_scheme_num]] getter function. <>= procedure :: get_scheme => model_get_scheme <>= function model_get_scheme (model) result (scheme) class(model_t), intent(in) :: model type(string_t) :: scheme if (allocated (model%selected_scheme)) then scheme = model%selected_scheme else scheme = "" end if end function model_get_scheme @ %def model_get_scheme @ Check if a model has been set up with a specific name and (if applicable) scheme. This helps in determining whether we need a new model object. A UFO model is considered to be distinct from a non-UFO model. We assume that if [[ufo]] is asked for, there is no scheme argument. Furthermore, if there is an [[ufo_path]] requested, it must coincide with the [[ufo_path]] of the model. If not, the model [[ufo_path]] is not checked. <>= procedure :: matches => model_matches <>= function model_matches (model, name, scheme, ufo, ufo_path) result (flag) logical :: flag class(model_t), intent(in) :: model type(string_t), intent(in) :: name type(string_t), intent(in), optional :: scheme logical, intent(in), optional :: ufo type(string_t), intent(in), optional :: ufo_path logical :: ufo_model ufo_model = .false.; if (present (ufo)) ufo_model = ufo if (name /= model%get_name ()) then flag = .false. else if (ufo_model .neqv. model%is_ufo_model ()) then flag = .false. else if (ufo_model) then if (present (ufo_path)) then flag = model%get_ufo_path () == ufo_path else flag = .true. end if else if (model%has_schemes ()) then if (present (scheme)) then flag = model%get_scheme () == scheme else flag = model%get_scheme_num () == 1 end if else if (present (scheme)) then flag = .false. else flag = .true. end if end function model_matches @ %def model_matches @ \subsection{SLHA-type interface} Abusing the original strict SUSY Les Houches Accord (SLHA), we support reading parameter data from some custom SLHA-type input file. To this end, the [[model]] object stores a list of model-specific block names together with information how to find a parameter in the model record, given a block name and index vector. Check if the model supports custom SLHA block info. This is the case if [[n_slha_block]] is nonzero, i.e., after SLHA block names have been parsed and registered. <>= procedure :: supports_custom_slha => model_supports_custom_slha <>= function model_supports_custom_slha (model) result (flag) class(model_t), intent(in) :: model logical :: flag flag = model%n_slha_block > 0 end function model_supports_custom_slha @ %def model_supports_custom_slha @ Return the block names for all SLHA block references. <>= procedure :: get_custom_slha_blocks => model_get_custom_slha_blocks <>= subroutine model_get_custom_slha_blocks (model, block_name) class(model_t), intent(in) :: model type(string_t), dimension(:), allocatable :: block_name integer :: i allocate (block_name (model%n_slha_block)) do i = 1, size (block_name) block_name(i) = model%slha_block(i)%name end do end subroutine model_get_custom_slha_blocks @ %def model_get_custom_slha_blocks @ This routine registers a SLHA block reference. We have the index of a (new) parameter entry and a parse node from the model file which specifies a block name and an index array. <>= subroutine model_record_slha_block_entry (model, i_par, node) class(model_t), intent(inout) :: model integer, intent(in) :: i_par type(parse_node_t), intent(in), target :: node type(parse_node_t), pointer :: node_block_name, node_index type(string_t) :: block_name integer :: n_index, i, i_block integer, dimension(:), allocatable :: block_index node_block_name => node%get_sub_ptr (2) select case (char (node_block_name%get_rule_key ())) case ("block_name") block_name = node_block_name%get_string () case ("QNUMBERS") block_name = "QNUMBERS" case default block_name = node_block_name%get_string () end select n_index = node%get_n_sub () - 2 allocate (block_index (n_index)) node_index => node_block_name%get_next_ptr () do i = 1, n_index block_index(i) = node_index%get_integer () node_index => node_index%get_next_ptr () end do i_block = 0 FIND_BLOCK: do i = 1, model%n_slha_block if (model%slha_block(i)%name == block_name) then i_block = i exit FIND_BLOCK end if end do FIND_BLOCK if (i_block == 0) then call model_add_slha_block (model, block_name) i_block = model%n_slha_block end if associate (b => model%slha_block(i_block)) call add_slha_block_entry (b, block_index, i_par) end associate model%par(i_par)%block_name = block_name model%par(i_par)%block_index = block_index end subroutine model_record_slha_block_entry @ %def model_record_slha_block_entry @ Add a new entry to the SLHA block register, increasing the array size if necessary <>= subroutine model_add_slha_block (model, block_name) class(model_t), intent(inout) :: model type(string_t), intent(in) :: block_name if (.not. allocated (model%slha_block)) allocate (model%slha_block (1)) if (model%n_slha_block == size (model%slha_block)) call grow model%n_slha_block = model%n_slha_block + 1 associate (b => model%slha_block(model%n_slha_block)) b%name = block_name allocate (b%entry (1)) end associate contains subroutine grow type(slha_block_t), dimension(:), allocatable :: b_tmp call move_alloc (model%slha_block, b_tmp) allocate (model%slha_block (2 * size (b_tmp))) model%slha_block(:size (b_tmp)) = b_tmp(:) end subroutine grow end subroutine model_add_slha_block @ %def model_add_slha_block @ Add a new entry to a block-register record. The entry establishes a pointer-target relation between an index array within the SLHA block and a parameter-data record. We increase the entry array as needed. <>= subroutine add_slha_block_entry (b, block_index, i_par) type(slha_block_t), intent(inout) :: b integer, dimension(:), intent(in) :: block_index integer, intent(in) :: i_par if (b%n_entry == size (b%entry)) call grow b%n_entry = b%n_entry + 1 associate (entry => b%entry(b%n_entry)) entry%block_index = block_index entry%i_par = i_par end associate contains subroutine grow type(slha_entry_t), dimension(:), allocatable :: entry_tmp call move_alloc (b%entry, entry_tmp) allocate (b%entry (2 * size (entry_tmp))) b%entry(:size (entry_tmp)) = entry_tmp(:) end subroutine grow end subroutine add_slha_block_entry @ %def add_slha_block_entry @ The lookup routine returns a pointer to the appropriate [[par_data]] record, if [[block_name]] and [[block_index]] are valid. The latter point to the [[slha_block_t]] register within the [[model_t]] object, if it is allocated. This should only be needed during I/O (i.e., while reading the SLHA file), so a simple linear search for each parameter should not be a performance problem. <>= procedure :: slha_lookup => model_slha_lookup <>= subroutine model_slha_lookup (model, block_name, block_index, par_data) class(model_t), intent(in) :: model type(string_t), intent(in) :: block_name integer, dimension(:), intent(in) :: block_index class(modelpar_data_t), pointer, intent(out) :: par_data integer :: i, j par_data => null () if (allocated (model%slha_block)) then do i = 1, model%n_slha_block associate (block => model%slha_block(i)) if (block%name == block_name) then do j = 1, block%n_entry associate (entry => block%entry(j)) if (size (entry%block_index) == size (block_index)) then if (all (entry%block_index == block_index)) then par_data => model%par(entry%i_par)%data return end if end if end associate end do end if end associate end do end if end subroutine model_slha_lookup @ %def model_slha_lookup @ Modify the value of a parameter, identified by block name and index array. <>= procedure :: slha_set_par => model_slha_set_par <>= subroutine model_slha_set_par (model, block_name, block_index, value) class(model_t), intent(inout) :: model type(string_t), intent(in) :: block_name integer, dimension(:), intent(in) :: block_index real(default), intent(in) :: value class(modelpar_data_t), pointer :: par_data call model%slha_lookup (block_name, block_index, par_data) if (associated (par_data)) then par_data = value end if end subroutine model_slha_set_par @ %def model_slha_set_par @ \subsection{Reading models from file} This procedure defines the model-file syntax for the parser, returning an internal file (ifile). Note that arithmetic operators are defined as keywords in the expression syntax, so we exclude them here. <>= subroutine define_model_file_syntax (ifile) type(ifile_t), intent(inout) :: ifile call ifile_append (ifile, "SEQ model_def = model_name_def " // & "scheme_header parameters external_pars particles vertices") call ifile_append (ifile, "SEQ model_name_def = model model_name") call ifile_append (ifile, "KEY model") call ifile_append (ifile, "QUO model_name = '""'...'""'") call ifile_append (ifile, "SEQ scheme_header = scheme_decl?") call ifile_append (ifile, "SEQ scheme_decl = schemes '=' scheme_list") call ifile_append (ifile, "KEY schemes") call ifile_append (ifile, "LIS scheme_list = scheme_name+") call ifile_append (ifile, "QUO scheme_name = '""'...'""'") call ifile_append (ifile, "SEQ parameters = generic_par_def*") call ifile_append (ifile, "ALT generic_par_def = & ¶meter_def | derived_def | unused_def | scheme_block") call ifile_append (ifile, "SEQ parameter_def = parameter par_name " // & "'=' any_real_value slha_annotation?") call ifile_append (ifile, "ALT any_real_value = " & // "neg_real_value | pos_real_value | real_value") call ifile_append (ifile, "SEQ neg_real_value = '-' real_value") call ifile_append (ifile, "SEQ pos_real_value = '+' real_value") call ifile_append (ifile, "KEY parameter") call ifile_append (ifile, "IDE par_name") ! call ifile_append (ifile, "KEY '='") !!! Key already exists call ifile_append (ifile, "SEQ slha_annotation = " // & "slha_entry slha_block_name slha_entry_index*") call ifile_append (ifile, "KEY slha_entry") call ifile_append (ifile, "IDE slha_block_name") call ifile_append (ifile, "INT slha_entry_index") call ifile_append (ifile, "SEQ derived_def = derived par_name " // & "'=' expr") call ifile_append (ifile, "KEY derived") call ifile_append (ifile, "SEQ unused_def = unused par_name") call ifile_append (ifile, "KEY unused") call ifile_append (ifile, "SEQ external_pars = external_def*") call ifile_append (ifile, "SEQ external_def = external par_name") call ifile_append (ifile, "KEY external") call ifile_append (ifile, "SEQ scheme_block = & &scheme_block_beg scheme_block_body scheme_block_end") call ifile_append (ifile, "SEQ scheme_block_beg = select scheme") call ifile_append (ifile, "SEQ scheme_block_body = scheme_block_case*") call ifile_append (ifile, "SEQ scheme_block_case = & &scheme scheme_id parameters") call ifile_append (ifile, "ALT scheme_id = scheme_list | other") call ifile_append (ifile, "SEQ scheme_block_end = end select") call ifile_append (ifile, "KEY select") call ifile_append (ifile, "KEY scheme") call ifile_append (ifile, "KEY other") call ifile_append (ifile, "KEY end") call ifile_append (ifile, "SEQ particles = particle_def*") call ifile_append (ifile, "SEQ particle_def = particle name_def " // & "prt_pdg prt_details") call ifile_append (ifile, "KEY particle") call ifile_append (ifile, "SEQ prt_pdg = signed_int") call ifile_append (ifile, "ALT prt_details = prt_src | prt_properties") call ifile_append (ifile, "SEQ prt_src = like name_def prt_properties") call ifile_append (ifile, "KEY like") call ifile_append (ifile, "SEQ prt_properties = prt_property*") call ifile_append (ifile, "ALT prt_property = " // & "parton | invisible | gauge | left | right | " // & "prt_name | prt_anti | prt_tex_name | prt_tex_anti | " // & "prt_spin | prt_isospin | prt_charge | " // & "prt_color | prt_mass | prt_width") call ifile_append (ifile, "KEY parton") call ifile_append (ifile, "KEY invisible") call ifile_append (ifile, "KEY gauge") call ifile_append (ifile, "KEY left") call ifile_append (ifile, "KEY right") call ifile_append (ifile, "SEQ prt_name = name name_def+") call ifile_append (ifile, "SEQ prt_anti = anti name_def+") call ifile_append (ifile, "SEQ prt_tex_name = tex_name name_def") call ifile_append (ifile, "SEQ prt_tex_anti = tex_anti name_def") call ifile_append (ifile, "KEY name") call ifile_append (ifile, "KEY anti") call ifile_append (ifile, "KEY tex_name") call ifile_append (ifile, "KEY tex_anti") call ifile_append (ifile, "ALT name_def = name_string | name_id") call ifile_append (ifile, "QUO name_string = '""'...'""'") call ifile_append (ifile, "IDE name_id") call ifile_append (ifile, "SEQ prt_spin = spin frac") call ifile_append (ifile, "KEY spin") call ifile_append (ifile, "SEQ prt_isospin = isospin frac") call ifile_append (ifile, "KEY isospin") call ifile_append (ifile, "SEQ prt_charge = charge frac") call ifile_append (ifile, "KEY charge") call ifile_append (ifile, "SEQ prt_color = color integer_literal") call ifile_append (ifile, "KEY color") call ifile_append (ifile, "SEQ prt_mass = mass par_name") call ifile_append (ifile, "KEY mass") call ifile_append (ifile, "SEQ prt_width = width par_name") call ifile_append (ifile, "KEY width") call ifile_append (ifile, "SEQ vertices = vertex_def*") call ifile_append (ifile, "SEQ vertex_def = vertex name_def+") call ifile_append (ifile, "KEY vertex") call define_expr_syntax (ifile, particles=.false., analysis=.false.) end subroutine define_model_file_syntax @ %def define_model_file_syntax @ The model-file syntax and lexer are fixed, therefore stored as module variables: <>= type(syntax_t), target, save :: syntax_model_file @ %def syntax_model_file <>= public :: syntax_model_file_init <>= subroutine syntax_model_file_init () type(ifile_t) :: ifile call define_model_file_syntax (ifile) call syntax_init (syntax_model_file, ifile) call ifile_final (ifile) end subroutine syntax_model_file_init @ %def syntax_model_file_init <>= subroutine lexer_init_model_file (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_model_file)) end subroutine lexer_init_model_file @ %def lexer_init_model_file <>= public :: syntax_model_file_final <>= subroutine syntax_model_file_final () call syntax_final (syntax_model_file) end subroutine syntax_model_file_final @ %def syntax_model_file_final <>= public :: syntax_model_file_write <>= subroutine syntax_model_file_write (unit) integer, intent(in), optional :: unit call syntax_write (syntax_model_file, unit) end subroutine syntax_model_file_write @ %def syntax_model_file_write @ Read a model from file. Handle all syntax and respect the provided scheme. The [[ufo]] flag just says that the model object should be tagged as being derived from an UFO model. The UFO model path may be requested by the caller. If not, we use a standard path search for UFO models. There is no difference in the contents of the file or the generated model object. <>= procedure :: read => model_read <>= subroutine model_read (model, filename, os_data, exist, & scheme, ufo, ufo_path_requested, rebuild_mdl) class(model_t), intent(out), target :: model type(string_t), intent(in) :: filename type(os_data_t), intent(in) :: os_data logical, intent(out), optional :: exist type(string_t), intent(in), optional :: scheme logical, intent(in), optional :: ufo type(string_t), intent(in), optional :: ufo_path_requested logical, intent(in), optional :: rebuild_mdl type(string_t) :: file type(stream_t), target :: stream type(lexer_t) :: lexer integer :: unit character(32) :: model_md5sum type(parse_node_t), pointer :: nd_model_def, nd_model_name_def type(parse_node_t), pointer :: nd_schemes, nd_scheme_decl type(parse_node_t), pointer :: nd_parameters type(parse_node_t), pointer :: nd_external_pars type(parse_node_t), pointer :: nd_particles, nd_vertices type(string_t) :: model_name, lib_name integer :: n_parblock, n_par, i_par, n_ext, n_prt, n_vtx type(parse_node_t), pointer :: nd_par_def type(parse_node_t), pointer :: nd_ext_def type(parse_node_t), pointer :: nd_prt type(parse_node_t), pointer :: nd_vtx logical :: ufo_model, model_exist, rebuild ufo_model = .false.; if (present (ufo)) ufo_model = ufo rebuild = .true.; if (present (rebuild_mdl)) rebuild = rebuild_mdl file = filename inquire (file=char(file), exist=model_exist) if ((.not. model_exist) .and. (.not. os_data%use_testfiles)) then file = os_data%whizard_modelpath_local // "/" // filename inquire (file = char (file), exist = model_exist) end if if (.not. model_exist) then file = os_data%whizard_modelpath // "/" // filename inquire (file = char (file), exist = model_exist) end if if (ufo_model .and. rebuild) then file = filename call model_generate_ufo (filename, os_data, model%ufo_path, & ufo_path_requested=ufo_path_requested) inquire (file = char (file), exist = model_exist) end if if (.not. model_exist) then call msg_fatal ("Model file '" // char (filename) // "' not found") if (present (exist)) exist = .false. return end if if (present (exist)) exist = .true. if (logging) call msg_message ("Reading model file '" // char (file) // "'") unit = free_unit () open (file=char(file), unit=unit, action="read", status="old") model_md5sum = md5sum (unit) close (unit) call lexer_init_model_file (lexer) call stream_init (stream, char (file)) call lexer_assign_stream (lexer, stream) call parse_tree_init (model%parse_tree, syntax_model_file, lexer) call stream_final (stream) call lexer_final (lexer) nd_model_def => model%parse_tree%get_root_ptr () nd_model_name_def => parse_node_get_sub_ptr (nd_model_def) model_name = parse_node_get_string & (parse_node_get_sub_ptr (nd_model_name_def, 2)) nd_schemes => nd_model_name_def%get_next_ptr () call find_block & ("scheme_header", nd_schemes, nd_scheme_decl, nd_next=nd_parameters) call find_block & ("parameters", nd_parameters, nd_par_def, n_parblock, nd_external_pars) call find_block & ("external_pars", nd_external_pars, nd_ext_def, n_ext, nd_particles) call find_block & ("particles", nd_particles, nd_prt, n_prt, nd_vertices) call find_block & ("vertices", nd_vertices, nd_vtx, n_vtx) if (associated (nd_external_pars)) then lib_name = "external." // model_name else lib_name = "" end if if (associated (nd_scheme_decl)) then call handle_schemes (nd_scheme_decl, scheme) end if n_par = 0 call count_parameters (nd_par_def, n_parblock, n_par) call model%init & (model_name, lib_name, os_data, n_par + n_ext, n_prt, n_vtx, ufo) model%md5sum = model_md5sum if (associated (nd_par_def)) then i_par = 0 call handle_parameters (nd_par_def, n_parblock, i_par) end if if (associated (nd_ext_def)) then call handle_external (nd_ext_def, n_par, n_ext) end if call model%update_parameters () if (associated (nd_prt)) then call handle_fields (nd_prt, n_prt) end if if (associated (nd_vtx)) then call handle_vertices (nd_vtx, n_vtx) end if call model%freeze_vertices () call model%append_field_vars () contains subroutine find_block (key, nd, nd_item, n_item, nd_next) character(*), intent(in) :: key type(parse_node_t), pointer, intent(inout) :: nd type(parse_node_t), pointer, intent(out) :: nd_item integer, intent(out), optional :: n_item type(parse_node_t), pointer, intent(out), optional :: nd_next if (associated (nd)) then if (nd%get_rule_key () == key) then nd_item => nd%get_sub_ptr () if (present (n_item)) n_item = nd%get_n_sub () if (present (nd_next)) nd_next => nd%get_next_ptr () else nd_item => null () if (present (n_item)) n_item = 0 if (present (nd_next)) nd_next => nd nd => null () end if else nd_item => null () if (present (n_item)) n_item = 0 if (present (nd_next)) nd_next => null () end if end subroutine find_block subroutine handle_schemes (nd_scheme_decl, scheme) type(parse_node_t), pointer, intent(in) :: nd_scheme_decl type(string_t), intent(in), optional :: scheme type(parse_node_t), pointer :: nd_list, nd_entry type(string_t), dimension(:), allocatable :: schemes integer :: i, n_schemes nd_list => nd_scheme_decl%get_sub_ptr (3) nd_entry => nd_list%get_sub_ptr () n_schemes = nd_list%get_n_sub () allocate (schemes (n_schemes)) do i = 1, n_schemes schemes(i) = nd_entry%get_string () nd_entry => nd_entry%get_next_ptr () end do if (present (scheme)) then do i = 1, n_schemes if (schemes(i) == scheme) goto 10 ! block exit end do call msg_fatal ("Scheme '" // char (scheme) & // "' is not supported by model '" // char (model_name) // "'") end if 10 continue call model%enable_schemes (schemes) call model%set_scheme (scheme) end subroutine handle_schemes subroutine select_scheme (nd_scheme_block, n_parblock_sub, nd_par_def) type(parse_node_t), pointer, intent(in) :: nd_scheme_block integer, intent(out) :: n_parblock_sub type(parse_node_t), pointer, intent(out) :: nd_par_def type(parse_node_t), pointer :: nd_scheme_body type(parse_node_t), pointer :: nd_scheme_case, nd_scheme_id, nd_scheme type(string_t) :: scheme integer :: n_cases, i scheme = model%get_scheme () nd_scheme_body => nd_scheme_block%get_sub_ptr (2) nd_parameters => null () select case (char (nd_scheme_body%get_rule_key ())) case ("scheme_block_body") n_cases = nd_scheme_body%get_n_sub () FIND_SCHEME: do i = 1, n_cases nd_scheme_case => nd_scheme_body%get_sub_ptr (i) nd_scheme_id => nd_scheme_case%get_sub_ptr (2) select case (char (nd_scheme_id%get_rule_key ())) case ("scheme_list") nd_scheme => nd_scheme_id%get_sub_ptr () do while (associated (nd_scheme)) if (scheme == nd_scheme%get_string ()) then nd_parameters => nd_scheme_id%get_next_ptr () exit FIND_SCHEME end if nd_scheme => nd_scheme%get_next_ptr () end do case ("other") nd_parameters => nd_scheme_id%get_next_ptr () exit FIND_SCHEME case default print *, "'", char (nd_scheme_id%get_rule_key ()), "'" call msg_bug ("Model read: impossible scheme rule") end select end do FIND_SCHEME end select if (associated (nd_parameters)) then select case (char (nd_parameters%get_rule_key ())) case ("parameters") n_parblock_sub = nd_parameters%get_n_sub () if (n_parblock_sub > 0) then nd_par_def => nd_parameters%get_sub_ptr () else nd_par_def => null () end if case default n_parblock_sub = 0 nd_par_def => null () end select else n_parblock_sub = 0 nd_par_def => null () end if end subroutine select_scheme recursive subroutine count_parameters (nd_par_def_in, n_parblock, n_par) type(parse_node_t), pointer, intent(in) :: nd_par_def_in integer, intent(in) :: n_parblock integer, intent(inout) :: n_par type(parse_node_t), pointer :: nd_par_def, nd_par_key type(parse_node_t), pointer :: nd_par_def_sub integer :: n_parblock_sub integer :: i nd_par_def => nd_par_def_in do i = 1, n_parblock nd_par_key => nd_par_def%get_sub_ptr () select case (char (nd_par_key%get_rule_key ())) case ("parameter", "derived", "unused") n_par = n_par + 1 case ("scheme_block_beg") call select_scheme (nd_par_def, n_parblock_sub, nd_par_def_sub) if (n_parblock_sub > 0) then call count_parameters (nd_par_def_sub, n_parblock_sub, n_par) end if case default print *, "'", char (nd_par_key%get_rule_key ()), "'" call msg_bug ("Model read: impossible parameter rule") end select nd_par_def => parse_node_get_next_ptr (nd_par_def) end do end subroutine count_parameters recursive subroutine handle_parameters (nd_par_def_in, n_parblock, i_par) type(parse_node_t), pointer, intent(in) :: nd_par_def_in integer, intent(in) :: n_parblock integer, intent(inout) :: i_par type(parse_node_t), pointer :: nd_par_def, nd_par_key type(parse_node_t), pointer :: nd_par_def_sub integer :: n_parblock_sub integer :: i nd_par_def => nd_par_def_in do i = 1, n_parblock nd_par_key => nd_par_def%get_sub_ptr () select case (char (nd_par_key%get_rule_key ())) case ("parameter") i_par = i_par + 1 call model%read_parameter (i_par, nd_par_def) case ("derived") i_par = i_par + 1 call model%read_derived (i_par, nd_par_def) case ("unused") i_par = i_par + 1 call model%read_unused (i_par, nd_par_def) case ("scheme_block_beg") call select_scheme (nd_par_def, n_parblock_sub, nd_par_def_sub) if (n_parblock_sub > 0) then call handle_parameters (nd_par_def_sub, n_parblock_sub, i_par) end if end select nd_par_def => parse_node_get_next_ptr (nd_par_def) end do end subroutine handle_parameters subroutine handle_external (nd_ext_def, n_par, n_ext) type(parse_node_t), pointer, intent(inout) :: nd_ext_def integer, intent(in) :: n_par, n_ext integer :: i do i = n_par + 1, n_par + n_ext call model%read_external (i, nd_ext_def) nd_ext_def => parse_node_get_next_ptr (nd_ext_def) end do ! real(c_default_float), dimension(:), allocatable :: par ! if (associated (model%init_external_parameters)) then ! allocate (par (model%get_n_real ())) ! call model%real_parameters_to_c_array (par) ! call model%init_external_parameters (par) ! call model%real_parameters_from_c_array (par) ! end if end subroutine handle_external subroutine handle_fields (nd_prt, n_prt) type(parse_node_t), pointer, intent(inout) :: nd_prt integer, intent(in) :: n_prt integer :: i do i = 1, n_prt call model%read_field (i, nd_prt) nd_prt => parse_node_get_next_ptr (nd_prt) end do end subroutine handle_fields subroutine handle_vertices (nd_vtx, n_vtx) type(parse_node_t), pointer, intent(inout) :: nd_vtx integer, intent(in) :: n_vtx integer :: i do i = 1, n_vtx call model%read_vertex (i, nd_vtx) nd_vtx => parse_node_get_next_ptr (nd_vtx) end do end subroutine handle_vertices end subroutine model_read @ %def model_read @ Parameters are real values (literal) with an optional unit. <>= procedure, private :: read_parameter => model_read_parameter <>= subroutine model_read_parameter (model, i, node) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(parse_node_t), intent(in), target :: node type(parse_node_t), pointer :: node_name, node_val, node_slha_entry type(string_t) :: name node_name => parse_node_get_sub_ptr (node, 2) name = parse_node_get_string (node_name) node_val => parse_node_get_next_ptr (node_name, 2) call model%set_parameter_parse_node (i, name, node_val, constant=.true.) node_slha_entry => parse_node_get_next_ptr (node_val) if (associated (node_slha_entry)) then call model_record_slha_block_entry (model, i, node_slha_entry) end if end subroutine model_read_parameter @ %def model_read_parameter @ Derived parameters have any numeric expression as their definition. Don't evaluate the expression, yet. <>= procedure, private :: read_derived => model_read_derived <>= subroutine model_read_derived (model, i, node) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(parse_node_t), intent(in), target :: node type(string_t) :: name type(parse_node_t), pointer :: pn_expr name = parse_node_get_string (parse_node_get_sub_ptr (node, 2)) pn_expr => parse_node_get_sub_ptr (node, 4) call model%set_parameter_parse_node (i, name, pn_expr, constant=.false.) end subroutine model_read_derived @ %def model_read_derived @ External parameters have no definition; they are handled by an external library. <>= procedure, private :: read_external => model_read_external <>= subroutine model_read_external (model, i, node) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(parse_node_t), intent(in), target :: node type(string_t) :: name name = parse_node_get_string (parse_node_get_sub_ptr (node, 2)) call model%set_parameter_external (i, name) end subroutine model_read_external @ %def model_read_external @ Ditto for unused parameters, they are there just for reserving the name. <>= procedure, private :: read_unused => model_read_unused <>= subroutine model_read_unused (model, i, node) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(parse_node_t), intent(in), target :: node type(string_t) :: name name = parse_node_get_string (parse_node_get_sub_ptr (node, 2)) call model%set_parameter_unused (i, name) end subroutine model_read_unused @ %def model_read_unused <>= procedure, private :: read_field => model_read_field <>= subroutine model_read_field (model, i, node) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(parse_node_t), intent(in) :: node type(parse_node_t), pointer :: nd_src, nd_props, nd_prop type(string_t) :: longname integer :: pdg type(string_t) :: name_src type(string_t), dimension(:), allocatable :: name type(field_data_t), pointer :: field, field_src longname = parse_node_get_string (parse_node_get_sub_ptr (node, 2)) pdg = read_frac (parse_node_get_sub_ptr (node, 3)) field => model%get_field_ptr_by_index (i) call field%init (longname, pdg) nd_src => parse_node_get_sub_ptr (node, 4) if (associated (nd_src)) then if (parse_node_get_rule_key (nd_src) == "prt_src") then name_src = parse_node_get_string (parse_node_get_sub_ptr (nd_src, 2)) field_src => model%get_field_ptr (name_src, check=.true.) call field%copy_from (field_src) nd_props => parse_node_get_sub_ptr (nd_src, 3) else nd_props => nd_src end if nd_prop => parse_node_get_sub_ptr (nd_props) do while (associated (nd_prop)) select case (char (parse_node_get_rule_key (nd_prop))) case ("invisible") call field%set (is_visible=.false.) case ("parton") call field%set (is_parton=.true.) case ("gauge") call field%set (is_gauge=.true.) case ("left") call field%set (is_left_handed=.true.) case ("right") call field%set (is_right_handed=.true.) case ("prt_name") call read_names (nd_prop, name) call field%set (name=name) case ("prt_anti") call read_names (nd_prop, name) call field%set (anti=name) case ("prt_tex_name") call field%set ( & tex_name = parse_node_get_string & (parse_node_get_sub_ptr (nd_prop, 2))) case ("prt_tex_anti") call field%set ( & tex_anti = parse_node_get_string & (parse_node_get_sub_ptr (nd_prop, 2))) case ("prt_spin") call field%set ( & spin_type = read_frac & (parse_node_get_sub_ptr (nd_prop, 2), 2)) case ("prt_isospin") call field%set ( & isospin_type = read_frac & (parse_node_get_sub_ptr (nd_prop, 2), 2)) case ("prt_charge") call field%set ( & charge_type = read_frac & (parse_node_get_sub_ptr (nd_prop, 2), 3)) case ("prt_color") call field%set ( & color_type = parse_node_get_integer & (parse_node_get_sub_ptr (nd_prop, 2))) case ("prt_mass") call field%set ( & mass_data = model%get_par_data_ptr & (parse_node_get_string & (parse_node_get_sub_ptr (nd_prop, 2)))) case ("prt_width") call field%set ( & width_data = model%get_par_data_ptr & (parse_node_get_string & (parse_node_get_sub_ptr (nd_prop, 2)))) case default call msg_bug (" Unknown particle property '" & // char (parse_node_get_rule_key (nd_prop)) // "'") end select if (allocated (name)) deallocate (name) nd_prop => parse_node_get_next_ptr (nd_prop) end do end if call field%freeze () end subroutine model_read_field @ %def model_read_field <>= procedure, private :: read_vertex => model_read_vertex <>= subroutine model_read_vertex (model, i, node) class(model_t), intent(inout) :: model integer, intent(in) :: i type(parse_node_t), intent(in) :: node type(string_t), dimension(:), allocatable :: name call read_names (node, name) call model%set_vertex (i, name) end subroutine model_read_vertex @ %def model_read_vertex <>= subroutine read_names (node, name) type(parse_node_t), intent(in) :: node type(string_t), dimension(:), allocatable, intent(inout) :: name type(parse_node_t), pointer :: nd_name integer :: n_names, i n_names = parse_node_get_n_sub (node) - 1 allocate (name (n_names)) nd_name => parse_node_get_sub_ptr (node, 2) do i = 1, n_names name(i) = parse_node_get_string (nd_name) nd_name => parse_node_get_next_ptr (nd_name) end do end subroutine read_names @ %def read_names @ There is an optional argument for the base. <>= function read_frac (nd_frac, base) result (qn_type) integer :: qn_type type(parse_node_t), intent(in) :: nd_frac integer, intent(in), optional :: base type(parse_node_t), pointer :: nd_num, nd_den integer :: num, den nd_num => parse_node_get_sub_ptr (nd_frac) nd_den => parse_node_get_next_ptr (nd_num) select case (char (parse_node_get_rule_key (nd_num))) case ("integer_literal") num = parse_node_get_integer (nd_num) case ("neg_int") num = - parse_node_get_integer (parse_node_get_sub_ptr (nd_num, 2)) case ("pos_int") num = parse_node_get_integer (parse_node_get_sub_ptr (nd_num, 2)) case default call parse_tree_bug (nd_num, "int|neg_int|pos_int") end select if (associated (nd_den)) then den = parse_node_get_integer (parse_node_get_sub_ptr (nd_den, 2)) else den = 1 end if if (present (base)) then if (den == 1) then qn_type = sign (1 + abs (num) * base, num) else if (den == base) then qn_type = sign (abs (num) + 1, num) else call parse_node_write_rec (nd_frac) call msg_fatal (" Fractional quantum number: wrong denominator") end if else if (den == 1) then qn_type = num else call parse_node_write_rec (nd_frac) call msg_fatal (" Wrong type: no fraction expected") end if end if end function read_frac @ %def read_frac @ Append field (PDG-array) variables to the variable list, based on the field content. <>= procedure, private :: append_field_vars => model_append_field_vars <>= subroutine model_append_field_vars (model) class(model_t), intent(inout) :: model type(pdg_array_t) :: aval type(field_data_t), dimension(:), pointer :: field_array type(field_data_t), pointer :: field type(string_t) :: name type(string_t), dimension(:), allocatable :: name_array integer, dimension(:), allocatable :: pdg logical, dimension(:), allocatable :: mask integer :: i, j field_array => model%get_field_array_ptr () aval = UNDEFINED - call var_list_append_pdg_array & - (model%var_list, var_str ("particle"), & - aval, locked = .true., intrinsic=.true.) + call model%var_list%append_pdg_array (var_str ("particle"), & + aval, locked = .true., intrinsic=.true.) do i = 1, size (field_array) aval = field_array(i)%get_pdg () name = field_array(i)%get_longname () - call var_list_append_pdg_array & - (model%var_list, name, aval, locked=.true., intrinsic=.true.) + call model%var_list%append_pdg_array & + (name, aval, locked=.true., intrinsic=.true.) call field_array(i)%get_name_array (.false., name_array) do j = 1, size (name_array) - call var_list_append_pdg_array & - (model%var_list, name_array(j), & + call model%var_list%append_pdg_array (name_array(j), & aval, locked=.true., intrinsic=.true.) end do model%max_field_name_length = & max (model%max_field_name_length, len (name_array(1))) aval = - field_array(i)%get_pdg () call field_array(i)%get_name_array (.true., name_array) do j = 1, size (name_array) - call var_list_append_pdg_array & - (model%var_list, name_array(j), & + call model%var_list%append_pdg_array (name_array(j), & aval, locked=.true., intrinsic=.true.) end do if (size (name_array) > 0) then model%max_field_name_length = & max (model%max_field_name_length, len (name_array(1))) end if end do call model%get_all_pdg (pdg) allocate (mask (size (pdg))) do i = 1, size (pdg) field => model%get_field_ptr (pdg(i)) mask(i) = field%get_charge_type () /= 1 end do aval = pack (pdg, mask) - call var_list_append_pdg_array & - (model%var_list, var_str ("charged"), & - aval, locked = .true., intrinsic=.true.) + call model%var_list%append_pdg_array (var_str ("charged"), & + aval, locked = .true., intrinsic=.true.) do i = 1, size (pdg) field => model%get_field_ptr (pdg(i)) mask(i) = field%get_charge_type () == 1 end do aval = pack (pdg, mask) - call var_list_append_pdg_array & - (model%var_list, var_str ("neutral"), & - aval, locked = .true., intrinsic=.true.) + call model%var_list%append_pdg_array (var_str ("neutral"), & + aval, locked = .true., intrinsic=.true.) do i = 1, size (pdg) field => model%get_field_ptr (pdg(i)) mask(i) = field%get_color_type () /= 1 end do aval = pack (pdg, mask) - call var_list_append_pdg_array & - (model%var_list, var_str ("colored"), & - aval, locked = .true., intrinsic=.true.) + call model%var_list%append_pdg_array (var_str ("colored"), & + aval, locked = .true., intrinsic=.true.) end subroutine model_append_field_vars @ %def model_append_field_vars @ \subsection{Test models} <>= public :: create_test_model <>= subroutine create_test_model (model_name, test_model) type(string_t), intent(in) :: model_name type(model_t), intent(out), pointer :: test_model type(os_data_t) :: os_data type(model_list_t) :: model_list call syntax_model_file_init () call os_data%init () call model_list%read_model & (model_name, model_name // var_str (".mdl"), os_data, test_model) end subroutine create_test_model @ %def create_test_model @ \subsection{Model list} List of currently active models <>= type, extends (model_t) :: model_entry_t type(model_entry_t), pointer :: next => null () end type model_entry_t @ %def model_entry_t <>= public :: model_list_t <>= type :: model_list_t type(model_entry_t), pointer :: first => null () type(model_entry_t), pointer :: last => null () type(model_list_t), pointer :: context => null () contains <> end type model_list_t @ %def model_list_t @ Write an account of the model list. We write linked lists first, starting from the global context. <>= procedure :: write => model_list_write <>= recursive subroutine model_list_write (object, unit, verbose, follow_link) class(model_list_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: verbose logical, intent(in), optional :: follow_link type(model_entry_t), pointer :: current logical :: rec integer :: u u = given_output_unit (unit); if (u < 0) return rec = .true.; if (present (follow_link)) rec = follow_link if (rec .and. associated (object%context)) then call object%context%write (unit, verbose, follow_link) end if current => object%first if (associated (current)) then do while (associated (current)) call current%write (unit, verbose) current => current%next if (associated (current)) write (u, *) end do end if end subroutine model_list_write @ %def model_list_write @ Link this list to another one. <>= procedure :: link => model_list_link <>= subroutine model_list_link (model_list, context) class(model_list_t), intent(inout) :: model_list type(model_list_t), intent(in), target :: context model_list%context => context end subroutine model_list_link @ %def model_list_link @ (Private, used below:) Append an existing model, for which we have allocated a pointer entry, to the model list. The original pointer becomes disassociated, and the model should now be considered as part of the list. We assume that this model is not yet part of the list. If we provide a [[model]] argument, this returns a pointer to the new entry. <>= procedure, private :: import => model_list_import <>= subroutine model_list_import (model_list, current, model) class(model_list_t), intent(inout) :: model_list type(model_entry_t), pointer, intent(inout) :: current type(model_t), optional, pointer, intent(out) :: model if (associated (current)) then if (associated (model_list%first)) then model_list%last%next => current else model_list%first => current end if model_list%last => current if (present (model)) model => current%model_t current => null () end if end subroutine model_list_import @ %def model_list_import @ Currently test only: Add a new model with given [[name]] to the list, if it does not yet exist. If successful, return a pointer to the new model. <>= procedure :: add => model_list_add <>= subroutine model_list_add (model_list, & name, os_data, n_par, n_prt, n_vtx, model) class(model_list_t), intent(inout) :: model_list type(string_t), intent(in) :: name type(os_data_t), intent(in) :: os_data integer, intent(in) :: n_par, n_prt, n_vtx type(model_t), pointer :: model type(model_entry_t), pointer :: current if (model_list%model_exists (name, follow_link=.false.)) then model => null () else allocate (current) call current%init (name, var_str (""), os_data, & n_par, n_prt, n_vtx) call model_list%import (current, model) end if end subroutine model_list_add @ %def model_list_add @ Read a new model from file and add to the list, if it does not yet exist. Finalize the model by allocating the vertex table. Return a pointer to the new model. If unsuccessful, return the original pointer. The model is always inserted in the last link of a chain of model lists. This way, we avoid loading models twice from different contexts. When a model is modified, we should first allocate a local copy. <>= procedure :: read_model => model_list_read_model <>= subroutine model_list_read_model & (model_list, name, filename, os_data, model, & scheme, ufo, ufo_path, rebuild_mdl) class(model_list_t), intent(inout), target :: model_list type(string_t), intent(in) :: name, filename type(os_data_t), intent(in) :: os_data type(model_t), pointer, intent(inout) :: model type(string_t), intent(in), optional :: scheme logical, intent(in), optional :: ufo type(string_t), intent(in), optional :: ufo_path logical, intent(in), optional :: rebuild_mdl class(model_list_t), pointer :: global_model_list type(model_entry_t), pointer :: current logical :: exist if (.not. model_list%model_exists (name, & scheme, ufo, ufo_path, follow_link=.true.)) then allocate (current) call current%read (filename, os_data, exist, & scheme=scheme, ufo=ufo, ufo_path_requested=ufo_path, & rebuild_mdl=rebuild_mdl) if (.not. exist) return if (current%get_name () /= name) then call msg_fatal ("Model file '" // char (filename) // & "' contains model '" // char (current%get_name ()) // & "' instead of '" // char (name) // "'") call current%final (); deallocate (current) return end if global_model_list => model_list do while (associated (global_model_list%context)) global_model_list => global_model_list%context end do call global_model_list%import (current, model) else model => model_list%get_model_ptr (name, scheme, ufo, ufo_path) end if end subroutine model_list_read_model @ %def model_list_read_model @ Append a copy of an existing model to a model list. Optionally, return pointer to the new entry. <>= procedure :: append_copy => model_list_append_copy <>= subroutine model_list_append_copy (model_list, orig, model) class(model_list_t), intent(inout) :: model_list type(model_t), intent(in), target :: orig type(model_t), intent(out), pointer, optional :: model type(model_entry_t), pointer :: copy allocate (copy) call copy%init_instance (orig) call model_list%import (copy, model) end subroutine model_list_append_copy @ %def model_list_append_copy @ Check if a model exists by examining the list. Check recursively unless told otherwise. <>= procedure :: model_exists => model_list_model_exists <>= recursive function model_list_model_exists & (model_list, name, scheme, ufo, ufo_path, follow_link) result (exists) class(model_list_t), intent(in) :: model_list logical :: exists type(string_t), intent(in) :: name type(string_t), intent(in), optional :: scheme logical, intent(in), optional :: ufo type(string_t), intent(in), optional :: ufo_path logical, intent(in), optional :: follow_link type(model_entry_t), pointer :: current logical :: rec rec = .true.; if (present (follow_link)) rec = follow_link current => model_list%first do while (associated (current)) if (current%matches (name, scheme, ufo, ufo_path)) then exists = .true. return end if current => current%next end do if (rec .and. associated (model_list%context)) then exists = model_list%context%model_exists (name, & scheme, ufo, ufo_path, follow_link) else exists = .false. end if end function model_list_model_exists @ %def model_list_model_exists @ Return a pointer to a named model. Search recursively unless told otherwise. <>= procedure :: get_model_ptr => model_list_get_model_ptr <>= recursive function model_list_get_model_ptr & (model_list, name, scheme, ufo, ufo_path, follow_link) result (model) class(model_list_t), intent(in) :: model_list type(model_t), pointer :: model type(string_t), intent(in) :: name type(string_t), intent(in), optional :: scheme logical, intent(in), optional :: ufo type(string_t), intent(in), optional :: ufo_path logical, intent(in), optional :: follow_link type(model_entry_t), pointer :: current logical :: rec rec = .true.; if (present (follow_link)) rec = follow_link current => model_list%first do while (associated (current)) if (current%matches (name, scheme, ufo, ufo_path)) then model => current%model_t return end if current => current%next end do if (rec .and. associated (model_list%context)) then model => model_list%context%get_model_ptr (name, & scheme, ufo, ufo_path, follow_link) else model => null () end if end function model_list_get_model_ptr @ %def model_list_get_model_ptr @ Delete the list of models. No recursion. <>= procedure :: final => model_list_final <>= subroutine model_list_final (model_list) class(model_list_t), intent(inout) :: model_list type(model_entry_t), pointer :: current model_list%last => null () do while (associated (model_list%first)) current => model_list%first model_list%first => model_list%first%next call current%final () deallocate (current) end do end subroutine model_list_final @ %def model_list_final @ \subsection{Model instances} A model instance is a copy of a model object. The parameters are true copies. The particle data and the variable list pointers should point to the copy, so modifying the parameters has only a local effect. Hence, we build them up explicitly. The vertex array is also rebuilt, it contains particle pointers. Finally, the vertex hash table can be copied directly since it contains no pointers. The [[multiplicity]] entry depends on the association of the [[mass_data]] entry and therefore has to be set at the end. The instance must carry the [[target]] attribute. Parameters: the [[copy_parameter]] method essentially copies the parameter decorations (parse node, expression etc.). The current parameter values are part of the [[model_data_t]] base type and are copied afterwards via its [[copy_from]] method. Note: the parameter set is initialized for real parameters only. In order for the local model to be able to use the correct UFO model setup, UFO model information has to be transferred. <>= procedure :: init_instance => model_copy <>= subroutine model_copy (model, orig) class(model_t), intent(out), target :: model type(model_t), intent(in) :: orig integer :: n_par, n_prt, n_vtx integer :: i n_par = orig%get_n_real () n_prt = orig%get_n_field () n_vtx = orig%get_n_vtx () call model%basic_init (orig%get_name (), n_par, n_prt, n_vtx) if (allocated (orig%schemes)) then model%schemes = orig%schemes if (allocated (orig%selected_scheme)) then model%selected_scheme = orig%selected_scheme call model%set_scheme_num (orig%get_scheme_num ()) end if end if if (allocated (orig%slha_block)) then model%slha_block = orig%slha_block end if model%md5sum = orig%md5sum model%ufo_model = orig%ufo_model model%ufo_path = orig%ufo_path if (allocated (orig%par)) then do i = 1, n_par call model%copy_parameter (i, orig%par(i)) end do end if model%init_external_parameters => orig%init_external_parameters call model%model_data_t%copy_from (orig) model%max_par_name_length = orig%max_par_name_length call model%append_field_vars () end subroutine model_copy @ %def model_copy @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[models_ut.f90]]>>= <> module models_ut use unit_tests use models_uti <> <> contains <> end module models_ut @ %def models_ut @ <<[[models_uti.f90]]>>= <> module models_uti <> <> use file_utils, only: delete_file use physics_defs, only: SCALAR, SPINOR use os_interface use model_data use variables use models <> <> contains <> end module models_uti @ %def models_ut @ API: driver for the unit tests below. <>= public :: models_test <>= subroutine models_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine models_test @ %def models_tests @ \subsubsection{Construct a Model} Here, we construct a toy model explicitly without referring to a file. <>= call test (models_1, "models_1", & "construct model", & u, results) <>= public :: models_1 <>= subroutine models_1 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_list_t) :: model_list type(model_t), pointer :: model type(string_t) :: model_name type(string_t) :: x_longname type(string_t), dimension(2) :: parname type(string_t), dimension(2) :: x_name type(string_t), dimension(1) :: x_anti type(string_t) :: x_tex_name, x_tex_anti type(string_t) :: y_longname type(string_t), dimension(2) :: y_name type(string_t) :: y_tex_name type(field_data_t), pointer :: field write (u, "(A)") "* Test output: models_1" write (u, "(A)") "* Purpose: create a model" write (u, *) model_name = "Test model" call model_list%add (model_name, os_data, 2, 2, 3, model) parname(1) = "mx" parname(2) = "coup" call model%set_parameter_constant (1, parname(1), 10._default) call model%set_parameter_constant (2, parname(2), 1.3_default) x_longname = "X_LEPTON" x_name(1) = "X" x_name(2) = "x" x_anti(1) = "Xbar" x_tex_name = "X^+" x_tex_anti = "X^-" field => model%get_field_ptr_by_index (1) call field%init (x_longname, 99) call field%set ( & .true., .false., .false., .false., .false., & name=x_name, anti=x_anti, tex_name=x_tex_name, tex_anti=x_tex_anti, & spin_type=SPINOR, isospin_type=-3, charge_type=2, & mass_data=model%get_par_data_ptr (parname(1))) y_longname = "Y_COLORON" y_name(1) = "Y" y_name(2) = "yc" y_tex_name = "Y^0" field => model%get_field_ptr_by_index (2) call field%init (y_longname, 97) call field%set ( & .false., .false., .true., .false., .false., & name=y_name, tex_name=y_tex_name, & spin_type=SCALAR, isospin_type=2, charge_type=1, color_type=8) call model%set_vertex (1, [99, 99, 99]) call model%set_vertex (2, [99, 99, 99, 99]) call model%set_vertex (3, [99, 97, 99]) call model_list%write (u) call model_list%final () write (u, *) write (u, "(A)") "* Test output end: models_1" end subroutine models_1 @ %def models_1 @ \subsubsection{Read a Model} Read a predefined model from file. <>= call test (models_2, "models_2", & "read model", & u, results) <>= public :: models_2 <>= subroutine models_2 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_list_t) :: model_list type(var_list_t), pointer :: var_list type(model_t), pointer :: model write (u, "(A)") "* Test output: models_2" write (u, "(A)") "* Purpose: read a model from file" write (u, *) call syntax_model_file_init () call os_data%init () call model_list%read_model (var_str ("Test"), var_str ("Test.mdl"), & os_data, model) call model_list%write (u) write (u, *) write (u, "(A)") "* Variable list" write (u, *) var_list => model%get_var_list_ptr () call var_list%write (u) write (u, *) write (u, "(A)") "* Cleanup" call model_list%final () call syntax_model_file_final () write (u, *) write (u, "(A)") "* Test output end: models_2" end subroutine models_2 @ %def models_2 @ \subsubsection{Model Instance} Read a predefined model from file and create an instance. <>= call test (models_3, "models_3", & "model instance", & u, results) <>= public :: models_3 <>= subroutine models_3 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_list_t) :: model_list type(model_t), pointer :: model type(var_list_t), pointer :: var_list type(model_t), pointer :: instance write (u, "(A)") "* Test output: models_3" write (u, "(A)") "* Purpose: create a model instance" write (u, *) call syntax_model_file_init () call os_data%init () call model_list%read_model (var_str ("Test"), var_str ("Test.mdl"), & os_data, model) allocate (instance) call instance%init_instance (model) call model%write (u) write (u, *) write (u, "(A)") "* Variable list" write (u, *) var_list => instance%get_var_list_ptr () call var_list%write (u) write (u, *) write (u, "(A)") "* Cleanup" call instance%final () deallocate (instance) call model_list%final () call syntax_model_file_final () write (u, *) write (u, "(A)") "* Test output end: models_3" end subroutine models_3 @ %def models_test @ \subsubsection{Unstable and Polarized Particles} Read a predefined model from file and define decays and polarization. <>= call test (models_4, "models_4", & "handle decays and polarization", & u, results) <>= public :: models_4 <>= subroutine models_4 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_list_t) :: model_list type(model_t), pointer :: model, model_instance character(32) :: md5sum write (u, "(A)") "* Test output: models_4" write (u, "(A)") "* Purpose: set and unset decays and polarization" write (u, *) call syntax_model_file_init () call os_data%init () write (u, "(A)") "* Read model from file" call model_list%read_model (var_str ("Test"), var_str ("Test.mdl"), & os_data, model) md5sum = model%get_parameters_md5sum () write (u, *) write (u, "(1x,3A)") "MD5 sum (parameters) = '", md5sum, "'" write (u, *) write (u, "(A)") "* Set particle decays and polarization" write (u, *) call model%set_unstable (25, [var_str ("dec1"), var_str ("dec2")]) call model%set_polarized (6) call model%set_unstable (-6, [var_str ("fdec")]) call model%write (u) md5sum = model%get_parameters_md5sum () write (u, *) write (u, "(1x,3A)") "MD5 sum (parameters) = '", md5sum, "'" write (u, *) write (u, "(A)") "* Create a model instance" allocate (model_instance) call model_instance%init_instance (model) write (u, *) write (u, "(A)") "* Revert particle decays and polarization" write (u, *) call model%set_stable (25) call model%set_unpolarized (6) call model%set_stable (-6) call model%write (u) md5sum = model%get_parameters_md5sum () write (u, *) write (u, "(1x,3A)") "MD5 sum (parameters) = '", md5sum, "'" write (u, *) write (u, "(A)") "* Show the model instance" write (u, *) call model_instance%write (u) md5sum = model_instance%get_parameters_md5sum () write (u, *) write (u, "(1x,3A)") "MD5 sum (parameters) = '", md5sum, "'" write (u, *) write (u, "(A)") "* Cleanup" call model_instance%final () deallocate (model_instance) call model_list%final () call syntax_model_file_final () write (u, *) write (u, "(A)") "* Test output end: models_4" end subroutine models_4 @ %def models_4 @ \subsubsection{Model Variables} Read a predefined model from file and modify some parameters. Note that the MD5 sum is not modified by this. <>= call test (models_5, "models_5", & "handle parameters", & u, results) <>= public :: models_5 <>= subroutine models_5 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_list_t) :: model_list type(model_t), pointer :: model, model_instance character(32) :: md5sum write (u, "(A)") "* Test output: models_5" write (u, "(A)") "* Purpose: access and modify model variables" write (u, *) call syntax_model_file_init () call os_data%init () write (u, "(A)") "* Read model from file" call model_list%read_model (var_str ("Test"), var_str ("Test.mdl"), & os_data, model) write (u, *) call model%write (u, & show_md5sum = .true., & show_variables = .true., & show_parameters = .true., & show_particles = .false., & show_vertices = .false.) write (u, *) write (u, "(A)") "* Check parameter status" write (u, *) write (u, "(1x,A,L1)") "xy exists = ", model%var_exists (var_str ("xx")) write (u, "(1x,A,L1)") "ff exists = ", model%var_exists (var_str ("ff")) write (u, "(1x,A,L1)") "mf exists = ", model%var_exists (var_str ("mf")) write (u, "(1x,A,L1)") "ff locked = ", model%var_is_locked (var_str ("ff")) write (u, "(1x,A,L1)") "mf locked = ", model%var_is_locked (var_str ("mf")) write (u, *) write (u, "(1x,A,F6.2)") "ff = ", model%get_rval (var_str ("ff")) write (u, "(1x,A,F6.2)") "mf = ", model%get_rval (var_str ("mf")) write (u, *) write (u, "(A)") "* Modify parameter" write (u, *) call model%set_real (var_str ("ff"), 1._default) call model%write (u, & show_md5sum = .true., & show_variables = .true., & show_parameters = .true., & show_particles = .false., & show_vertices = .false.) write (u, *) write (u, "(A)") "* Cleanup" call model_list%final () call syntax_model_file_final () write (u, *) write (u, "(A)") "* Test output end: models_5" end subroutine models_5 @ %def models_5 @ \subsubsection{Read model with disordered parameters} Read a model from file where the ordering of independent and derived parameters is non-canonical. <>= call test (models_6, "models_6", & "read model parameters", & u, results) <>= public :: models_6 <>= subroutine models_6 (u) integer, intent(in) :: u integer :: um character(80) :: buffer type(os_data_t) :: os_data type(model_list_t) :: model_list type(var_list_t), pointer :: var_list type(model_t), pointer :: model write (u, "(A)") "* Test output: models_6" write (u, "(A)") "* Purpose: read a model from file & &with non-canonical parameter ordering" write (u, *) open (newunit=um, file="Test6.mdl", status="replace", action="readwrite") write (um, "(A)") 'model "Test6"' write (um, "(A)") ' parameter a = 1.000000000000E+00' write (um, "(A)") ' derived b = 2 * a' write (um, "(A)") ' parameter c = 3.000000000000E+00' write (um, "(A)") ' unused d' rewind (um) do read (um, "(A)", end=1) buffer write (u, "(A)") trim (buffer) end do 1 continue close (um) call syntax_model_file_init () call os_data%init () call model_list%read_model (var_str ("Test6"), var_str ("Test6.mdl"), & os_data, model) write (u, *) write (u, "(A)") "* Variable list" write (u, *) var_list => model%get_var_list_ptr () call var_list%write (u) write (u, *) write (u, "(A)") "* Cleanup" call model_list%final () call syntax_model_file_final () write (u, *) write (u, "(A)") "* Test output end: models_6" end subroutine models_6 @ %def models_6 @ \subsubsection{Read model with schemes} Read a model from file which supports scheme selection in the parameter list. <>= call test (models_7, "models_7", & "handle schemes", & u, results) <>= public :: models_7 <>= subroutine models_7 (u) integer, intent(in) :: u integer :: um character(80) :: buffer type(os_data_t) :: os_data type(model_list_t) :: model_list type(var_list_t), pointer :: var_list type(model_t), pointer :: model write (u, "(A)") "* Test output: models_7" write (u, "(A)") "* Purpose: read a model from file & &with scheme selection" write (u, *) open (newunit=um, file="Test7.mdl", status="replace", action="readwrite") write (um, "(A)") 'model "Test7"' write (um, "(A)") ' schemes = "foo", "bar", "gee"' write (um, "(A)") '' write (um, "(A)") ' select scheme' write (um, "(A)") ' scheme "foo"' write (um, "(A)") ' parameter a = 1' write (um, "(A)") ' derived b = 2 * a' write (um, "(A)") ' scheme other' write (um, "(A)") ' parameter b = 4' write (um, "(A)") ' derived a = b / 2' write (um, "(A)") ' end select' write (um, "(A)") '' write (um, "(A)") ' parameter c = 3' write (um, "(A)") '' write (um, "(A)") ' select scheme' write (um, "(A)") ' scheme "foo", "gee"' write (um, "(A)") ' derived d = b + c' write (um, "(A)") ' scheme other' write (um, "(A)") ' unused d' write (um, "(A)") ' end select' rewind (um) do read (um, "(A)", end=1) buffer write (u, "(A)") trim (buffer) end do 1 continue close (um) call syntax_model_file_init () call os_data%init () write (u, *) write (u, "(A)") "* Model output, default scheme (= foo)" write (u, *) call model_list%read_model (var_str ("Test7"), var_str ("Test7.mdl"), & os_data, model) call model%write (u, show_md5sum=.false.) call show_var_list () call show_par_array () call model_list%final () write (u, *) write (u, "(A)") "* Model output, scheme foo" write (u, *) call model_list%read_model (var_str ("Test7"), var_str ("Test7.mdl"), & os_data, model, scheme = var_str ("foo")) call model%write (u, show_md5sum=.false.) call show_var_list () call show_par_array () call model_list%final () write (u, *) write (u, "(A)") "* Model output, scheme bar" write (u, *) call model_list%read_model (var_str ("Test7"), var_str ("Test7.mdl"), & os_data, model, scheme = var_str ("bar")) call model%write (u, show_md5sum=.false.) call show_var_list () call show_par_array () call model_list%final () write (u, *) write (u, "(A)") "* Model output, scheme gee" write (u, *) call model_list%read_model (var_str ("Test7"), var_str ("Test7.mdl"), & os_data, model, scheme = var_str ("gee")) call model%write (u, show_md5sum=.false.) call show_var_list () call show_par_array () write (u, *) write (u, "(A)") "* Cleanup" call model_list%final () call syntax_model_file_final () write (u, *) write (u, "(A)") "* Test output end: models_7" contains subroutine show_var_list () write (u, *) write (u, "(A)") "* Variable list" write (u, *) var_list => model%get_var_list_ptr () call var_list%write (u) end subroutine show_var_list subroutine show_par_array () real(default), dimension(:), allocatable :: par integer :: n write (u, *) write (u, "(A)") "* Parameter array" write (u, *) n = model%get_n_real () allocate (par (n)) call model%real_parameters_to_array (par) write (u, 1) par 1 format (1X,F6.3) end subroutine show_par_array end subroutine models_7 @ %def models_7 @ \subsubsection{Read and handle UFO model} Read a model from file which is considered as an UFO model. In fact, it is a mock model file which just follows our naming convention for UFO models. Compare this to an equivalent non-UFO model. <>= call test (models_8, "models_8", & "handle UFO-derived models", & u, results) <>= public :: models_8 <>= subroutine models_8 (u) integer, intent(in) :: u integer :: um character(80) :: buffer type(os_data_t) :: os_data type(model_list_t) :: model_list type(string_t) :: model_name type(model_t), pointer :: model write (u, "(A)") "* Test output: models_8" write (u, "(A)") "* Purpose: distinguish models marked as UFO-derived" write (u, *) call os_data%init () call show_model_list_status () model_name = "models_8_M" write (u, *) write (u, "(A)") "* Write WHIZARD model" write (u, *) open (newunit=um, file=char (model_name // ".mdl"), & status="replace", action="readwrite") write (um, "(A)") 'model "models_8_M"' write (um, "(A)") ' parameter a = 1' rewind (um) do read (um, "(A)", end=1) buffer write (u, "(A)") trim (buffer) end do 1 continue close (um) write (u, *) write (u, "(A)") "* Write UFO model" write (u, *) open (newunit=um, file=char (model_name // ".ufo.mdl"), & status="replace", action="readwrite") write (um, "(A)") 'model "models_8_M"' write (um, "(A)") ' parameter a = 2' rewind (um) do read (um, "(A)", end=2) buffer write (u, "(A)") trim (buffer) end do 2 continue close (um) call syntax_model_file_init () call os_data%init () write (u, *) write (u, "(A)") "* Read WHIZARD model" write (u, *) call model_list%read_model (model_name, model_name // ".mdl", & os_data, model) call model%write (u, show_md5sum=.false.) call show_model_list_status () write (u, *) write (u, "(A)") "* Read UFO model" write (u, *) call model_list%read_model (model_name, model_name // ".ufo.mdl", & os_data, model, ufo=.true., rebuild_mdl = .false.) call model%write (u, show_md5sum=.false.) call show_model_list_status () write (u, *) write (u, "(A)") "* Reload WHIZARD model" write (u, *) call model_list%read_model (model_name, model_name // ".mdl", & os_data, model) call model%write (u, show_md5sum=.false.) call show_model_list_status () write (u, *) write (u, "(A)") "* Reload UFO model" write (u, *) call model_list%read_model (model_name, model_name // ".ufo.mdl", & os_data, model, ufo=.true., rebuild_mdl = .false.) call model%write (u, show_md5sum=.false.) call show_model_list_status () write (u, *) write (u, "(A)") "* Cleanup" call model_list%final () call syntax_model_file_final () write (u, *) write (u, "(A)") "* Test output end: models_8" contains subroutine show_model_list_status () write (u, "(A)") "* Model list status" write (u, *) write (u, "(A,1x,L1)") "WHIZARD model exists =", & model_list%model_exists (model_name) write (u, "(A,1x,L1)") "UFO model exists =", & model_list%model_exists (model_name, ufo=.true.) end subroutine show_model_list_status end subroutine models_8 @ %def models_8 @ \subsubsection{Generate UFO model file} Generate the necessary [[.ufo.mdl]] file from source, calling OMega, and load the model. Note: There must not be another unit test which works with the same UFO model. The model file is deleted explicitly at the end of this test. <>= call test (models_9, "models_9", & "generate UFO-derived model file", & u, results) <>= public :: models_9 <>= subroutine models_9 (u) integer, intent(in) :: u integer :: um character(80) :: buffer type(os_data_t) :: os_data type(model_list_t) :: model_list type(string_t) :: model_name, model_file_name type(model_t), pointer :: model write (u, "(A)") "* Test output: models_9" write (u, "(A)") "* Purpose: enable the UFO Standard Model (test version)" write (u, *) call os_data%init () call syntax_model_file_init () os_data%whizard_modelpath_ufo = "../models/UFO" model_name = "SM" model_file_name = model_name // ".models_9" // ".ufo.mdl" write (u, "(A)") "* Generate and read UFO model" write (u, *) call delete_file (char (model_file_name)) call model_list%read_model (model_name, model_file_name, os_data, model, ufo=.true.) call model%write (u, show_md5sum=.false.) write (u, *) write (u, "(A)") "* Cleanup" call model_list%final () call syntax_model_file_final () write (u, *) write (u, "(A)") "* Test output end: models_9" end subroutine models_9 @ %def models_9 @ \subsubsection{Read model with schemes} Read a model from file which contains [[slha_entry]] qualifiers for parameters. <>= call test (models_10, "models_10", & "handle slha_entry option", & u, results) <>= public :: models_10 <>= subroutine models_10 (u) integer, intent(in) :: u integer :: um character(80) :: buffer type(os_data_t) :: os_data type(model_list_t) :: model_list type(var_list_t), pointer :: var_list type(model_t), pointer :: model type(string_t), dimension(:), allocatable :: slha_block_name integer :: i write (u, "(A)") "* Test output: models_10" write (u, "(A)") "* Purpose: read a model from file & &with slha_entry options" write (u, *) open (newunit=um, file="Test10.mdl", status="replace", action="readwrite") write (um, "(A)") 'model "Test10"' write (um, "(A)") ' parameter a = 1 slha_entry FOO 1' write (um, "(A)") ' parameter b = 4 slha_entry BAR 2 1' rewind (um) do read (um, "(A)", end=1) buffer write (u, "(A)") trim (buffer) end do 1 continue close (um) call syntax_model_file_init () call os_data%init () write (u, *) write (u, "(A)") "* Model output, default scheme (= foo)" write (u, *) call model_list%read_model (var_str ("Test10"), var_str ("Test10.mdl"), & os_data, model) call model%write (u, show_md5sum=.false.) write (u, *) write (u, "(A)") "* Check that model contains slha_entry options" write (u, *) write (u, "(A,1x,L1)") & "supports_custom_slha =", model%supports_custom_slha () write (u, *) write (u, "(A)") "custom_slha_blocks =" call model%get_custom_slha_blocks (slha_block_name) do i = 1, size (slha_block_name) write (u, "(1x,A)", advance="no") char (slha_block_name(i)) end do write (u, *) write (u, *) write (u, "(A)") "* Parameter lookup" write (u, *) call show_slha ("FOO", [1]) call show_slha ("FOO", [2]) call show_slha ("BAR", [2, 1]) call show_slha ("GEE", [3]) write (u, *) write (u, "(A)") "* Modify parameter via SLHA block interface" write (u, *) call model%slha_set_par (var_str ("FOO"), [1], 7._default) call show_slha ("FOO", [1]) write (u, *) write (u, "(A)") "* Show var list with modified parameter" write (u, *) call show_var_list () write (u, *) write (u, "(A)") "* Cleanup" call model_list%final () call syntax_model_file_final () write (u, *) write (u, "(A)") "* Test output end: models_10" contains subroutine show_slha (block_name, block_index) character(*), intent(in) :: block_name integer, dimension(:), intent(in) :: block_index class(modelpar_data_t), pointer :: par_data write (u, "(A,*(1x,I0))", advance="no") block_name, block_index write (u, "(' => ')", advance="no") call model%slha_lookup (var_str (block_name), block_index, par_data) if (associated (par_data)) then call par_data%write (u) write (u, *) else write (u, "('-')") end if end subroutine show_slha subroutine show_var_list () var_list => model%get_var_list_ptr () call var_list%write (u) end subroutine show_var_list end subroutine models_10 @ %def models_10 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{The SUSY Les Houches Accord} The SUSY Les Houches Accord defines a standard interfaces for storing the physics data of SUSY models. Here, we provide the means for reading, storing, and writing such data. <<[[slha_interface.f90]]>>= <> module slha_interface <> <> use io_units use constants use string_utils, only: upper_case use system_defs, only: VERSION_STRING use system_defs, only: EOF use diagnostics use os_interface use ifiles use lexers use syntax_rules use parser use variables use models <> <> <> <> save contains <> <> end module slha_interface @ %def slha_interface @ \subsection{Preprocessor} SLHA is a mixed-format standard. It should be read in assuming free format (but line-oriented), but it has some fixed-format elements. To overcome this difficulty, we implement a preprocessing step which transforms the SLHA into a format that can be swallowed by our generic free-format lexer and parser. Each line with a blank first character is assumed to be a data line. We prepend a 'DATA' keyword to these lines. Furthermore, to enforce line-orientation, each line is appended a '\$' key which is recognized by the parser. To do this properly, we first remove trailing comments, and skip lines consisting only of comments. The preprocessor reads from a stream and puts out an [[ifile]]. Blocks that are not recognized are skipped. For some blocks, data items are quoted, so they can be read as strings if necessary. A name clash occurse if the block name is identical to a keyword. This can happen for custom SLHA models and files. In that case, we prepend an underscore, which will be silently suppressed where needed. <>= integer, parameter :: MODE_SKIP = 0, MODE_DATA = 1, MODE_INFO = 2 @ %def MODE_SKIP = 0, MODE_DATA = 1, MODE_INFO = 2 <>= subroutine slha_preprocess (stream, custom_block_name, ifile) type(stream_t), intent(inout), target :: stream type(string_t), dimension(:), intent(in) :: custom_block_name type(ifile_t), intent(out) :: ifile type(string_t) :: buffer, line, item integer :: iostat integer :: mode mode = MODE SCAN_FILE: do call stream_get_record (stream, buffer, iostat) select case (iostat) case (0) call split (buffer, line, "#") if (len_trim (line) == 0) cycle SCAN_FILE select case (char (extract (line, 1, 1))) case ("B", "b") call check_block_handling (line, custom_block_name, mode) call ifile_append (ifile, line // "$") case ("D", "d") mode = MODE_DATA call ifile_append (ifile, line // "$") case (" ") select case (mode) case (MODE_DATA) call ifile_append (ifile, "DATA" // line // "$") case (MODE_INFO) line = adjustl (line) call split (line, item, " ") call ifile_append (ifile, "INFO" // " " // item // " " & // '"' // trim (adjustl (line)) // '" $') end select case default call msg_message (char (line)) call msg_fatal ("SLHA: Incomprehensible line") end select case (EOF) exit SCAN_FILE case default call msg_fatal ("SLHA: I/O error occured while reading SLHA input") end select end do SCAN_FILE end subroutine slha_preprocess @ %def slha_preprocess @ Return the mode that we should treat this block with. We add the [[custom_block_name]] array to the set of supported blocks, which otherwise includes only hard-coded block names. Those custom blocks are data blocks. Unknown blocks will be skipped altogether. The standard does not specify their internal format at all, so we must not parse their content. If the name of a (custom) block clashes with a keyword of the SLHA syntax, we append an underscore to the block name, modifying the current line string. This should be silently suppressed when actually parsing block names. <>= subroutine check_block_handling (line, custom_block_name, mode) type(string_t), intent(inout) :: line type(string_t), dimension(:), intent(in) :: custom_block_name integer, intent(out) :: mode type(string_t) :: buffer, key, block_name integer :: i buffer = trim (line) call split (buffer, key, " ") buffer = adjustl (buffer) call split (buffer, block_name, " ") buffer = adjustl (buffer) block_name = trim (adjustl (upper_case (block_name))) select case (char (block_name)) case ("MODSEL", "MINPAR", "SMINPUTS") mode = MODE_DATA case ("MASS") mode = MODE_DATA case ("NMIX", "UMIX", "VMIX", "STOPMIX", "SBOTMIX", "STAUMIX") mode = MODE_DATA case ("NMHMIX", "NMAMIX", "NMNMIX", "NMSSMRUN") mode = MODE_DATA case ("ALPHA", "HMIX") mode = MODE_DATA case ("AU", "AD", "AE") mode = MODE_DATA case ("SPINFO", "DCINFO") mode = MODE_INFO case default mode = MODE_SKIP CHECK_CUSTOM_NAMES: do i = 1, size (custom_block_name) if (block_name == custom_block_name(i)) then mode = MODE_DATA call mangle_keywords (block_name) line = key // " " // block_name // " " // trim (buffer) exit CHECK_CUSTOM_NAMES end if end do CHECK_CUSTOM_NAMES end select end subroutine check_block_handling @ %def check_block_handling @ Append an underscore to specific block names: <>= subroutine mangle_keywords (name) type(string_t), intent(inout) :: name select case (char (name)) case ("BLOCK", "DATA", "INFO", "DECAY") name = name // "_" end select end subroutine mangle_keywords @ %def mangle_keywords @ Remove the underscore again: <>= subroutine demangle_keywords (name) type(string_t), intent(inout) :: name select case (char (name)) case ("BLOCK_", "DATA_", "INFO_", "DECAY_") name = extract (name, 1, len(name)-1) end select end subroutine demangle_keywords @ %def demangle_keywords @ \subsection{Lexer and syntax} <>= type(syntax_t), target :: syntax_slha @ %def syntax_slha <>= public :: syntax_slha_init <>= subroutine syntax_slha_init () type(ifile_t) :: ifile call define_slha_syntax (ifile) call syntax_init (syntax_slha, ifile) call ifile_final (ifile) end subroutine syntax_slha_init @ %def syntax_slha_init <>= public :: syntax_slha_final <>= subroutine syntax_slha_final () call syntax_final (syntax_slha) end subroutine syntax_slha_final @ %def syntax_slha_final <>= public :: syntax_slha_write <>= subroutine syntax_slha_write (unit) integer, intent(in), optional :: unit call syntax_write (syntax_slha, unit) end subroutine syntax_slha_write @ %def syntax_slha_write <>= subroutine define_slha_syntax (ifile) type(ifile_t), intent(inout) :: ifile call ifile_append (ifile, "SEQ slha = chunk*") call ifile_append (ifile, "ALT chunk = block_def | decay_def") call ifile_append (ifile, "SEQ block_def = " & // "BLOCK blockgen '$' block_line*") call ifile_append (ifile, "ALT blockgen = block_spec | q_spec") call ifile_append (ifile, "KEY BLOCK") call ifile_append (ifile, "SEQ q_spec = QNUMBERS pdg_code") call ifile_append (ifile, "KEY QNUMBERS") call ifile_append (ifile, "SEQ block_spec = block_name qvalue?") call ifile_append (ifile, "IDE block_name") call ifile_append (ifile, "SEQ qvalue = qname '=' real") call ifile_append (ifile, "IDE qname") call ifile_append (ifile, "KEY '='") call ifile_append (ifile, "REA real") call ifile_append (ifile, "KEY '$'") call ifile_append (ifile, "ALT block_line = block_data | block_info") call ifile_append (ifile, "SEQ block_data = DATA data_line '$'") call ifile_append (ifile, "KEY DATA") call ifile_append (ifile, "SEQ data_line = data_item+") call ifile_append (ifile, "ALT data_item = signed_number | number") call ifile_append (ifile, "SEQ signed_number = sign number") call ifile_append (ifile, "ALT sign = '+' | '-'") call ifile_append (ifile, "ALT number = integer | real") call ifile_append (ifile, "INT integer") call ifile_append (ifile, "KEY '-'") call ifile_append (ifile, "KEY '+'") call ifile_append (ifile, "SEQ block_info = INFO info_line '$'") call ifile_append (ifile, "KEY INFO") call ifile_append (ifile, "SEQ info_line = integer string_literal") call ifile_append (ifile, "QUO string_literal = '""'...'""'") call ifile_append (ifile, "SEQ decay_def = " & // "DECAY decay_spec '$' decay_data*") call ifile_append (ifile, "KEY DECAY") call ifile_append (ifile, "SEQ decay_spec = pdg_code data_item") call ifile_append (ifile, "ALT pdg_code = signed_integer | integer") call ifile_append (ifile, "SEQ signed_integer = sign integer") call ifile_append (ifile, "SEQ decay_data = DATA decay_line '$'") call ifile_append (ifile, "SEQ decay_line = data_item integer pdg_code+") end subroutine define_slha_syntax @ %def define_slha_syntax @ The SLHA specification allows for string data items in certain places. Currently, we do not interpret them, but the strings, which are not quoted, must be parsed somehow. The hack for this problem is to allow essentially all characters as special characters, so the string can be read before it is discarded. <>= public :: lexer_init_slha <>= subroutine lexer_init_slha (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_slha), & upper_case_keywords = .true.) ! $ end subroutine lexer_init_slha @ %def lexer_init_slha @ \subsection{Interpreter} \subsubsection{Find blocks} From the parse tree, find the node that represents a particular block. If [[required]] is true, issue an error if not found. Since [[block_name]] is always invoked with capital letters, we have to capitalize [[pn_block_name]]. <>= function slha_get_block_ptr & (parse_tree, block_name, required) result (pn_block) type(parse_node_t), pointer :: pn_block type(parse_tree_t), intent(in) :: parse_tree type(string_t), intent(in) :: block_name type(string_t) :: block_def logical, intent(in) :: required type(parse_node_t), pointer :: pn_root, pn_block_spec, pn_block_name pn_root => parse_tree%get_root_ptr () pn_block => parse_node_get_sub_ptr (pn_root) do while (associated (pn_block)) select case (char (parse_node_get_rule_key (pn_block))) case ("block_def") pn_block_spec => parse_node_get_sub_ptr (pn_block, 2) pn_block_name => parse_node_get_sub_ptr (pn_block_spec) select case (char (pn_block_name%get_rule_key ())) case ("block_name") block_def = trim (adjustl (upper_case & (pn_block_name%get_string ()))) case ("QNUMBERS") block_def = "QNUMBERS" end select if (block_def == block_name) then return end if end select pn_block => parse_node_get_next_ptr (pn_block) end do if (required) then call msg_fatal ("SLHA: block '" // char (block_name) // "' not found") end if end function slha_get_block_ptr @ %def slha_get_blck_ptr @ Scan the file for the first/next DECAY block. <>= function slha_get_first_decay_ptr (parse_tree) result (pn_decay) type(parse_node_t), pointer :: pn_decay type(parse_tree_t), intent(in) :: parse_tree type(parse_node_t), pointer :: pn_root pn_root => parse_tree%get_root_ptr () pn_decay => parse_node_get_sub_ptr (pn_root) do while (associated (pn_decay)) select case (char (parse_node_get_rule_key (pn_decay))) case ("decay_def") return end select pn_decay => parse_node_get_next_ptr (pn_decay) end do end function slha_get_first_decay_ptr function slha_get_next_decay_ptr (pn_block) result (pn_decay) type(parse_node_t), pointer :: pn_decay type(parse_node_t), intent(in), target :: pn_block pn_decay => parse_node_get_next_ptr (pn_block) do while (associated (pn_decay)) select case (char (parse_node_get_rule_key (pn_decay))) case ("decay_def") return end select pn_decay => parse_node_get_next_ptr (pn_decay) end do end function slha_get_next_decay_ptr @ %def slha_get_next_decay_ptr @ \subsubsection{Extract and transfer data from blocks} Given the parse node of a block, find the parse node of a particular switch or data line. Return this node and the node of the data item following the integer code. <>= subroutine slha_find_index_ptr (pn_block, pn_data, pn_item, code) type(parse_node_t), intent(in), target :: pn_block type(parse_node_t), intent(out), pointer :: pn_data type(parse_node_t), intent(out), pointer :: pn_item integer, intent(in) :: code pn_data => parse_node_get_sub_ptr (pn_block, 4) call slha_next_index_ptr (pn_data, pn_item, code) end subroutine slha_find_index_ptr subroutine slha_find_index_pair_ptr (pn_block, pn_data, pn_item, code1, code2) type(parse_node_t), intent(in), target :: pn_block type(parse_node_t), intent(out), pointer :: pn_data type(parse_node_t), intent(out), pointer :: pn_item integer, intent(in) :: code1, code2 pn_data => parse_node_get_sub_ptr (pn_block, 4) call slha_next_index_pair_ptr (pn_data, pn_item, code1, code2) end subroutine slha_find_index_pair_ptr @ %def slha_find_index_ptr slha_find_index_pair_ptr @ Starting from the pointer to a data line, find a data line with the given integer code. <>= subroutine slha_next_index_ptr (pn_data, pn_item, code) type(parse_node_t), intent(inout), pointer :: pn_data integer, intent(in) :: code type(parse_node_t), intent(out), pointer :: pn_item type(parse_node_t), pointer :: pn_line, pn_code do while (associated (pn_data)) pn_line => parse_node_get_sub_ptr (pn_data, 2) pn_code => parse_node_get_sub_ptr (pn_line) select case (char (parse_node_get_rule_key (pn_code))) case ("integer") if (parse_node_get_integer (pn_code) == code) then pn_item => parse_node_get_next_ptr (pn_code) return end if end select pn_data => parse_node_get_next_ptr (pn_data) end do pn_item => null () end subroutine slha_next_index_ptr @ %def slha_next_index_ptr @ Starting from the pointer to a data line, find a data line with the given integer code pair. <>= subroutine slha_next_index_pair_ptr (pn_data, pn_item, code1, code2) type(parse_node_t), intent(inout), pointer :: pn_data integer, intent(in) :: code1, code2 type(parse_node_t), intent(out), pointer :: pn_item type(parse_node_t), pointer :: pn_line, pn_code1, pn_code2 do while (associated (pn_data)) pn_line => parse_node_get_sub_ptr (pn_data, 2) pn_code1 => parse_node_get_sub_ptr (pn_line) select case (char (parse_node_get_rule_key (pn_code1))) case ("integer") if (parse_node_get_integer (pn_code1) == code1) then pn_code2 => parse_node_get_next_ptr (pn_code1) if (associated (pn_code2)) then select case (char (parse_node_get_rule_key (pn_code2))) case ("integer") if (parse_node_get_integer (pn_code2) == code2) then pn_item => parse_node_get_next_ptr (pn_code2) return end if end select end if end if end select pn_data => parse_node_get_next_ptr (pn_data) end do pn_item => null () end subroutine slha_next_index_pair_ptr @ %def slha_next_index_pair_ptr @ \subsubsection{Handle info data} Return all strings with index [[i]]. The result is an allocated string array. Since we do not know the number of matching entries in advance, we build an intermediate list which is transferred to the final array and deleted before exiting. <>= subroutine retrieve_strings_in_block (pn_block, code, str_array) type(parse_node_t), intent(in), target :: pn_block integer, intent(in) :: code type(string_t), dimension(:), allocatable, intent(out) :: str_array type(parse_node_t), pointer :: pn_data, pn_item type :: str_entry_t type(string_t) :: str type(str_entry_t), pointer :: next => null () end type str_entry_t type(str_entry_t), pointer :: first => null () type(str_entry_t), pointer :: current => null () integer :: n n = 0 call slha_find_index_ptr (pn_block, pn_data, pn_item, code) if (associated (pn_item)) then n = n + 1 allocate (first) first%str = parse_node_get_string (pn_item) current => first do while (associated (pn_data)) pn_data => parse_node_get_next_ptr (pn_data) call slha_next_index_ptr (pn_data, pn_item, code) if (associated (pn_item)) then n = n + 1 allocate (current%next) current => current%next current%str = parse_node_get_string (pn_item) end if end do allocate (str_array (n)) n = 0 do while (associated (first)) n = n + 1 current => first str_array(n) = current%str first => first%next deallocate (current) end do else allocate (str_array (0)) end if end subroutine retrieve_strings_in_block @ %def retrieve_strings_in_block @ \subsubsection{Transfer data from SLHA to variables} Extract real parameter with index [[i]]. If it does not exist, retrieve it from the variable list, using the given name. <>= function get_parameter_in_block (pn_block, code, name, var_list) result (var) real(default) :: var type(parse_node_t), intent(in), target :: pn_block integer, intent(in) :: code type(string_t), intent(in) :: name type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_data, pn_item call slha_find_index_ptr (pn_block, pn_data, pn_item, code) if (associated (pn_item)) then var = get_real_parameter (pn_item) else var = var_list%get_rval (name) end if end function get_parameter_in_block @ %def get_parameter_in_block @ Extract a real data item with index [[i]]. If it does exist, set it in the variable list, using the given name. If the variable is not present in the variable list, ignore it. <>= subroutine set_data_item (pn_block, code, name, var_list) type(parse_node_t), intent(in), target :: pn_block integer, intent(in) :: code type(string_t), intent(in) :: name type(var_list_t), intent(inout), target :: var_list type(parse_node_t), pointer :: pn_data, pn_item call slha_find_index_ptr (pn_block, pn_data, pn_item, code) if (associated (pn_item)) then call var_list%set_real (name, get_real_parameter (pn_item), & is_known=.true., ignore=.true.) end if end subroutine set_data_item @ %def set_data_item @ Extract a real matrix element with index [[i,j]]. If it does exists, set it in the variable list, using the given name. If the variable is not present in the variable list, ignore it. <>= subroutine set_matrix_element (pn_block, code1, code2, name, var_list) type(parse_node_t), intent(in), target :: pn_block integer, intent(in) :: code1, code2 type(string_t), intent(in) :: name type(var_list_t), intent(inout), target :: var_list type(parse_node_t), pointer :: pn_data, pn_item call slha_find_index_pair_ptr (pn_block, pn_data, pn_item, code1, code2) if (associated (pn_item)) then call var_list%set_real (name, get_real_parameter (pn_item), & is_known=.true., ignore=.true.) end if end subroutine set_matrix_element @ %def set_matrix_element @ \subsubsection{Transfer data from variables to SLHA} Get a real/integer parameter with index [[i]] from the variable list and write it to the current output file. In the integer case, we account for the fact that the variable is type real. If it does not exist, do nothing. <>= subroutine write_integer_data_item (u, code, name, var_list, comment) integer, intent(in) :: u integer, intent(in) :: code type(string_t), intent(in) :: name type(var_list_t), intent(in) :: var_list character(*), intent(in) :: comment integer :: item if (var_list%contains (name)) then item = nint (var_list%get_rval (name)) call write_integer_parameter (u, code, item, comment) end if end subroutine write_integer_data_item subroutine write_real_data_item (u, code, name, var_list, comment) integer, intent(in) :: u integer, intent(in) :: code type(string_t), intent(in) :: name type(var_list_t), intent(in) :: var_list character(*), intent(in) :: comment real(default) :: item if (var_list%contains (name)) then item = var_list%get_rval (name) call write_real_parameter (u, code, item, comment) end if end subroutine write_real_data_item @ %def write_real_data_item @ Get a real data item with two integer indices from the variable list and write it to the current output file. If it does not exist, do nothing. <>= subroutine write_matrix_element (u, code1, code2, name, var_list, comment) integer, intent(in) :: u integer, intent(in) :: code1, code2 type(string_t), intent(in) :: name type(var_list_t), intent(in) :: var_list character(*), intent(in) :: comment real(default) :: item if (var_list%contains (name)) then item = var_list%get_rval (name) call write_real_matrix_element (u, code1, code2, item, comment) end if end subroutine write_matrix_element @ %def write_matrix_element @ \subsection{Auxiliary function} Write a block header. <>= subroutine write_block_header (u, name, comment) integer, intent(in) :: u character(*), intent(in) :: name, comment write (u, "(A,1x,A,3x,'#',1x,A)") "BLOCK", name, comment end subroutine write_block_header @ %def write_block_header @ Extract a real parameter that may be defined real or integer, signed or unsigned. <>= function get_real_parameter (pn_item) result (var) real(default) :: var type(parse_node_t), intent(in), target :: pn_item type(parse_node_t), pointer :: pn_sign, pn_var integer :: sign select case (char (parse_node_get_rule_key (pn_item))) case ("signed_number") pn_sign => parse_node_get_sub_ptr (pn_item) pn_var => parse_node_get_next_ptr (pn_sign) select case (char (parse_node_get_key (pn_sign))) case ("+"); sign = +1 case ("-"); sign = -1 end select case default sign = +1 pn_var => pn_item end select select case (char (parse_node_get_rule_key (pn_var))) case ("integer"); var = sign * parse_node_get_integer (pn_var) case ("real"); var = sign * parse_node_get_real (pn_var) end select end function get_real_parameter @ %def get_real_parameter @ Auxiliary: Extract an integer parameter that may be defined signed or unsigned. A real value is an error. <>= function get_integer_parameter (pn_item) result (var) integer :: var type(parse_node_t), intent(in), target :: pn_item type(parse_node_t), pointer :: pn_sign, pn_var integer :: sign select case (char (parse_node_get_rule_key (pn_item))) case ("signed_integer") pn_sign => parse_node_get_sub_ptr (pn_item) pn_var => parse_node_get_next_ptr (pn_sign) select case (char (parse_node_get_key (pn_sign))) case ("+"); sign = +1 case ("-"); sign = -1 end select case ("integer") sign = +1 pn_var => pn_item case default call parse_node_write (pn_var) call msg_error ("SLHA: Integer parameter expected") var = 0 return end select var = sign * parse_node_get_integer (pn_var) end function get_integer_parameter @ %def get_real_parameter @ Write an integer parameter with a single index directly to file, using the required output format. <>= subroutine write_integer_parameter (u, code, item, comment) integer, intent(in) :: u integer, intent(in) :: code integer, intent(in) :: item character(*), intent(in) :: comment 1 format (1x, I9, 3x, 3x, I9, 4x, 3x, '#', 1x, A) write (u, 1) code, item, comment end subroutine write_integer_parameter @ %def write_integer_parameter @ Write a real parameter with two indices directly to file, using the required output format. <>= subroutine write_real_parameter (u, code, item, comment) integer, intent(in) :: u integer, intent(in) :: code real(default), intent(in) :: item character(*), intent(in) :: comment 1 format (1x, I9, 3x, 1P, E16.8, 0P, 3x, '#', 1x, A) write (u, 1) code, item, comment end subroutine write_real_parameter @ %def write_real_parameter @ Write a real parameter with a single index directly to file, using the required output format. <>= subroutine write_real_matrix_element (u, code1, code2, item, comment) integer, intent(in) :: u integer, intent(in) :: code1, code2 real(default), intent(in) :: item character(*), intent(in) :: comment 1 format (1x, I2, 1x, I2, 3x, 1P, E16.8, 0P, 3x, '#', 1x, A) write (u, 1) code1, code2, item, comment end subroutine write_real_matrix_element @ %def write_real_matrix_element @ \subsubsection{The concrete SLHA interpreter} SLHA codes for particular physics models <>= integer, parameter :: MDL_MSSM = 0 integer, parameter :: MDL_NMSSM = 1 @ %def MDL_MSSM MDL_NMSSM @ Take the parse tree and extract relevant data. Select the correct model and store all data that is present in the appropriate variable list. Finally, update the variable record. We assume that if the model contains custom SLHA block names, we just have to scan those to get complete information. Block names could coincide with the SLHA standard block names, but we do not have to assume this. This will be the situation for an UFO-generated file. In particular, an UFO file should contain all expressions necessary for computing dependent parameters, so we can forget about the strict SLHA standard and its hard-coded conventions. If there are no custom SLHA block names, we should assume that the model is a standard SUSY model, and the parameters and hard-coded blocks can be read as specified by the original SLHA standard. There are hard-coded block names and parameter calculations. Public for use in unit test. <>= public :: slha_interpret_parse_tree <>= subroutine slha_interpret_parse_tree & (parse_tree, model, input, spectrum, decays) type(parse_tree_t), intent(in) :: parse_tree type(model_t), intent(inout), target :: model logical, intent(in) :: input, spectrum, decays logical :: errors integer :: mssm_type if (model%supports_custom_slha ()) then call slha_handle_custom_file (parse_tree, model) else call slha_handle_MODSEL (parse_tree, model, mssm_type) if (input) then call slha_handle_SMINPUTS (parse_tree, model) call slha_handle_MINPAR (parse_tree, model, mssm_type) end if if (spectrum) then call slha_handle_info_block (parse_tree, "SPINFO", errors) if (errors) return call slha_handle_MASS (parse_tree, model) call slha_handle_matrix_block (parse_tree, "NMIX", "mn_", 4, 4, model) call slha_handle_matrix_block (parse_tree, "NMNMIX", "mixn_", 5, 5, model) call slha_handle_matrix_block (parse_tree, "UMIX", "mu_", 2, 2, model) call slha_handle_matrix_block (parse_tree, "VMIX", "mv_", 2, 2, model) call slha_handle_matrix_block (parse_tree, "STOPMIX", "mt_", 2, 2, model) call slha_handle_matrix_block (parse_tree, "SBOTMIX", "mb_", 2, 2, model) call slha_handle_matrix_block (parse_tree, "STAUMIX", "ml_", 2, 2, model) call slha_handle_matrix_block (parse_tree, "NMHMIX", "mixh0_", 3, 3, model) call slha_handle_matrix_block (parse_tree, "NMAMIX", "mixa0_", 2, 3, model) call slha_handle_ALPHA (parse_tree, model) call slha_handle_HMIX (parse_tree, model) call slha_handle_NMSSMRUN (parse_tree, model) call slha_handle_matrix_block (parse_tree, "AU", "Au_", 3, 3, model) call slha_handle_matrix_block (parse_tree, "AD", "Ad_", 3, 3, model) call slha_handle_matrix_block (parse_tree, "AE", "Ae_", 3, 3, model) end if end if if (decays) then call slha_handle_info_block (parse_tree, "DCINFO", errors) if (errors) return call slha_handle_decays (parse_tree, model) end if end subroutine slha_interpret_parse_tree @ %def slha_interpret_parse_tree @ \subsubsection{Info blocks} Handle the informational blocks SPINFO and DCINFO. The first two items are program name and version. Items with index 3 are warnings. Items with index 4 are errors. We reproduce these as WHIZARD warnings and errors. <>= subroutine slha_handle_info_block (parse_tree, block_name, errors) type(parse_tree_t), intent(in) :: parse_tree character(*), intent(in) :: block_name logical, intent(out) :: errors type(parse_node_t), pointer :: pn_block type(string_t), dimension(:), allocatable :: msg integer :: i pn_block => slha_get_block_ptr & (parse_tree, var_str (block_name), required=.true.) if (.not. associated (pn_block)) then call msg_error ("SLHA: Missing info block '" & // trim (block_name) // "'; ignored.") errors = .true. return end if select case (block_name) case ("SPINFO") call msg_message ("SLHA: SUSY spectrum program info:") case ("DCINFO") call msg_message ("SLHA: SUSY decay program info:") end select call retrieve_strings_in_block (pn_block, 1, msg) do i = 1, size (msg) call msg_message ("SLHA: " // char (msg(i))) end do call retrieve_strings_in_block (pn_block, 2, msg) do i = 1, size (msg) call msg_message ("SLHA: " // char (msg(i))) end do call retrieve_strings_in_block (pn_block, 3, msg) do i = 1, size (msg) call msg_warning ("SLHA: " // char (msg(i))) end do call retrieve_strings_in_block (pn_block, 4, msg) do i = 1, size (msg) call msg_error ("SLHA: " // char (msg(i))) end do errors = size (msg) > 0 end subroutine slha_handle_info_block @ %def slha_handle_info_block @ \subsubsection{MODSEL} Handle the overall model definition. Only certain models are recognized. The soft-breaking model templates that determine the set of input parameters. This block used to be required, but for generic UFO model support we should allow for its absence. In that case, [[mssm_type]] will be set to a negative value. If the block is present, the model must be one of the following, or parsing ends with an error. <>= integer, parameter :: MSSM_GENERIC = 0 integer, parameter :: MSSM_SUGRA = 1 integer, parameter :: MSSM_GMSB = 2 integer, parameter :: MSSM_AMSB = 3 @ %def MSSM_GENERIC MSSM_MSUGRA MSSM_GMSB MSSM_AMSB <>= subroutine slha_handle_MODSEL (parse_tree, model, mssm_type) type(parse_tree_t), intent(in) :: parse_tree type(model_t), intent(in), target :: model integer, intent(out) :: mssm_type type(parse_node_t), pointer :: pn_block, pn_data, pn_item type(string_t) :: model_name pn_block => slha_get_block_ptr & (parse_tree, var_str ("MODSEL"), required=.false.) if (.not. associated (pn_block)) then mssm_type = -1 return end if call slha_find_index_ptr (pn_block, pn_data, pn_item, 1) if (associated (pn_item)) then mssm_type = get_integer_parameter (pn_item) else mssm_type = MSSM_GENERIC end if call slha_find_index_ptr (pn_block, pn_data, pn_item, 3) if (associated (pn_item)) then select case (parse_node_get_integer (pn_item)) case (MDL_MSSM); model_name = "MSSM" case (MDL_NMSSM); model_name = "NMSSM" case default call msg_fatal ("SLHA: unknown model code in MODSEL") return end select else model_name = "MSSM" end if call slha_find_index_ptr (pn_block, pn_data, pn_item, 4) if (associated (pn_item)) then call msg_fatal (" R-parity violation is currently not supported by WHIZARD.") end if call slha_find_index_ptr (pn_block, pn_data, pn_item, 5) if (associated (pn_item)) then call msg_fatal (" CP violation is currently not supported by WHIZARD.") end if select case (char (model_name)) case ("MSSM") select case (char (model%get_name ())) case ("MSSM","MSSM_CKM","MSSM_Grav","MSSM_Hgg") model_name = model%get_name () case default call msg_fatal ("Selected model '" & // char (model%get_name ()) // "' does not match model '" & // char (model_name) // "' in SLHA input file.") return end select case ("NMSSM") select case (char (model%get_name ())) case ("NMSSM","NMSSM_CKM","NMSSM_Hgg") model_name = model%get_name () case default call msg_fatal ("Selected model '" & // char (model%get_name ()) // "' does not match model '" & // char (model_name) // "' in SLHA input file.") return end select case default call msg_bug ("SLHA model name '" & // char (model_name) // "' not recognized.") return end select call msg_message ("SLHA: Initializing model '" // char (model_name) // "'") end subroutine slha_handle_MODSEL @ %def slha_handle_MODSEL @ Write a MODSEL block, based on the contents of the current model. <>= subroutine slha_write_MODSEL (u, model, mssm_type) integer, intent(in) :: u type(model_t), intent(in), target :: model integer, intent(out) :: mssm_type type(var_list_t), pointer :: var_list integer :: model_id type(string_t) :: mtype_string var_list => model%get_var_list_ptr () if (var_list%contains (var_str ("mtype"))) then mssm_type = nint (var_list%get_rval (var_str ("mtype"))) else call msg_error ("SLHA: parameter 'mtype' (SUSY breaking scheme) " & // "is unknown in current model, no SLHA output possible") mssm_type = -1 return end if call write_block_header (u, "MODSEL", "SUSY model selection") select case (mssm_type) case (0); mtype_string = "Generic MSSM" case (1); mtype_string = "SUGRA" case (2); mtype_string = "GMSB" case (3); mtype_string = "AMSB" case default mtype_string = "unknown" end select call write_integer_parameter (u, 1, mssm_type, & "SUSY-breaking scheme: " // char (mtype_string)) select case (char (model%get_name ())) case ("MSSM"); model_id = MDL_MSSM case ("NMSSM"); model_id = MDL_NMSSM case default model_id = 0 end select call write_integer_parameter (u, 3, model_id, & "SUSY model type: " // char (model%get_name ())) end subroutine slha_write_MODSEL @ %def slha_write_MODSEL @ \subsubsection{SMINPUTS} Read SM parameters and update the variable list accordingly. If a parameter is not defined in the block, we use the previous value from the model variable list. For the basic parameters we have to do a small recalculation, since SLHA uses the $G_F$-$\alpha$-$m_Z$ scheme, while \whizard\ derives them from $G_F$, $m_W$, and $m_Z$. <>= subroutine slha_handle_SMINPUTS (parse_tree, model) type(parse_tree_t), intent(in) :: parse_tree type(model_t), intent(inout), target :: model type(parse_node_t), pointer :: pn_block real(default) :: alpha_em_i, GF, alphas, mZ real(default) :: ee, vv, cw_sw, cw2, mW real(default) :: mb, mtop, mtau type(var_list_t), pointer :: var_list var_list => model%get_var_list_ptr () pn_block => slha_get_block_ptr & (parse_tree, var_str ("SMINPUTS"), required=.true.) if (.not. (associated (pn_block))) return alpha_em_i = & get_parameter_in_block (pn_block, 1, var_str ("alpha_em_i"), var_list) GF = get_parameter_in_block (pn_block, 2, var_str ("GF"), var_list) alphas = & get_parameter_in_block (pn_block, 3, var_str ("alphas"), var_list) mZ = get_parameter_in_block (pn_block, 4, var_str ("mZ"), var_list) mb = get_parameter_in_block (pn_block, 5, var_str ("mb"), var_list) mtop = get_parameter_in_block (pn_block, 6, var_str ("mtop"), var_list) mtau = get_parameter_in_block (pn_block, 7, var_str ("mtau"), var_list) ee = sqrt (4 * pi / alpha_em_i) vv = 1 / sqrt (sqrt (2._default) * GF) cw_sw = ee * vv / (2 * mZ) if (2*cw_sw <= 1) then cw2 = (1 + sqrt (1 - 4 * cw_sw**2)) / 2 mW = mZ * sqrt (cw2) call var_list%set_real (var_str ("GF"), GF, .true.) call var_list%set_real (var_str ("mZ"), mZ, .true.) call var_list%set_real (var_str ("mW"), mW, .true.) call var_list%set_real (var_str ("mtau"), mtau, .true.) call var_list%set_real (var_str ("mb"), mb, .true.) call var_list%set_real (var_str ("mtop"), mtop, .true.) call var_list%set_real (var_str ("alphas"), alphas, .true.) else call msg_fatal ("SLHA: Unphysical SM parameter values") return end if end subroutine slha_handle_SMINPUTS @ %def slha_handle_SMINPUTS @ Write a SMINPUTS block. <>= subroutine slha_write_SMINPUTS (u, model) integer, intent(in) :: u type(model_t), intent(in), target :: model type(var_list_t), pointer :: var_list var_list => model%get_var_list_ptr () call write_block_header (u, "SMINPUTS", "SM input parameters") call write_real_data_item (u, 1, var_str ("alpha_em_i"), var_list, & "Inverse electromagnetic coupling alpha (Z pole)") call write_real_data_item (u, 2, var_str ("GF"), var_list, & "Fermi constant") call write_real_data_item (u, 3, var_str ("alphas"), var_list, & "Strong coupling alpha_s (Z pole)") call write_real_data_item (u, 4, var_str ("mZ"), var_list, & "Z mass") call write_real_data_item (u, 5, var_str ("mb"), var_list, & "b running mass (at mb)") call write_real_data_item (u, 6, var_str ("mtop"), var_list, & "top mass") call write_real_data_item (u, 7, var_str ("mtau"), var_list, & "tau mass") end subroutine slha_write_SMINPUTS @ %def slha_write_SMINPUTS @ \subsubsection{MINPAR} The block of SUSY input parameters. They are accessible to WHIZARD, but they only get used when an external spectrum generator is invoked. The precise set of parameters depends on the type of SUSY breaking, which by itself is one of the parameters. <>= subroutine slha_handle_MINPAR (parse_tree, model, mssm_type) type(parse_tree_t), intent(in) :: parse_tree type(model_t), intent(inout), target :: model integer, intent(in) :: mssm_type type(var_list_t), pointer :: var_list type(parse_node_t), pointer :: pn_block var_list => model%get_var_list_ptr () call var_list%set_real & (var_str ("mtype"), real(mssm_type, default), is_known=.true.) pn_block => slha_get_block_ptr & (parse_tree, var_str ("MINPAR"), required=.true.) select case (mssm_type) case (MSSM_SUGRA) call set_data_item (pn_block, 1, var_str ("m_zero"), var_list) call set_data_item (pn_block, 2, var_str ("m_half"), var_list) call set_data_item (pn_block, 3, var_str ("tanb"), var_list) call set_data_item (pn_block, 4, var_str ("sgn_mu"), var_list) call set_data_item (pn_block, 5, var_str ("A0"), var_list) case (MSSM_GMSB) call set_data_item (pn_block, 1, var_str ("Lambda"), var_list) call set_data_item (pn_block, 2, var_str ("M_mes"), var_list) call set_data_item (pn_block, 3, var_str ("tanb"), var_list) call set_data_item (pn_block, 4, var_str ("sgn_mu"), var_list) call set_data_item (pn_block, 5, var_str ("N_5"), var_list) call set_data_item (pn_block, 6, var_str ("c_grav"), var_list) case (MSSM_AMSB) call set_data_item (pn_block, 1, var_str ("m_zero"), var_list) call set_data_item (pn_block, 2, var_str ("m_grav"), var_list) call set_data_item (pn_block, 3, var_str ("tanb"), var_list) call set_data_item (pn_block, 4, var_str ("sgn_mu"), var_list) case default call set_data_item (pn_block, 3, var_str ("tanb"), var_list) end select end subroutine slha_handle_MINPAR @ %def slha_handle_MINPAR @ Write a MINPAR block as appropriate for the current model type. <>= subroutine slha_write_MINPAR (u, model, mssm_type) integer, intent(in) :: u type(model_t), intent(in), target :: model integer, intent(in) :: mssm_type type(var_list_t), pointer :: var_list var_list => model%get_var_list_ptr () call write_block_header (u, "MINPAR", "Basic SUSY input parameters") select case (mssm_type) case (MSSM_SUGRA) call write_real_data_item (u, 1, var_str ("m_zero"), var_list, & "Common scalar mass") call write_real_data_item (u, 2, var_str ("m_half"), var_list, & "Common gaugino mass") call write_real_data_item (u, 3, var_str ("tanb"), var_list, & "tan(beta)") call write_integer_data_item (u, 4, & var_str ("sgn_mu"), var_list, & "Sign of mu") call write_real_data_item (u, 5, var_str ("A0"), var_list, & "Common trilinear coupling") case (MSSM_GMSB) call write_real_data_item (u, 1, var_str ("Lambda"), var_list, & "Soft-breaking scale") call write_real_data_item (u, 2, var_str ("M_mes"), var_list, & "Messenger scale") call write_real_data_item (u, 3, var_str ("tanb"), var_list, & "tan(beta)") call write_integer_data_item (u, 4, & var_str ("sgn_mu"), var_list, & "Sign of mu") call write_integer_data_item (u, 5, var_str ("N_5"), var_list, & "Messenger index") call write_real_data_item (u, 6, var_str ("c_grav"), var_list, & "Gravitino mass factor") case (MSSM_AMSB) call write_real_data_item (u, 1, var_str ("m_zero"), var_list, & "Common scalar mass") call write_real_data_item (u, 2, var_str ("m_grav"), var_list, & "Gravitino mass") call write_real_data_item (u, 3, var_str ("tanb"), var_list, & "tan(beta)") call write_integer_data_item (u, 4, & var_str ("sgn_mu"), var_list, & "Sign of mu") case default call write_real_data_item (u, 3, var_str ("tanb"), var_list, & "tan(beta)") end select end subroutine slha_write_MINPAR @ %def slha_write_MINPAR @ \subsubsection{Mass spectrum} Set masses. Since the particles are identified by PDG code, read the line and try to set the appropriate particle mass in the current model. At the end, update parameters, just in case the $W$ or $Z$ mass was included. <>= subroutine slha_handle_MASS (parse_tree, model) type(parse_tree_t), intent(in) :: parse_tree type(model_t), intent(inout), target :: model type(parse_node_t), pointer :: pn_block, pn_data, pn_line, pn_code type(parse_node_t), pointer :: pn_mass integer :: pdg real(default) :: mass pn_block => slha_get_block_ptr & (parse_tree, var_str ("MASS"), required=.true.) if (.not. (associated (pn_block))) return pn_data => parse_node_get_sub_ptr (pn_block, 4) do while (associated (pn_data)) pn_line => parse_node_get_sub_ptr (pn_data, 2) pn_code => parse_node_get_sub_ptr (pn_line) if (associated (pn_code)) then pdg = get_integer_parameter (pn_code) pn_mass => parse_node_get_next_ptr (pn_code) if (associated (pn_mass)) then mass = get_real_parameter (pn_mass) call model%set_field_mass (pdg, mass) else call msg_error ("SLHA: Block MASS: Missing mass value") end if else call msg_error ("SLHA: Block MASS: Missing PDG code") end if pn_data => parse_node_get_next_ptr (pn_data) end do end subroutine slha_handle_MASS @ %def slha_handle_MASS @ \subsubsection{Widths} Set widths. For each DECAY block, extract the header, read the PDG code and width, and try to set the appropriate particle width in the current model. <>= subroutine slha_handle_decays (parse_tree, model) type(parse_tree_t), intent(in) :: parse_tree type(model_t), intent(inout), target :: model type(parse_node_t), pointer :: pn_decay, pn_decay_spec, pn_code, pn_width integer :: pdg real(default) :: width pn_decay => slha_get_first_decay_ptr (parse_tree) do while (associated (pn_decay)) pn_decay_spec => parse_node_get_sub_ptr (pn_decay, 2) pn_code => parse_node_get_sub_ptr (pn_decay_spec) pdg = get_integer_parameter (pn_code) pn_width => parse_node_get_next_ptr (pn_code) width = get_real_parameter (pn_width) call model%set_field_width (pdg, width) pn_decay => slha_get_next_decay_ptr (pn_decay) end do end subroutine slha_handle_decays @ %def slha_handle_decays @ \subsubsection{Mixing matrices} Read mixing matrices. We can treat all matrices by a single procedure if we just know the block name, variable prefix, and matrix dimension. The matrix dimension must be less than 10. For the pseudoscalar Higgses in NMSSM-type models we need off-diagonal matrices, so we generalize the definition. <>= subroutine slha_handle_matrix_block & (parse_tree, block_name, var_prefix, dim1, dim2, model) type(parse_tree_t), intent(in) :: parse_tree character(*), intent(in) :: block_name, var_prefix integer, intent(in) :: dim1, dim2 type(model_t), intent(inout), target :: model type(parse_node_t), pointer :: pn_block type(var_list_t), pointer :: var_list integer :: i, j character(len=len(var_prefix)+2) :: var_name var_list => model%get_var_list_ptr () pn_block => slha_get_block_ptr & (parse_tree, var_str (block_name), required=.false.) if (.not. (associated (pn_block))) return do i = 1, dim1 do j = 1, dim2 write (var_name, "(A,I1,I1)") var_prefix, i, j call set_matrix_element (pn_block, i, j, var_str (var_name), var_list) end do end do end subroutine slha_handle_matrix_block @ %def slha_handle_matrix_block @ \subsubsection{Higgs data} Read the block ALPHA which holds just the Higgs mixing angle. <>= subroutine slha_handle_ALPHA (parse_tree, model) type(parse_tree_t), intent(in) :: parse_tree type(model_t), intent(inout), target :: model type(parse_node_t), pointer :: pn_block, pn_line, pn_data, pn_item type(var_list_t), pointer :: var_list real(default) :: al_h var_list => model%get_var_list_ptr () pn_block => slha_get_block_ptr & (parse_tree, var_str ("ALPHA"), required=.false.) if (.not. (associated (pn_block))) return pn_data => parse_node_get_sub_ptr (pn_block, 4) pn_line => parse_node_get_sub_ptr (pn_data, 2) pn_item => parse_node_get_sub_ptr (pn_line) if (associated (pn_item)) then al_h = get_real_parameter (pn_item) call var_list%set_real (var_str ("al_h"), al_h, & is_known=.true., ignore=.true.) end if end subroutine slha_handle_ALPHA @ %def slha_handle_matrix_block @ Read the block HMIX for the Higgs mixing parameters <>= subroutine slha_handle_HMIX (parse_tree, model) type(parse_tree_t), intent(in) :: parse_tree type(model_t), intent(inout), target :: model type(parse_node_t), pointer :: pn_block type(var_list_t), pointer :: var_list var_list => model%get_var_list_ptr () pn_block => slha_get_block_ptr & (parse_tree, var_str ("HMIX"), required=.false.) if (.not. (associated (pn_block))) return call set_data_item (pn_block, 1, var_str ("mu_h"), var_list) call set_data_item (pn_block, 2, var_str ("tanb_h"), var_list) end subroutine slha_handle_HMIX @ %def slha_handle_HMIX @ Read the block NMSSMRUN for the specific NMSSM parameters <>= subroutine slha_handle_NMSSMRUN (parse_tree, model) type(parse_tree_t), intent(in) :: parse_tree type(model_t), intent(inout), target :: model type(parse_node_t), pointer :: pn_block type(var_list_t), pointer :: var_list var_list => model%get_var_list_ptr () pn_block => slha_get_block_ptr & (parse_tree, var_str ("NMSSMRUN"), required=.false.) if (.not. (associated (pn_block))) return call set_data_item (pn_block, 1, var_str ("ls"), var_list) call set_data_item (pn_block, 2, var_str ("ks"), var_list) call set_data_item (pn_block, 3, var_str ("a_ls"), var_list) call set_data_item (pn_block, 4, var_str ("a_ks"), var_list) call set_data_item (pn_block, 5, var_str ("nmu"), var_list) end subroutine slha_handle_NMSSMRUN @ %def slha_handle_NMSSMRUN @ \subsection{Parsing custom SLHA files} With the introduction of UFO models, we support custom files in generic SLHA format that reset model parameters. In contrast to strict SLHA files, the order and naming of blocks is arbitrary. We scan the complete file (i.e., preprocessed parse tree), parsing all blocks that contain data lines. For each data line, we identify index array and associated value. Then we set the model parameter that is associated with that block name and index array, if it exists. <>= subroutine slha_handle_custom_file (parse_tree, model) type(parse_tree_t), intent(in) :: parse_tree type(model_t), intent(inout), target :: model type(parse_node_t), pointer :: pn_root, pn_block type(parse_node_t), pointer :: pn_block_spec, pn_block_name type(parse_node_t), pointer :: pn_data, pn_line, pn_code, pn_item type(string_t) :: block_name integer, dimension(:), allocatable :: block_index integer :: n_index, i real(default) :: value pn_root => parse_tree%get_root_ptr () pn_block => pn_root%get_sub_ptr () HANDLE_BLOCKS: do while (associated (pn_block)) select case (char (pn_block%get_rule_key ())) case ("block_def") call slha_handle_custom_block (pn_block, model) end select pn_block => pn_block%get_next_ptr () end do HANDLE_BLOCKS end subroutine slha_handle_custom_file @ %def slha_handle_custom_file @ <>= subroutine slha_handle_custom_block (pn_block, model) type(parse_node_t), intent(in), target :: pn_block type(model_t), intent(inout), target :: model type(parse_node_t), pointer :: pn_block_spec, pn_block_name type(parse_node_t), pointer :: pn_data, pn_line, pn_code, pn_item type(string_t) :: block_name integer, dimension(:), allocatable :: block_index integer :: n_index, i real(default) :: value pn_block_spec => parse_node_get_sub_ptr (pn_block, 2) pn_block_name => parse_node_get_sub_ptr (pn_block_spec) select case (char (parse_node_get_rule_key (pn_block_name))) case ("block_name") block_name = trim (adjustl (upper_case (pn_block_name%get_string ()))) case ("QNUMBERS") block_name = "QNUMBERS" end select call demangle_keywords (block_name) pn_data => pn_block%get_sub_ptr (4) HANDLE_LINES: do while (associated (pn_data)) select case (char (pn_data%get_rule_key ())) case ("block_data") pn_line => pn_data%get_sub_ptr (2) n_index = pn_line%get_n_sub () - 1 allocate (block_index (n_index)) pn_code => pn_line%get_sub_ptr () READ_LINE: do i = 1, n_index select case (char (pn_code%get_rule_key ())) case ("integer"); block_index(i) = pn_code%get_integer () case default pn_code => null () exit READ_LINE end select pn_code => pn_code%get_next_ptr () end do READ_LINE if (associated (pn_code)) then value = get_real_parameter (pn_code) call model%slha_set_par (block_name, block_index, value) end if deallocate (block_index) end select pn_data => pn_data%get_next_ptr () end do HANDLE_LINES end subroutine slha_handle_custom_block @ %def slha_handle_custom_block @ \subsection{Parser} Read a SLHA file from stream, including preprocessing, and make up a parse tree. <>= subroutine slha_parse_stream (stream, custom_block_name, parse_tree) type(stream_t), intent(inout), target :: stream type(string_t), dimension(:), intent(in) :: custom_block_name type(parse_tree_t), intent(out) :: parse_tree type(ifile_t) :: ifile type(lexer_t) :: lexer type(stream_t), target :: stream_tmp call slha_preprocess (stream, custom_block_name, ifile) call stream_init (stream_tmp, ifile) call lexer_init_slha (lexer) call lexer_assign_stream (lexer, stream_tmp) call parse_tree_init (parse_tree, syntax_slha, lexer) call lexer_final (lexer) call stream_final (stream_tmp) call ifile_final (ifile) end subroutine slha_parse_stream @ %def slha_parse_stream @ Read a SLHA file chosen by name. Check first the current directory, then the directory where SUSY input files should be located. The [[default_mode]] applies to unknown blocks in the SLHA file: this is either [[MODE_SKIP]] or [[MODE_DATA]], corresponding to genuine SUSY and custom file content, respectively. <>= public :: slha_parse_file <>= subroutine slha_parse_file (file, custom_block_name, os_data, parse_tree) type(string_t), intent(in) :: file type(string_t), dimension(:), intent(in) :: custom_block_name type(os_data_t), intent(in) :: os_data type(parse_tree_t), intent(out) :: parse_tree logical :: exist type(string_t) :: filename type(stream_t), target :: stream call msg_message ("Reading SLHA input file '" // char (file) // "'") filename = file inquire (file=char(filename), exist=exist) if (.not. exist) then filename = os_data%whizard_susypath // "/" // file inquire (file=char(filename), exist=exist) if (.not. exist) then call msg_fatal ("SLHA input file '" // char (file) // "' not found") return end if end if call stream_init (stream, char (filename)) call slha_parse_stream (stream, custom_block_name, parse_tree) call stream_final (stream) end subroutine slha_parse_file @ %def slha_parse_file @ \subsection{API} Read the SLHA file, parse it, and interpret the parse tree. The model parameters retrieved from the file will be inserted into the appropriate model, which is loaded and modified in the background. The pointer to this model is returned as the last argument. <>= public :: slha_read_file <>= subroutine slha_read_file & (file, os_data, model, input, spectrum, decays) type(string_t), intent(in) :: file type(os_data_t), intent(in) :: os_data type(model_t), intent(inout), target :: model logical, intent(in) :: input, spectrum, decays type(string_t), dimension(:), allocatable :: custom_block_name type(parse_tree_t) :: parse_tree call model%get_custom_slha_blocks (custom_block_name) call slha_parse_file (file, custom_block_name, os_data, parse_tree) if (associated (parse_tree%get_root_ptr ())) then call slha_interpret_parse_tree & (parse_tree, model, input, spectrum, decays) call parse_tree_final (parse_tree) call model%update_parameters () end if end subroutine slha_read_file @ %def slha_read_file @ Write the SLHA contents, as far as possible, to external file. <>= public :: slha_write_file <>= subroutine slha_write_file (file, model, input, spectrum, decays) type(string_t), intent(in) :: file type(model_t), target, intent(in) :: model logical, intent(in) :: input, spectrum, decays integer :: mssm_type integer :: u u = free_unit () call msg_message ("Writing SLHA output file '" // char (file) // "'") open (unit=u, file=char(file), action="write", status="replace") write (u, "(A)") "# SUSY Les Houches Accord" write (u, "(A)") "# Output generated by " // trim (VERSION_STRING) call slha_write_MODSEL (u, model, mssm_type) if (input) then call slha_write_SMINPUTS (u, model) call slha_write_MINPAR (u, model, mssm_type) end if if (spectrum) then call msg_bug ("SLHA: spectrum output not supported yet") end if if (decays) then call msg_bug ("SLHA: decays output not supported yet") end if close (u) end subroutine slha_write_file @ %def slha_write_file @ \subsection{Dispatch} <>= public :: dispatch_slha <>= subroutine dispatch_slha (var_list, input, spectrum, decays) type(var_list_t), intent(inout), target :: var_list logical, intent(out) :: input, spectrum, decays input = var_list%get_lval (var_str ("?slha_read_input")) spectrum = var_list%get_lval (var_str ("?slha_read_spectrum")) decays = var_list%get_lval (var_str ("?slha_read_decays")) end subroutine dispatch_slha @ %def dispatch_slha @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[slha_interface_ut.f90]]>>= <> module slha_interface_ut use unit_tests use slha_interface_uti <> <> contains <> end module slha_interface_ut @ %def slha_interface_ut @ <<[[slha_interface_uti.f90]]>>= <> module slha_interface_uti <> use io_units use os_interface use parser use model_data use variables use models use slha_interface <> <> contains <> end module slha_interface_uti @ %def slha_interface_ut @ API: driver for the unit tests below. <>= public :: slha_test <>= subroutine slha_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine slha_test @ %def slha_test @ Checking the basics of the SLHA interface. <>= call test (slha_1, "slha_1", & "check SLHA interface", & u, results) <>= public :: slha_1 <>= subroutine slha_1 (u) integer, intent(in) :: u type(os_data_t), pointer :: os_data => null () type(parse_tree_t), pointer :: parse_tree => null () integer :: u_file, iostat character(80) :: buffer character(*), parameter :: file_slha = "slha_test.dat" type(model_list_t) :: model_list type(model_t), pointer :: model => null () + type(var_list_t), pointer :: var_list type(string_t), dimension(0) :: empty_string_array write (u, "(A)") "* Test output: SLHA Interface" write (u, "(A)") "* Purpose: test SLHA file reading and writing" write (u, "(A)") write (u, "(A)") "* Initializing" write (u, "(A)") allocate (os_data) allocate (parse_tree) call os_data%init () call syntax_model_file_init () call model_list%read_model & (var_str("MSSM"), var_str("MSSM.mdl"), os_data, model) call syntax_slha_init () write (u, "(A)") "* Reading SLHA file sps1ap_decays.slha" write (u, "(A)") call slha_parse_file (var_str ("sps1ap_decays.slha"), & empty_string_array, os_data, parse_tree) write (u, "(A)") "* Writing the parse tree:" write (u, "(A)") call parse_tree_write (parse_tree, u) write (u, "(A)") "* Interpreting the parse tree" write (u, "(A)") call slha_interpret_parse_tree (parse_tree, model, & input=.true., spectrum=.true., decays=.true.) call parse_tree_final (parse_tree) write (u, "(A)") "* Writing out the list of variables (reals only):" write (u, "(A)") - call var_list_write (model%get_var_list_ptr (), & - only_type = V_REAL, unit = u) + var_list => model%get_var_list_ptr () + call var_list%write (only_type = V_REAL, unit = u) write (u, "(A)") write (u, "(A)") "* Writing SLHA output to '" // file_slha // "'" write (u, "(A)") call slha_write_file (var_str (file_slha), model, input=.true., & spectrum=.false., decays=.false.) u_file = free_unit () open (u_file, file = file_slha, action = "read", status = "old") do read (u_file, "(A)", iostat = iostat) buffer if (buffer(1:37) == "# Output generated by WHIZARD version") then buffer = "[...]" end if if (iostat /= 0) exit write (u, "(A)") trim (buffer) end do close (u_file) write (u, "(A)") write (u, "(A)") "* Cleanup" write (u, "(A)") call parse_tree_final (parse_tree) deallocate (parse_tree) deallocate (os_data) write (u, "(A)") "* Test output end: slha_1" write (u, "(A)") end subroutine slha_1 @ %def slha_1 @ \subsubsection{SLHA interface} This rather trivial sets all input values for the SLHA interface to [[false]]. <>= call test (slha_2, "slha_2", & "SLHA interface", & u, results) <>= public :: slha_2 <>= subroutine slha_2 (u) integer, intent(in) :: u type(var_list_t) :: var_list logical :: input, spectrum, decays write (u, "(A)") "* Test output: slha_2" write (u, "(A)") "* Purpose: SLHA interface settings" write (u, "(A)") write (u, "(A)") "* Default settings" write (u, "(A)") call var_list%init_defaults (0) call dispatch_slha (var_list, & input = input, spectrum = spectrum, decays = decays) write (u, "(A,1x,L1)") " slha_read_input =", input write (u, "(A,1x,L1)") " slha_read_spectrum =", spectrum write (u, "(A,1x,L1)") " slha_read_decays =", decays call var_list%final () call var_list%init_defaults (0) write (u, "(A)") write (u, "(A)") "* Set all entries to [false]" write (u, "(A)") call var_list%set_log (var_str ("?slha_read_input"), & .false., is_known = .true.) call var_list%set_log (var_str ("?slha_read_spectrum"), & .false., is_known = .true.) call var_list%set_log (var_str ("?slha_read_decays"), & .false., is_known = .true.) call dispatch_slha (var_list, & input = input, spectrum = spectrum, decays = decays) write (u, "(A,1x,L1)") " slha_read_input =", input write (u, "(A,1x,L1)") " slha_read_spectrum =", spectrum write (u, "(A,1x,L1)") " slha_read_decays =", decays call var_list%final () write (u, "(A)") write (u, "(A)") "* Test output end: slha_2" end subroutine slha_2 @ %def slha_2 Index: trunk/share/debug/Makefile_full =================================================================== --- trunk/share/debug/Makefile_full (revision 8782) +++ trunk/share/debug/Makefile_full (revision 8783) @@ -1,586 +1,587 @@ 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 \ 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 \ eio_data.f90 \ event_handles.f90 \ eio_base.f90 \ eio_base_uti.f90 \ eio_base_ut.f90 \ variables.f90 \ + variables_sub.f90 \ rng_base.f90 \ tao_random_numbers.f90 \ rng_tao.f90 \ rng_stream.f90 \ rng_base_uti.f90 \ rng_base_ut.f90 \ dispatch_rng.f90 \ dispatch_rng_uti.f90 \ dispatch_rng_ut.f90 \ beam_structures.f90 \ evaluators.f90 \ evaluators_sub.f90 \ beams.f90 \ sm_physics.f90 \ sm_physics_sub.f90 \ file_registries.f90 \ file_registries_sub.f90 \ sf_aux.f90 \ sf_mappings.f90 \ sf_base.f90 \ electron_pdfs.f90 \ sf_isr.f90 \ sf_epa.f90 \ sf_ewa.f90 \ sf_escan.f90 \ sf_gaussian.f90 \ sf_beam_events.f90 \ circe1.f90 \ sf_circe1.f90 \ circe2.f90 \ selectors.f90 \ sf_circe2.f90 \ sm_qcd.f90 \ sm_qcd_sub.f90 \ sm_qed.f90 \ sm_qed_sub.f90 \ mrst2004qed.f90 \ cteq6pdf.f90 \ mstwpdf.f90 \ ct10pdf.f90 \ CJpdf.f90 \ ct14pdf.f90 \ pdf_builtin.f90 \ pdf_builtin_sub.f90 \ LHAPDFWrap_dummy.f90 \ lhapdf5_full_dummy.f90 \ lhapdf5_has_photon_dummy.f90 \ lhapdf.f90 \ hoppet_dummy.f90 \ hoppet_interface.f90 \ sf_pdf_builtin.f90 \ sf_lhapdf.f90 \ dispatch_beams.f90 \ process_constants.f90 \ 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_test_core.f90 \ sm_qed.f90 \ prc_omega.f90 \ phs_base.f90 \ ifiles.f90 \ lexers.f90 \ syntax_rules.f90 \ parser.f90 \ expr_base.f90 \ formats.f90 \ formats_sub.f90 \ analysis.f90 \ user_code_interface.f90 \ observables.f90 \ eval_trees.f90 \ interpolation.f90 \ 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 \ permutations.f90 \ resonances.f90 \ phs_trees.f90 \ phs_forests.f90 \ prc_external.f90 \ blha_config.f90 \ blha_olp_interfaces.f90 \ prc_openloops.f90 \ prc_threshold.f90 \ process_config.f90 \ process_counter.f90 \ process_mci.f90 \ pcm_base.f90 \ nlo_data.f90 \ cascades.f90 \ cascades2_lexer.f90 \ cascades2_lexer_uti.f90 \ cascades2_lexer_ut.f90 \ cascades2.f90 \ cascades2_uti.f90 \ cascades2_ut.f90 \ phs_none.f90 \ phs_rambo.f90 \ phs_wood.f90 \ phs_fks.f90 \ phs_single.f90 \ fks_regions.f90 \ virtual.f90 \ pdf.f90 \ real_subtraction.f90 \ dglap_remnant.f90 \ dispatch_fks.f90 \ dispatch_phase_space.f90 \ pcm.f90 \ recola_wrapper_dummy.f90 \ prc_recola.f90 \ subevt_expr.f90 \ parton_states.f90 \ prc_template_me.f90 \ process.f90 \ process_stacks.f90 \ iterations.f90 \ rt_data.f90 \ file_utils.f90 \ file_utils_sub.f90 \ prc_gosam.f90 \ dispatch_me_methods.f90 \ sf_base_uti.f90 \ sf_base_ut.f90 \ dispatch_uti.f90 \ dispatch_ut.f90 \ formats_uti.f90 \ formats_ut.f90 \ md5_uti.f90 \ md5_ut.f90 \ os_interface_uti.f90 \ os_interface_ut.f90 \ sorting_uti.f90 \ sorting_ut.f90 \ grids.f90 \ grids_uti.f90 \ grids_ut.f90 \ solver.f90 \ solver_uti.f90 \ solver_ut.f90 \ cputime_uti.f90 \ cputime_ut.f90 \ sm_qcd_uti.f90 \ sm_qcd_ut.f90 \ sm_physics_uti.f90 \ sm_physics_ut.f90 \ lexers_uti.f90 \ lexers_ut.f90 \ parser_uti.f90 \ parser_ut.f90 \ xml.f90 \ xml_uti.f90 \ xml_ut.f90 \ colors_uti.f90 \ colors_ut.f90 \ state_matrices_uti.f90 \ state_matrices_ut.f90 \ analysis_uti.f90 \ analysis_ut.f90 \ particles_uti.f90 \ particles_ut.f90 \ radiation_generator.f90 \ radiation_generator_uti.f90 \ radiation_generator_ut.f90 \ blha_uti.f90 \ blha_ut.f90 \ evaluators_uti.f90 \ evaluators_ut.f90 \ models_uti.f90 \ models_ut.f90 \ eval_trees_uti.f90 \ eval_trees_ut.f90 \ resonances_uti.f90 \ resonances_ut.f90 \ phs_trees_uti.f90 \ phs_trees_ut.f90 \ phs_forests_uti.f90 \ phs_forests_ut.f90 \ beams_uti.f90 \ beams_ut.f90 \ su_algebra_uti.f90 \ su_algebra_ut.f90 \ bloch_vectors_uti.f90 \ bloch_vectors_ut.f90 \ polarizations_uti.f90 \ polarizations_ut.f90 \ sf_aux_uti.f90 \ sf_aux_ut.f90 \ sf_mappings_uti.f90 \ sf_mappings_ut.f90 \ sf_pdf_builtin_uti.f90 \ sf_pdf_builtin_ut.f90 \ sf_lhapdf_uti.f90 \ sf_lhapdf_ut.f90 \ sf_isr_uti.f90 \ sf_isr_ut.f90 \ sf_epa_uti.f90 \ sf_epa_ut.f90 \ sf_ewa_uti.f90 \ sf_ewa_ut.f90 \ sf_circe1_uti.f90 \ sf_circe1_ut.f90 \ sf_circe2_uti.f90 \ sf_circe2_ut.f90 \ sf_gaussian_uti.f90 \ sf_gaussian_ut.f90 \ sf_beam_events_uti.f90 \ sf_beam_events_ut.f90 \ sf_escan_uti.f90 \ sf_escan_ut.f90 \ phs_base_uti.f90 \ phs_base_ut.f90 \ phs_none_uti.f90 \ phs_none_ut.f90 \ phs_single_uti.f90 \ phs_single_ut.f90 \ phs_rambo_uti.f90 \ phs_rambo_ut.f90 \ phs_wood_uti.f90 \ phs_wood_ut.f90 \ phs_fks_uti.f90 \ phs_fks_ut.f90 \ fks_regions_uti.f90 \ fks_regions_ut.f90 \ mci_midpoint.f90 \ mci_base_uti.f90 \ mci_base_ut.f90 \ mci_midpoint_uti.f90 \ mci_midpoint_ut.f90 \ kinematics.f90 \ instances.f90 \ mci_none.f90 \ mci_none_uti.f90 \ mci_none_ut.f90 \ processes_uti.f90 \ processes_ut.f90 \ process_stacks_uti.f90 \ process_stacks_ut.f90 \ prc_recola_uti.f90 \ prc_recola_ut.f90 \ rng_tao_uti.f90 \ rng_tao_ut.f90 \ rng_stream_uti.f90 \ rng_stream_ut.f90 \ selectors_uti.f90 \ selectors_ut.f90 \ vegas.f90 \ vegas_uti.f90 \ vegas_ut.f90 \ vamp2.f90 \ vamp2_uti.f90 \ vamp2_ut.f90 \ exceptions.f90 \ vamp_stat.f90 \ utils.f90 \ divisions.f90 \ linalg.f90 \ vamp.f90 \ mci_vamp.f90 \ mci_vamp_uti.f90 \ mci_vamp_ut.f90 \ mci_vamp2.f90 \ mci_vamp2_uti.f90 \ mci_vamp2_ut.f90 \ prclib_interfaces_uti.f90 \ prclib_interfaces_ut.f90 \ particle_specifiers_uti.f90 \ particle_specifiers_ut.f90 \ process_libraries_uti.f90 \ process_libraries_ut.f90 \ prclib_stacks_uti.f90 \ prclib_stacks_ut.f90 \ slha_interface.f90 \ slha_interface_uti.f90 \ slha_interface_ut.f90 \ cascades_uti.f90 \ cascades_ut.f90 \ prc_test_uti.f90 \ prc_test_ut.f90 \ prc_template_me_uti.f90 \ prc_template_me_ut.f90 \ prc_omega_uti.f90 \ prc_omega_ut.f90 \ event_transforms.f90 \ event_transforms_uti.f90 \ event_transforms_ut.f90 \ hep_common.f90 \ hepev4_aux.f90 \ tauola_dummy.f90 \ tauola_interface.f90 \ shower_base.f90 \ shower_partons.f90 \ muli.f90 \ matching_base.f90 \ powheg_matching.f90 \ shower_core.f90 \ shower_base_uti.f90 \ shower_base_ut.f90 \ shower.f90 \ shower_uti.f90 \ shower_ut.f90 \ shower_pythia6.f90 \ whizard_lha.f90 \ whizard_lha_uti.f90 \ whizard_lha_ut.f90 \ LHAWhizard_dummy.f90 \ Pythia8Wrap_dummy.f90 \ pythia8.f90 \ pythia8_uti.f90 \ pythia8_ut.f90 \ shower_pythia8.f90 \ hadrons.f90 \ ktclus.f90 \ mlm_matching.f90 \ ckkw_matching.f90 \ jets_uti.f90 \ jets_ut.f90 \ pdg_arrays_uti.f90 \ pdg_arrays_ut.f90 \ interactions_uti.f90 \ interactions_ut.f90 \ decays.f90 \ decays_uti.f90 \ decays_ut.f90 \ evt_nlo.f90 \ events.f90 \ events_uti.f90 \ events_ut.f90 \ HepMCWrap_dummy.f90 \ hepmc_interface.f90 \ hepmc_interface_uti.f90 \ hepmc_interface_ut.f90 \ LCIOWrap_dummy.f90 \ lcio_interface.f90 \ lcio_interface_uti.f90 \ lcio_interface_ut.f90 \ hep_events.f90 \ hep_events_uti.f90 \ hep_events_ut.f90 \ expr_tests_uti.f90 \ expr_tests_ut.f90 \ parton_states_uti.f90 \ parton_states_ut.f90 \ eio_data_uti.f90 \ eio_data_ut.f90 \ eio_raw.f90 \ eio_raw_uti.f90 \ eio_raw_ut.f90 \ eio_checkpoints.f90 \ eio_checkpoints_uti.f90 \ eio_checkpoints_ut.f90 \ eio_lhef.f90 \ eio_lhef_uti.f90 \ eio_lhef_ut.f90 \ eio_hepmc.f90 \ eio_hepmc_uti.f90 \ eio_hepmc_ut.f90 \ eio_lcio.f90 \ eio_lcio_uti.f90 \ eio_lcio_ut.f90 \ stdhep_dummy.f90 \ xdr_wo_stdhep.f90 \ eio_stdhep.f90 \ eio_stdhep_uti.f90 \ eio_stdhep_ut.f90 \ eio_ascii.f90 \ eio_ascii_uti.f90 \ eio_ascii_ut.f90 \ eio_weights.f90 \ eio_weights_uti.f90 \ eio_weights_ut.f90 \ eio_dump.f90 \ eio_dump_uti.f90 \ eio_dump_ut.f90 \ eio_callback.f90 \ real_subtraction_uti.f90 \ real_subtraction_ut.f90 \ iterations_uti.f90 \ iterations_ut.f90 \ rt_data_uti.f90 \ rt_data_ut.f90 \ dispatch_mci.f90 \ dispatch_mci_uti.f90 \ dispatch_mci_ut.f90 \ dispatch_phs_uti.f90 \ dispatch_phs_ut.f90 \ resonance_insertion.f90 \ resonance_insertion_uti.f90 \ resonance_insertion_ut.f90 \ recoil_kinematics.f90 \ recoil_kinematics_uti.f90 \ recoil_kinematics_ut.f90 \ isr_epa_handler.f90 \ isr_epa_handler_uti.f90 \ isr_epa_handler_ut.f90 \ dispatch_transforms.f90 \ dispatch_transforms_uti.f90 \ dispatch_transforms_ut.f90 \ beam_structures_uti.f90 \ beam_structures_ut.f90 \ process_configurations.f90 \ process_configurations_uti.f90 \ process_configurations_ut.f90 \ compilations.f90 \ compilations_uti.f90 \ compilations_ut.f90 \ integrations.f90 \ integrations_uti.f90 \ integrations_ut.f90 \ event_streams.f90 \ event_streams_uti.f90 \ event_streams_ut.f90 \ restricted_subprocesses.f90 \ eio_direct.f90 \ eio_direct_uti.f90 \ eio_direct_ut.f90 \ simulations.f90 \ restricted_subprocesses_uti.f90 \ restricted_subprocesses_ut.f90 \ simulations_uti.f90 \ simulations_ut.f90 \ commands.f90 \ commands_uti.f90 \ commands_ut.f90 \ cmdline_options.f90 \ libmanager.f90 \ features.f90 \ whizard.f90 \ api.f90 \ api_hepmc_uti.f90 \ api_hepmc_ut.f90 \ api_lcio_uti.f90 \ api_lcio_ut.f90 \ api_uti.f90 \ api_ut.f90 FC_OBJ = $(FC0_SRC:.f90=.o) $(F77_SRC:.f=.o) $(FC_SRC:.f90=.o) CC_OBJ = $(CC_SRC:.c=.o) all: whizard_test check: whizard_test ./whizard_test --check resonances whizard_test: $(FC_OBJ) $(CC_OBJ) main_ut.f90 $(FC) $(FC_OBJ) $(CC_OBJ) -ldl -o $@ main_ut.f90 whizard: $(FC_OBJ) $(CC_OBJ) main.f90 $(FC) $(FC_OBJ) $(CC_OBJ) -ldl -o $@ main.f90 %.o: %.f90 $(FC) $(FCFLAGS) -c $< %.o: %.f $(FC) $(FCFLAGS) -c $< %.o: %.c $(CC) $(CCFLAGS) -c $< tar: $(FC_SRC) $(F77_SRC) $(FC0_SRC) $(CC_SRC) $(MODELS) tar cvvzf whizard-`date +%y%m%d`-`date +%H%M`.tar.gz $(FC_SRC) $(FC0_SRC) \ $(F77_SRC) $(CC_SRC) main_ut.f90 Makefile $(MODELS) clean: rm -f *.mod *.o whizard_test