Index: trunk/tests/functional_tests/Makefile.am =================================================================== --- trunk/tests/functional_tests/Makefile.am (revision 8224) +++ trunk/tests/functional_tests/Makefile.am (revision 8225) @@ -1,762 +1,763 @@ ## Makefile.am -- Makefile for executable WHIZARD test scripts ## ## Process this file with automake to produce Makefile.in ## ######################################################################## # # Copyright (C) 1999-2019 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. # ######################################################################## WHIZARD_DRIVER = run_whizard.sh TESTS_DEFAULT = \ empty.run \ fatal.run \ structure_1.run \ structure_2.run \ structure_3.run \ structure_4.run \ structure_5.run \ structure_6.run \ structure_7.run \ structure_8.run \ vars.run \ extpar.run \ testproc_1.run \ testproc_2.run \ testproc_3.run \ testproc_4.run \ testproc_5.run \ testproc_6.run \ testproc_7.run \ testproc_8.run \ testproc_9.run \ testproc_10.run \ testproc_11.run \ testproc_12.run \ template_me_1.run \ template_me_2.run \ model_scheme_1.run \ rebuild_1.run \ rebuild_4.run \ susyhit.run \ helicity.run \ libraries_4.run \ job_id_1.run \ pack_1.run XFAIL_TESTS_DEFAULT = TESTS_REQ_FASTJET = \ analyze_4.run TESTS_REQ_OCAML = \ libraries_1.run \ libraries_2.run \ libraries_3.run \ rebuild_2.run \ rebuild_3.run \ rebuild_5.run \ defaultcuts.run \ cuts.run \ model_change_1.run \ model_change_2.run \ model_change_3.run \ model_test.run \ job_id_2.run \ job_id_3.run \ job_id_4.run \ qedtest_1.run \ qedtest_2.run \ qedtest_3.run \ qedtest_4.run \ qedtest_5.run \ qedtest_6.run \ qedtest_7.run \ qedtest_8.run \ qedtest_9.run \ qedtest_10.run \ beam_setup_1.run \ beam_setup_2.run \ beam_setup_3.run \ beam_setup_4.run \ beam_setup_5.run \ qcdtest_1.run \ qcdtest_2.run \ qcdtest_3.run \ qcdtest_4.run \ qcdtest_5.run \ qcdtest_6.run \ observables_1.run \ observables_2.run \ event_weights_1.run \ event_weights_2.run \ event_eff_1.run \ event_eff_2.run \ event_dump_1.run \ event_dump_2.run \ reweight_1.run \ reweight_2.run \ reweight_3.run \ reweight_4.run \ reweight_5.run \ reweight_6.run \ reweight_7.run \ reweight_8.run \ analyze_1.run \ analyze_2.run \ analyze_5.run \ analyze_6.run \ colors.run \ colors_2.run \ colors_hgg.run \ alphas.run \ jets_xsec.run \ lhef_1.run \ lhef_2.run \ lhef_3.run \ lhef_4.run \ lhef_5.run \ lhef_6.run \ lhef_7.run \ lhef_8.run \ lhef_9.run \ lhef_10.run \ lhef_11.run \ stdhep_1.run \ stdhep_2.run \ stdhep_3.run \ stdhep_4.run \ stdhep_5.run \ stdhep_6.run \ select_1.run \ select_2.run \ fatal_beam_decay.run \ smtest_1.run \ smtest_2.run \ smtest_3.run \ smtest_4.run \ smtest_5.run \ smtest_6.run \ smtest_7.run \ smtest_8.run \ smtest_9.run \ smtest_10.run \ smtest_11.run \ smtest_12.run \ smtest_13.run \ smtest_14.run \ smtest_15.run \ smtest_16.run \ resonances_1.run \ resonances_2.run \ resonances_3.run \ resonances_4.run \ resonances_5.run \ resonances_6.run \ resonances_7.run \ resonances_8.run \ resonances_9.run \ resonances_10.run \ resonances_11.run \ resonances_12.run \ mssmtest_1.run \ mssmtest_2.run \ mssmtest_3.run \ sm_cms_1.run \ ufo_1.run \ ufo_2.run \ ufo_3.run \ nlo_1.run \ nlo_2.run \ nlo_3.run \ nlo_4.run \ nlo_5.run \ nlo_6.run \ nlo_decay_1.run \ real_partition_1.run \ fks_res_1.run \ fks_res_2.run \ fks_res_3.run \ openloops_1.run \ openloops_2.run \ openloops_3.run \ openloops_4.run \ openloops_5.run \ openloops_6.run \ openloops_7.run \ openloops_8.run \ openloops_9.run \ openloops_10.run \ + openloops_11.run \ recola_1.run \ recola_2.run \ recola_3.run \ recola_4.run \ recola_5.run \ recola_6.run \ recola_7.run \ recola_8.run \ powheg_1.run \ spincor_1.run \ show_1.run \ show_2.run \ show_3.run \ show_4.run \ show_5.run \ method_ovm_1.run \ multi_comp_1.run \ multi_comp_2.run \ multi_comp_3.run \ multi_comp_4.run \ flvsum_1.run \ br_redef_1.run \ decay_err_1.run \ decay_err_2.run \ decay_err_3.run \ polarized_1.run \ pdf_builtin.run \ ep_1.run \ ep_2.run \ ep_3.run \ circe1_1.run \ circe1_2.run \ circe1_3.run \ circe1_4.run \ circe1_5.run \ circe1_6.run \ circe1_7.run \ circe1_8.run \ circe1_9.run \ circe1_10.run \ circe1_photons_1.run \ circe1_photons_2.run \ circe1_photons_3.run \ circe1_photons_4.run \ circe1_photons_5.run \ circe1_errors_1.run \ circe2_1.run \ circe2_2.run \ circe2_3.run \ ewa_1.run \ ewa_2.run \ ewa_3.run \ ewa_4.run \ isr_1.run \ isr_2.run \ isr_3.run \ isr_4.run \ isr_5.run \ epa_1.run \ epa_2.run \ isr_epa_1.run \ ilc.run \ gaussian_1.run \ gaussian_2.run \ beam_events_1.run \ beam_events_2.run \ beam_events_3.run \ beam_events_4.run \ energy_scan_1.run \ restrictions.run \ process_log.run \ shower_err_1.run \ parton_shower_1.run \ parton_shower_2.run \ hadronize_1.run \ mlm_matching_fsr.run \ user_cuts.run \ user_prc_threshold_1.run \ cascades2_phs_1.run \ user_prc_threshold_2.run XFAIL_TESTS_REQ_OCAML = \ colors_hgg.run \ hadronize_1.run \ user_cuts.run TESTS_REQ_HEPMC = \ hepmc_1.run \ hepmc_2.run \ hepmc_3.run \ hepmc_4.run \ hepmc_5.run \ hepmc_6.run \ hepmc_7.run \ hepmc_8.run \ hepmc_9.run \ hepmc_10.run XFAIL_TESTS_REQ_HEPMC = TESTS_REQ_LCIO = \ lcio_1.run \ lcio_2.run \ lcio_3.run \ lcio_4.run \ lcio_5.run XFAIL_TESTS_REQ_LCIO = TESTS_REQ_LHAPDF5 = \ lhapdf5.run TESTS_REQ_LHAPDF6 = \ lhapdf6.run XFAIL_TESTS_REQ_LHAPDF5 = XFAIL_TESTS_REQ_LHAPDF6 = TESTS_STATIC = \ static_1.run \ static_2.run XFAIL_TESTS_STATIC = TESTS_REQ_PYTHIA6 = \ pythia6_1.run \ pythia6_2.run \ pythia6_3.run \ pythia6_4.run \ tauola_1.run \ tauola_2.run \ isr_5.run \ mlm_pythia6_isr.run \ mlm_matching_isr.run XFAIL_TESTS_REQ_PYTHIA6 = TESTS_REQ_PYTHIA8 = # pythia8_1.run \ # pythia8_2.run XFAIL_TESTS_REQ_PYTHIA8 = TESTS_REQ_EV_ANA = \ analyze_3.run XFAIL_TESTS_REQ_EV_ANA = TESTS_REQ_GAMELAN = \ analyze_3.run TEST_DRIVERS_RUN = \ $(TESTS_DEFAULT) \ $(TESTS_REQ_OCAML) \ $(TESTS_REQ_LHAPDF5) \ $(TESTS_REQ_LHAPDF6) \ $(TESTS_REQ_HEPMC) \ $(TESTS_REQ_LCIO) \ $(TESTS_REQ_FASTJET) \ $(TESTS_REQ_PYTHIA6) \ $(TESTS_REQ_EV_ANA) \ $(TESTS_STATIC) TEST_DRIVERS_SH = $(TEST_DRIVERS_RUN:.run=.sh) ######################################################################## TESTS = XFAIL_TESTS = TESTS_SRC = TESTS += $(TESTS_DEFAULT) XFAIL_TESTS += $(XFAIL_TESTS_DEFAULT) TESTS += $(TESTS_REQ_OCAML) XFAIL_TESTS += $(XFAIL_TESTS_REQ_OCAML) TESTS += $(TESTS_REQ_HEPMC) XFAIL_TESTS += $(XFAIL_TESTS_REQ_HEPMC) TESTS += $(TESTS_REQ_LCIO) XFAIL_TESTS += $(XFAIL_TESTS_REQ_LCIO) TESTS += $(TESTS_REQ_FASTJET) XFAIL_TESTS += $(XFAIL_TESTS_REQ_FASTJET) TESTS += $(TESTS_REQ_LHAPDF5) XFAIL_TESTS += $(XFAIL_TESTS_REQ_LHAPDF5) TESTS += $(TESTS_REQ_LHAPDF6) XFAIL_TESTS += $(XFAIL_TESTS_REQ_LHAPDF6) TESTS += $(TESTS_REQ_PYTHIA6) XFAIL_TESTS += $(XFAIL_TESTS_REQ_PYTHIA6) TESTS += $(TESTS_REQ_PYTHIA8) XFAIL_TESTS += $(XFAIL_TESTS_REQ_PYTHIA8) TESTS += $(TESTS_REQ_EV_ANA) XFAIL_TESTS += $(XFAIL_TESTS_REQ_EV_ANA) TESTS += $(TESTS_STATIC) XFAIL_TESTS += $(XFAIL_TESTS_STATIC) EXTRA_DIST = $(TEST_DRIVERS_SH) \ $(TESTS_SRC) ######################################################################## VPATH = $(srcdir) SUFFIXES = .sh .run .sh.run: @rm -f $@ @if test -f $(top_builddir)/share/tests/functional_tests/$*.sin; then \ $(SED) 's|@script@|$(top_builddir)/share/tests/functional_tests/$*|g' $< > $@; \ elif test -f $(top_srcdir)/share/tests/functional_tests/$*.sin; then \ $(SED) 's|@script@|$(top_srcdir)/share/tests/functional_tests/$*|g' $< > $@; \ else \ echo "$*.sin not found!" 1>&2; \ exit 2; \ fi @chmod +x $@ structure_2.run: structure_2_inc.sin structure_2_inc.sin: $(top_builddir)/share/tests/functional_tests/structure_2_inc.sin cp $< $@ testproc_3.run: testproc_3.phs testproc_3.phs: $(top_builddir)/share/tests/functional_tests/testproc_3.phs cp $< $@ static_1.run: static_1.exe.sin static_1.exe.sin: $(top_builddir)/share/tests/functional_tests/static_1.exe.sin cp $< $@ static_2.run: static_2.exe.sin static_2.exe.sin: $(top_builddir)/share/tests/functional_tests/static_2.exe.sin cp $< $@ susyhit.run: susyhit.in user_cuts.run: user_cuts.f90 user_cuts.f90: $(top_builddir)/share/tests/functional_tests/user_cuts.f90 cp $< $@ model_test.run: tdefs.$(FC_MODULE_EXT) tglue.$(FC_MODULE_EXT) \ threeshl.$(FC_MODULE_EXT) tscript.$(FC_MODULE_EXT) tdefs.mod: $(top_builddir)/src/models/threeshl_bundle/tdefs.$(FC_MODULE_EXT) cp $< $@ tglue.mod: $(top_builddir)/src/models/threeshl_bundle/tglue.$(FC_MODULE_EXT) cp $< $@ tscript.mod: $(top_builddir)/src/models/threeshl_bundle/tscript.$(FC_MODULE_EXT) cp $< $@ threeshl.mod: $(top_builddir)/src/models/threeshl_bundle/threeshl.$(FC_MODULE_EXT) cp $< $@ WT_OCAML_NATIVE_EXT=opt if OCAML_AVAILABLE OMEGA_QED = $(top_builddir)/omega/bin/omega_QED.$(WT_OCAML_NATIVE_EXT) OMEGA_QCD = $(top_builddir)/omega/bin/omega_QCD.$(WT_OCAML_NATIVE_EXT) OMEGA_MSSM = $(top_builddir)/omega/bin/omega_MSSM.$(WT_OCAML_NATIVE_EXT) omega_MSSM.$(WT_OMEGA_CACHE_SUFFIX): $(OMEGA_MSSM) $(OMEGA_MSSM) -initialize . UFO_TAG_FILE = __init__.py UFO_MODELPATH = ../models/UFO ufo_1.run: ufo_1_SM/$(UFO_TAG_FILE) ufo_2.run: ufo_2_SM/$(UFO_TAG_FILE) ufo_3.run: ufo_3_models/ufo_3_SM/$(UFO_TAG_FILE) ufo_1_SM/$(UFO_TAG_FILE): $(UFO_MODELPATH)/SM/$(UFO_TAG_FILE) mkdir -p ufo_1_SM cp $(UFO_MODELPATH)/SM/*.py ufo_1_SM ufo_2_SM/$(UFO_TAG_FILE): $(UFO_MODELPATH)/SM/$(UFO_TAG_FILE) mkdir -p ufo_2_SM cp $(UFO_MODELPATH)/SM/*.py ufo_2_SM ufo_3_models/ufo_3_SM/$(UFO_TAG_FILE): $(UFO_MODELPATH)/SM/$(UFO_TAG_FILE) mkdir -p ufo_3_models/ufo_3_SM cp $(UFO_MODELPATH)/SM/*.py ufo_3_models/ufo_3_SM $(UFO_MODELPATH)/SM/$(UFO_TAG_FILE): $(top_srcdir)/omega/tests/UFO/SM/$(UFO_TAG_FILE) $(MAKE) -C $(UFO_MODELPATH)/SM all endif OCAML_AVAILABLE if MPOST_AVAILABLE $(TESTS_REQ_GAMELAN): gamelan.sty gamelan.sty: $(top_builddir)/src/gamelan/gamelan.sty cp $< $@ $(top_builddir)/src/gamelan/gamelan.sty: $(MAKE) -C $(top_builddir)/src/gamelan gamelan.sty endif noinst_PROGRAMS = if OCAML_AVAILABLE noinst_PROGRAMS += resonances_1_count resonances_1_count_SOURCES = resonances_1_count.f90 resonances_1.run: resonances_1_count noinst_PROGRAMS += resonances_2_count resonances_2_count_SOURCES = resonances_2_count.f90 resonances_2.run: resonances_2_count noinst_PROGRAMS += resonances_3_count resonances_3_count_SOURCES = resonances_3_count.f90 resonances_3.run: resonances_3_count noinst_PROGRAMS += resonances_4_count resonances_4_count_SOURCES = resonances_4_count.f90 resonances_4.run: resonances_4_count noinst_PROGRAMS += resonances_9_count resonances_9_count_SOURCES = resonances_9_count.f90 resonances_9.run: resonances_9_count noinst_PROGRAMS += resonances_10_count resonances_10_count_SOURCES = resonances_10_count.f90 resonances_10.run: resonances_10_count noinst_PROGRAMS += resonances_11_count resonances_11_count_SOURCES = resonances_11_count.f90 resonances_11.run: resonances_11_count noinst_PROGRAMS += epa_2_count epa_2_count_SOURCES = epa_2_count.f90 epa_2.run: epa_2_count noinst_PROGRAMS += isr_epa_1_count isr_epa_1_count_SOURCES = isr_epa_1_count.f90 isr_epa_1.run: isr_epa_1_count noinst_PROGRAMS += analyze_6_check analyze_6_check_SOURCES = analyze_6_check.f90 analyze_6.run: analyze_6_check endif if HEPMC_AVAILABLE TESTS_SRC += $(hepmc_6_rd_SOURCES) noinst_PROGRAMS += hepmc_6_rd if HEPMC_IS_VERSION3 hepmc_6_rd_SOURCES = hepmc_6_v3_rd.cpp else hepmc_6_rd_SOURCES = hepmc_6_v2_rd.cpp endif hepmc_6_rd_CXXFLAGS = $(HEPMC_INCLUDES) $(AM_CXXFLAGS) hepmc_6_rd_LDADD = $(LDFLAGS_HEPMC) hepmc_6.run: hepmc_6_rd endif if LCIO_AVAILABLE TESTS_SRC += $(lcio_rd_SOURCES) noinst_PROGRAMS += lcio_rd lcio_rd_SOURCES = lcio_rd.cpp lcio_rd_CXXFLAGS = $(LCIO_INCLUDES) $(AM_CXXFLAGS) lcio_rd_LDADD = $(LDFLAGS_LCIO) lcio_1.run: lcio_rd lcio_2.run: lcio_rd lcio_3.run: lcio_rd lcio_4.run: lcio_rd lcio_5.run: lcio_rd endif stdhep_4.run: stdhep_rd stdhep_5.run: stdhep_rd stdhep_6.run: stdhep_rd polarized_1.run: stdhep_rd tauola_1.run: stdhep_rd tauola_2.run: stdhep_rd stdhep_rd: $(top_builddir)/src/xdr/stdhep_rd cp $< $@ susyhit.in: $(top_builddir)/share/tests/functional_tests/susyhit.in cp $< $@ BUILT_SOURCES = \ TESTFLAG \ HEPMC_FLAG \ LCIO_FLAG \ FASTJET_FLAG \ LHAPDF5_FLAG \ LHAPDF6_FLAG \ GAMELAN_FLAG \ MPI_FLAG \ EVENT_ANALYSIS_FLAG \ OCAML_FLAG \ PYTHIA6_FLAG \ PYTHIA8_FLAG \ OPENLOOPS_FLAG \ RECOLA_FLAG \ GZIP_FLAG \ STATIC_FLAG \ ref-output # If this file is found in the working directory, WHIZARD # will use the paths for the uninstalled version (source/build tree), # otherwise it uses the installed version TESTFLAG: touch $@ FASTJET_FLAG: if FASTJET_AVAILABLE touch $@ endif HEPMC_FLAG: if HEPMC_AVAILABLE touch $@ endif LCIO_FLAG: if LCIO_AVAILABLE touch $@ endif LHAPDF5_FLAG: if LHAPDF5_AVAILABLE touch $@ endif LHAPDF6_FLAG: if LHAPDF6_AVAILABLE touch $@ endif GAMELAN_FLAG: if MPOST_AVAILABLE touch $@ endif MPI_FLAG: if FC_USE_MPI touch $@ endif OCAML_FLAG: if OCAML_AVAILABLE touch $@ endif PYTHIA6_FLAG: if PYTHIA6_AVAILABLE touch $@ endif PYTHIA8_FLAG: if PYTHIA8_AVAILABLE touch $@ endif OPENLOOPS_FLAG: if OPENLOOPS_AVAILABLE touch $@ endif RECOLA_FLAG: if RECOLA_AVAILABLE touch $@ endif EVENT_ANALYSIS_FLAG: if EVENT_ANALYSIS_AVAILABLE touch $@ endif GZIP_FLAG: if GZIP_AVAILABLE touch $@ endif STATIC_FLAG: if STATIC_AVAILABLE touch $@ endif # The reference output files are in the source directory. Copy them here. if FC_QUAD ref-output: $(top_srcdir)/share/tests/functional_tests/ref-output mkdir -p ref-output for f in $ $name.log + echo "Contents of ${name}_p1.debug:" >> $name.log + cat ${name}_p1.debug >> $name.log + diff ref-output/$name.ref $name.log +else + echo "|=============================================================================|" + echo "No O'Mega or OpenLoops matrix elements available, test skipped" + exit 77 +fi Index: trunk/share/tests/Makefile.am =================================================================== --- trunk/share/tests/Makefile.am (revision 8224) +++ trunk/share/tests/Makefile.am (revision 8225) @@ -1,1383 +1,1385 @@ ## Makefile.am -- Makefile for WHIZARD tests ## ## Process this file with automake to produce Makefile.in ## ######################################################################## # # Copyright (C) 1999-2019 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. # ######################################################################## EXTRA_DIST = \ $(TESTSUITE_MACROS) $(TESTSUITES_M4) $(TESTSUITES_SIN) \ $(TESTSUITE_TOOLS) \ $(REF_OUTPUT_FILES) \ cascades2_lexer_1.fds \ cascades2_1.fds \ cascades2_2.fds \ functional_tests/structure_2_inc.sin functional_tests/testproc_3.phs \ functional_tests/user_cuts.f90 \ functional_tests/susyhit.in \ ext_tests_nmssm/nmssm.slha TESTSUITE_MACROS = testsuite.m4 TESTSUITE_TOOLS = \ check-debug-output.py \ check-debug-output-hadro.py \ check-hepmc-weights.py \ compare-integrals.py \ compare-integrals-multi.py \ compare-methods.py \ compare-histograms.py REF_OUTPUT_FILES = \ extra_integration_results.dat \ $(REF_OUTPUT_FILES_BASE) $(REF_OUTPUT_FILES_DOUBLE) \ $(REF_OUTPUT_FILES_PREC) $(REF_OUTPUT_FILES_EXT) \ $(REF_OUTPUT_FILES_QUAD) REF_OUTPUT_FILES_BASE = \ unit_tests/ref-output/analysis_1.ref \ unit_tests/ref-output/pdg_arrays_1.ref \ unit_tests/ref-output/pdg_arrays_2.ref \ unit_tests/ref-output/pdg_arrays_3.ref \ unit_tests/ref-output/pdg_arrays_4.ref \ unit_tests/ref-output/pdg_arrays_5.ref \ unit_tests/ref-output/expressions_1.ref \ unit_tests/ref-output/expressions_2.ref \ unit_tests/ref-output/expressions_3.ref \ unit_tests/ref-output/expressions_4.ref \ unit_tests/ref-output/su_algebra_1.ref \ unit_tests/ref-output/su_algebra_2.ref \ unit_tests/ref-output/su_algebra_3.ref \ unit_tests/ref-output/su_algebra_4.ref \ unit_tests/ref-output/bloch_vectors_1.ref \ unit_tests/ref-output/bloch_vectors_2.ref \ unit_tests/ref-output/bloch_vectors_3.ref \ unit_tests/ref-output/bloch_vectors_4.ref \ unit_tests/ref-output/bloch_vectors_5.ref \ unit_tests/ref-output/bloch_vectors_6.ref \ unit_tests/ref-output/bloch_vectors_7.ref \ unit_tests/ref-output/polarization_1.ref \ unit_tests/ref-output/polarization_2.ref \ unit_tests/ref-output/beam_1.ref \ unit_tests/ref-output/beam_2.ref \ unit_tests/ref-output/beam_3.ref \ unit_tests/ref-output/md5_1.ref \ unit_tests/ref-output/cputime_1.ref \ unit_tests/ref-output/cputime_2.ref \ unit_tests/ref-output/lexer_1.ref \ unit_tests/ref-output/parse_1.ref \ unit_tests/ref-output/color_1.ref \ unit_tests/ref-output/color_2.ref \ unit_tests/ref-output/os_interface_1.ref \ unit_tests/ref-output/evaluator_1.ref \ unit_tests/ref-output/evaluator_2.ref \ unit_tests/ref-output/evaluator_3.ref \ unit_tests/ref-output/evaluator_4.ref \ unit_tests/ref-output/format_1.ref \ unit_tests/ref-output/sorting_1.ref \ unit_tests/ref-output/grids_1.ref \ unit_tests/ref-output/grids_2.ref \ unit_tests/ref-output/grids_3.ref \ unit_tests/ref-output/grids_4.ref \ unit_tests/ref-output/grids_5.ref \ unit_tests/ref-output/solver_1.ref \ unit_tests/ref-output/state_matrix_1.ref \ unit_tests/ref-output/state_matrix_2.ref \ unit_tests/ref-output/state_matrix_3.ref \ unit_tests/ref-output/state_matrix_4.ref \ unit_tests/ref-output/state_matrix_5.ref \ unit_tests/ref-output/state_matrix_6.ref \ unit_tests/ref-output/state_matrix_7.ref \ unit_tests/ref-output/interaction_1.ref \ unit_tests/ref-output/xml_1.ref \ unit_tests/ref-output/xml_2.ref \ unit_tests/ref-output/xml_3.ref \ unit_tests/ref-output/xml_4.ref \ unit_tests/ref-output/sm_qcd_1.ref \ unit_tests/ref-output/sm_physics_1.ref \ unit_tests/ref-output/sm_physics_2.ref \ unit_tests/ref-output/models_1.ref \ unit_tests/ref-output/models_2.ref \ unit_tests/ref-output/models_3.ref \ unit_tests/ref-output/models_4.ref \ unit_tests/ref-output/models_5.ref \ unit_tests/ref-output/models_6.ref \ unit_tests/ref-output/models_7.ref \ unit_tests/ref-output/models_8.ref \ unit_tests/ref-output/models_9.ref \ unit_tests/ref-output/auto_components_1.ref \ unit_tests/ref-output/auto_components_2.ref \ unit_tests/ref-output/auto_components_3.ref \ unit_tests/ref-output/radiation_generator_1.ref \ unit_tests/ref-output/radiation_generator_2.ref \ unit_tests/ref-output/radiation_generator_3.ref \ unit_tests/ref-output/radiation_generator_4.ref \ unit_tests/ref-output/particles_1.ref \ unit_tests/ref-output/particles_2.ref \ unit_tests/ref-output/particles_3.ref \ unit_tests/ref-output/particles_4.ref \ unit_tests/ref-output/particles_5.ref \ unit_tests/ref-output/particles_6.ref \ unit_tests/ref-output/particles_7.ref \ unit_tests/ref-output/particles_8.ref \ unit_tests/ref-output/particles_9.ref \ unit_tests/ref-output/beam_structures_1.ref \ unit_tests/ref-output/beam_structures_2.ref \ unit_tests/ref-output/beam_structures_3.ref \ unit_tests/ref-output/beam_structures_4.ref \ unit_tests/ref-output/beam_structures_5.ref \ unit_tests/ref-output/beam_structures_6.ref \ unit_tests/ref-output/sf_aux_1.ref \ unit_tests/ref-output/sf_aux_2.ref \ unit_tests/ref-output/sf_aux_3.ref \ unit_tests/ref-output/sf_aux_4.ref \ unit_tests/ref-output/sf_mappings_1.ref \ unit_tests/ref-output/sf_mappings_2.ref \ unit_tests/ref-output/sf_mappings_3.ref \ unit_tests/ref-output/sf_mappings_4.ref \ unit_tests/ref-output/sf_mappings_5.ref \ unit_tests/ref-output/sf_mappings_6.ref \ unit_tests/ref-output/sf_mappings_7.ref \ unit_tests/ref-output/sf_mappings_8.ref \ unit_tests/ref-output/sf_mappings_9.ref \ unit_tests/ref-output/sf_mappings_10.ref \ unit_tests/ref-output/sf_mappings_11.ref \ unit_tests/ref-output/sf_mappings_12.ref \ unit_tests/ref-output/sf_mappings_13.ref \ unit_tests/ref-output/sf_mappings_14.ref \ unit_tests/ref-output/sf_mappings_15.ref \ unit_tests/ref-output/sf_mappings_16.ref \ unit_tests/ref-output/sf_base_1.ref \ unit_tests/ref-output/sf_base_2.ref \ unit_tests/ref-output/sf_base_3.ref \ unit_tests/ref-output/sf_base_4.ref \ unit_tests/ref-output/sf_base_5.ref \ unit_tests/ref-output/sf_base_6.ref \ unit_tests/ref-output/sf_base_7.ref \ unit_tests/ref-output/sf_base_8.ref \ unit_tests/ref-output/sf_base_9.ref \ unit_tests/ref-output/sf_base_10.ref \ unit_tests/ref-output/sf_base_11.ref \ unit_tests/ref-output/sf_base_12.ref \ unit_tests/ref-output/sf_base_13.ref \ unit_tests/ref-output/sf_base_14.ref \ unit_tests/ref-output/sf_pdf_builtin_1.ref \ unit_tests/ref-output/sf_pdf_builtin_2.ref \ unit_tests/ref-output/sf_pdf_builtin_3.ref \ unit_tests/ref-output/sf_lhapdf5_1.ref \ unit_tests/ref-output/sf_lhapdf5_2.ref \ unit_tests/ref-output/sf_lhapdf5_3.ref \ unit_tests/ref-output/sf_lhapdf6_1.ref \ unit_tests/ref-output/sf_lhapdf6_2.ref \ unit_tests/ref-output/sf_lhapdf6_3.ref \ unit_tests/ref-output/sf_isr_1.ref \ unit_tests/ref-output/sf_isr_2.ref \ unit_tests/ref-output/sf_isr_3.ref \ unit_tests/ref-output/sf_isr_4.ref \ unit_tests/ref-output/sf_isr_5.ref \ unit_tests/ref-output/sf_epa_1.ref \ unit_tests/ref-output/sf_epa_2.ref \ unit_tests/ref-output/sf_epa_3.ref \ unit_tests/ref-output/sf_epa_4.ref \ unit_tests/ref-output/sf_epa_5.ref \ unit_tests/ref-output/sf_ewa_1.ref \ unit_tests/ref-output/sf_ewa_2.ref \ unit_tests/ref-output/sf_ewa_3.ref \ unit_tests/ref-output/sf_ewa_4.ref \ unit_tests/ref-output/sf_ewa_5.ref \ unit_tests/ref-output/sf_circe1_1.ref \ unit_tests/ref-output/sf_circe1_2.ref \ unit_tests/ref-output/sf_circe1_3.ref \ unit_tests/ref-output/sf_circe2_1.ref \ unit_tests/ref-output/sf_circe2_2.ref \ unit_tests/ref-output/sf_circe2_3.ref \ unit_tests/ref-output/sf_gaussian_1.ref \ unit_tests/ref-output/sf_gaussian_2.ref \ unit_tests/ref-output/sf_beam_events_1.ref \ unit_tests/ref-output/sf_beam_events_2.ref \ unit_tests/ref-output/sf_beam_events_3.ref \ unit_tests/ref-output/sf_escan_1.ref \ unit_tests/ref-output/sf_escan_2.ref \ unit_tests/ref-output/phs_base_1.ref \ unit_tests/ref-output/phs_base_2.ref \ unit_tests/ref-output/phs_base_3.ref \ unit_tests/ref-output/phs_base_4.ref \ unit_tests/ref-output/phs_base_5.ref \ unit_tests/ref-output/phs_none_1.ref \ unit_tests/ref-output/phs_single_1.ref \ unit_tests/ref-output/phs_single_2.ref \ unit_tests/ref-output/phs_single_3.ref \ unit_tests/ref-output/phs_single_4.ref \ unit_tests/ref-output/phs_rambo_1.ref \ unit_tests/ref-output/phs_rambo_2.ref \ unit_tests/ref-output/phs_rambo_3.ref \ unit_tests/ref-output/phs_rambo_4.ref \ unit_tests/ref-output/resonances_1.ref \ unit_tests/ref-output/resonances_2.ref \ unit_tests/ref-output/resonances_3.ref \ unit_tests/ref-output/resonances_4.ref \ unit_tests/ref-output/resonances_5.ref \ unit_tests/ref-output/resonances_6.ref \ unit_tests/ref-output/resonances_7.ref \ unit_tests/ref-output/phs_tree_1.ref \ unit_tests/ref-output/phs_tree_2.ref \ unit_tests/ref-output/phs_forest_1.ref \ unit_tests/ref-output/phs_forest_2.ref \ unit_tests/ref-output/phs_wood_1.ref \ unit_tests/ref-output/phs_wood_2.ref \ unit_tests/ref-output/phs_wood_3.ref \ unit_tests/ref-output/phs_wood_4.ref \ unit_tests/ref-output/phs_wood_5.ref \ unit_tests/ref-output/phs_wood_6.ref \ unit_tests/ref-output/phs_wood_vis_1.ref \ unit_tests/ref-output/phs_fks_generator_1.ref \ unit_tests/ref-output/phs_fks_generator_2.ref \ unit_tests/ref-output/phs_fks_generator_3.ref \ unit_tests/ref-output/phs_fks_generator_4.ref \ unit_tests/ref-output/phs_fks_generator_5.ref \ unit_tests/ref-output/phs_fks_generator_6.ref \ unit_tests/ref-output/phs_fks_generator_7.ref \ unit_tests/ref-output/fks_regions_1.ref \ unit_tests/ref-output/fks_regions_2.ref \ unit_tests/ref-output/fks_regions_3.ref \ unit_tests/ref-output/fks_regions_4.ref \ unit_tests/ref-output/fks_regions_5.ref \ unit_tests/ref-output/fks_regions_6.ref \ unit_tests/ref-output/fks_regions_7.ref \ unit_tests/ref-output/fks_regions_8.ref \ unit_tests/ref-output/real_subtraction_1.ref \ unit_tests/ref-output/prc_recola_1.ref \ unit_tests/ref-output/prc_recola_2.ref \ unit_tests/ref-output/rng_base_1.ref \ unit_tests/ref-output/rng_base_2.ref \ unit_tests/ref-output/rng_tao_1.ref \ unit_tests/ref-output/rng_tao_2.ref \ unit_tests/ref-output/rng_stream_1.ref \ unit_tests/ref-output/rng_stream_2.ref \ unit_tests/ref-output/rng_stream_3.ref \ unit_tests/ref-output/selectors_1.ref \ unit_tests/ref-output/selectors_2.ref \ unit_tests/ref-output/vegas_1.ref \ unit_tests/ref-output/vegas_2.ref \ unit_tests/ref-output/vegas_3.ref \ unit_tests/ref-output/vegas_4.ref \ unit_tests/ref-output/vegas_5.ref \ unit_tests/ref-output/vegas_6.ref \ unit_tests/ref-output/vamp2_1.ref \ unit_tests/ref-output/vamp2_2.ref \ unit_tests/ref-output/vamp2_3.ref \ unit_tests/ref-output/vamp2_4.ref \ unit_tests/ref-output/vamp2_5.ref \ unit_tests/ref-output/mci_base_1.ref \ unit_tests/ref-output/mci_base_2.ref \ unit_tests/ref-output/mci_base_3.ref \ unit_tests/ref-output/mci_base_4.ref \ unit_tests/ref-output/mci_base_5.ref \ unit_tests/ref-output/mci_base_6.ref \ unit_tests/ref-output/mci_base_7.ref \ unit_tests/ref-output/mci_base_8.ref \ unit_tests/ref-output/mci_none_1.ref \ unit_tests/ref-output/mci_midpoint_1.ref \ unit_tests/ref-output/mci_midpoint_2.ref \ unit_tests/ref-output/mci_midpoint_3.ref \ unit_tests/ref-output/mci_midpoint_4.ref \ unit_tests/ref-output/mci_midpoint_5.ref \ unit_tests/ref-output/mci_midpoint_6.ref \ unit_tests/ref-output/mci_midpoint_7.ref \ unit_tests/ref-output/mci_vamp_1.ref \ unit_tests/ref-output/mci_vamp_2.ref \ unit_tests/ref-output/mci_vamp_3.ref \ unit_tests/ref-output/mci_vamp_4.ref \ unit_tests/ref-output/mci_vamp_5.ref \ unit_tests/ref-output/mci_vamp_6.ref \ unit_tests/ref-output/mci_vamp_7.ref \ unit_tests/ref-output/mci_vamp_8.ref \ unit_tests/ref-output/mci_vamp_9.ref \ unit_tests/ref-output/mci_vamp_10.ref \ unit_tests/ref-output/mci_vamp_11.ref \ unit_tests/ref-output/mci_vamp_12.ref \ unit_tests/ref-output/mci_vamp_13.ref \ unit_tests/ref-output/mci_vamp_14.ref \ unit_tests/ref-output/mci_vamp_15.ref \ unit_tests/ref-output/mci_vamp_16.ref \ unit_tests/ref-output/mci_vamp2_1.ref \ unit_tests/ref-output/mci_vamp2_2.ref \ unit_tests/ref-output/mci_vamp2_3.ref \ unit_tests/ref-output/integration_results_1.ref \ unit_tests/ref-output/integration_results_2.ref \ unit_tests/ref-output/integration_results_3.ref \ unit_tests/ref-output/integration_results_4.ref \ unit_tests/ref-output/integration_results_5.ref \ unit_tests/ref-output/prclib_interfaces_1.ref \ unit_tests/ref-output/prclib_interfaces_2.ref \ unit_tests/ref-output/prclib_interfaces_3.ref \ unit_tests/ref-output/prclib_interfaces_4.ref \ unit_tests/ref-output/prclib_interfaces_5.ref \ unit_tests/ref-output/prclib_interfaces_6.ref \ unit_tests/ref-output/prclib_interfaces_7.ref \ unit_tests/ref-output/particle_specifiers_1.ref \ unit_tests/ref-output/particle_specifiers_2.ref \ unit_tests/ref-output/process_libraries_1.ref \ unit_tests/ref-output/process_libraries_2.ref \ unit_tests/ref-output/process_libraries_3.ref \ unit_tests/ref-output/process_libraries_4.ref \ unit_tests/ref-output/process_libraries_5.ref \ unit_tests/ref-output/process_libraries_6.ref \ unit_tests/ref-output/process_libraries_7.ref \ unit_tests/ref-output/process_libraries_8.ref \ unit_tests/ref-output/prclib_stacks_1.ref \ unit_tests/ref-output/prclib_stacks_2.ref \ unit_tests/ref-output/slha_1.ref \ unit_tests/ref-output/slha_2.ref \ unit_tests/ref-output/prc_test_1.ref \ unit_tests/ref-output/prc_test_2.ref \ unit_tests/ref-output/prc_test_3.ref \ unit_tests/ref-output/prc_test_4.ref \ unit_tests/ref-output/prc_template_me_1.ref \ unit_tests/ref-output/prc_template_me_2.ref \ unit_tests/ref-output/prc_omega_1.ref \ unit_tests/ref-output/prc_omega_2.ref \ unit_tests/ref-output/prc_omega_3.ref \ unit_tests/ref-output/prc_omega_4.ref \ unit_tests/ref-output/prc_omega_5.ref \ unit_tests/ref-output/prc_omega_6.ref \ unit_tests/ref-output/prc_omega_diags_1.ref \ unit_tests/ref-output/parton_states_1.ref \ unit_tests/ref-output/subevt_expr_1.ref \ unit_tests/ref-output/subevt_expr_2.ref \ unit_tests/ref-output/processes_1.ref \ unit_tests/ref-output/processes_2.ref \ unit_tests/ref-output/processes_3.ref \ unit_tests/ref-output/processes_4.ref \ unit_tests/ref-output/processes_5.ref \ unit_tests/ref-output/processes_6.ref \ unit_tests/ref-output/processes_7.ref \ unit_tests/ref-output/processes_8.ref \ unit_tests/ref-output/processes_9.ref \ unit_tests/ref-output/processes_10.ref \ unit_tests/ref-output/processes_11.ref \ unit_tests/ref-output/processes_12.ref \ unit_tests/ref-output/processes_13.ref \ unit_tests/ref-output/processes_14.ref \ unit_tests/ref-output/processes_15.ref \ unit_tests/ref-output/processes_16.ref \ unit_tests/ref-output/processes_17.ref \ unit_tests/ref-output/processes_18.ref \ unit_tests/ref-output/processes_19.ref \ unit_tests/ref-output/process_stacks_1.ref \ unit_tests/ref-output/process_stacks_2.ref \ unit_tests/ref-output/process_stacks_3.ref \ unit_tests/ref-output/process_stacks_4.ref \ unit_tests/ref-output/cascades_1.ref \ unit_tests/ref-output/cascades_2.ref \ unit_tests/ref-output/cascades2_lexer_1.ref \ unit_tests/ref-output/cascades2_1.ref \ unit_tests/ref-output/cascades2_2.ref \ unit_tests/ref-output/event_transforms_1.ref \ unit_tests/ref-output/recoil_kinematics_1.ref \ unit_tests/ref-output/recoil_kinematics_2.ref \ unit_tests/ref-output/recoil_kinematics_3.ref \ unit_tests/ref-output/recoil_kinematics_4.ref \ unit_tests/ref-output/recoil_kinematics_5.ref \ unit_tests/ref-output/resonance_insertion_1.ref \ unit_tests/ref-output/resonance_insertion_2.ref \ unit_tests/ref-output/resonance_insertion_3.ref \ unit_tests/ref-output/resonance_insertion_4.ref \ unit_tests/ref-output/resonance_insertion_5.ref \ unit_tests/ref-output/resonance_insertion_6.ref \ unit_tests/ref-output/isr_handler_1.ref \ unit_tests/ref-output/isr_handler_2.ref \ unit_tests/ref-output/isr_handler_3.ref \ unit_tests/ref-output/epa_handler_1.ref \ unit_tests/ref-output/epa_handler_2.ref \ unit_tests/ref-output/epa_handler_3.ref \ unit_tests/ref-output/decays_1.ref \ unit_tests/ref-output/decays_2.ref \ unit_tests/ref-output/decays_3.ref \ unit_tests/ref-output/decays_4.ref \ unit_tests/ref-output/decays_5.ref \ unit_tests/ref-output/decays_6.ref \ unit_tests/ref-output/shower_1.ref \ unit_tests/ref-output/shower_2.ref \ unit_tests/ref-output/shower_base_1.ref \ unit_tests/ref-output/events_1.ref \ unit_tests/ref-output/events_2.ref \ unit_tests/ref-output/events_3.ref \ unit_tests/ref-output/events_4.ref \ unit_tests/ref-output/events_5.ref \ unit_tests/ref-output/events_6.ref \ unit_tests/ref-output/events_7.ref \ unit_tests/ref-output/hep_events_1.ref \ unit_tests/ref-output/eio_data_1.ref \ unit_tests/ref-output/eio_data_2.ref \ unit_tests/ref-output/eio_base_1.ref \ unit_tests/ref-output/eio_direct_1.ref \ unit_tests/ref-output/eio_raw_1.ref \ unit_tests/ref-output/eio_raw_2.ref \ unit_tests/ref-output/eio_checkpoints_1.ref \ unit_tests/ref-output/eio_lhef_1.ref \ unit_tests/ref-output/eio_lhef_2.ref \ unit_tests/ref-output/eio_lhef_3.ref \ unit_tests/ref-output/eio_lhef_4.ref \ unit_tests/ref-output/eio_lhef_5.ref \ unit_tests/ref-output/eio_lhef_6.ref \ unit_tests/ref-output/eio_stdhep_1.ref \ unit_tests/ref-output/eio_stdhep_2.ref \ unit_tests/ref-output/eio_stdhep_3.ref \ unit_tests/ref-output/eio_stdhep_4.ref \ unit_tests/ref-output/eio_hepmc_1.ref \ unit_tests/ref-output/eio_hepmc_2.ref \ unit_tests/ref-output/eio_lcio_1.ref \ unit_tests/ref-output/eio_lcio_2.ref \ unit_tests/ref-output/eio_ascii_1.ref \ unit_tests/ref-output/eio_ascii_2.ref \ unit_tests/ref-output/eio_ascii_3.ref \ unit_tests/ref-output/eio_ascii_4.ref \ unit_tests/ref-output/eio_ascii_5.ref \ unit_tests/ref-output/eio_ascii_6.ref \ unit_tests/ref-output/eio_ascii_7.ref \ unit_tests/ref-output/eio_ascii_8.ref \ unit_tests/ref-output/eio_ascii_9.ref \ unit_tests/ref-output/eio_ascii_10.ref \ unit_tests/ref-output/eio_weights_1.ref \ unit_tests/ref-output/eio_weights_2.ref \ unit_tests/ref-output/eio_weights_3.ref \ unit_tests/ref-output/eio_dump_1.ref \ unit_tests/ref-output/iterations_1.ref \ unit_tests/ref-output/iterations_2.ref \ unit_tests/ref-output/rt_data_1.ref \ unit_tests/ref-output/rt_data_2.ref \ unit_tests/ref-output/rt_data_3.ref \ unit_tests/ref-output/rt_data_4.ref \ unit_tests/ref-output/rt_data_5.ref \ unit_tests/ref-output/rt_data_6.ref \ unit_tests/ref-output/rt_data_7.ref \ unit_tests/ref-output/rt_data_8.ref \ unit_tests/ref-output/rt_data_9.ref \ unit_tests/ref-output/rt_data_10.ref \ unit_tests/ref-output/rt_data_11.ref \ unit_tests/ref-output/dispatch_1.ref \ unit_tests/ref-output/dispatch_2.ref \ unit_tests/ref-output/dispatch_7.ref \ unit_tests/ref-output/dispatch_8.ref \ unit_tests/ref-output/dispatch_10.ref \ unit_tests/ref-output/dispatch_11.ref \ unit_tests/ref-output/dispatch_rng_1.ref \ unit_tests/ref-output/dispatch_phs_1.ref \ unit_tests/ref-output/dispatch_phs_2.ref \ unit_tests/ref-output/dispatch_mci_1.ref \ unit_tests/ref-output/dispatch_transforms_1.ref \ unit_tests/ref-output/dispatch_transforms_2.ref \ unit_tests/ref-output/process_configurations_1.ref \ unit_tests/ref-output/process_configurations_2.ref \ unit_tests/ref-output/event_streams_1.ref \ unit_tests/ref-output/event_streams_2.ref \ unit_tests/ref-output/event_streams_3.ref \ unit_tests/ref-output/event_streams_4.ref \ unit_tests/ref-output/compilations_1.ref \ unit_tests/ref-output/compilations_2.ref \ unit_tests/ref-output/compilations_3.ref \ unit_tests/ref-output/compilations_static_1.ref \ unit_tests/ref-output/compilations_static_2.ref \ unit_tests/ref-output/integrations_1.ref \ unit_tests/ref-output/integrations_2.ref \ unit_tests/ref-output/integrations_3.ref \ unit_tests/ref-output/integrations_4.ref \ unit_tests/ref-output/integrations_5.ref \ unit_tests/ref-output/integrations_6.ref \ unit_tests/ref-output/integrations_7.ref \ unit_tests/ref-output/integrations_8.ref \ unit_tests/ref-output/integrations_9.ref \ unit_tests/ref-output/integrations_history_1.ref \ unit_tests/ref-output/restricted_subprocesses_1.ref \ unit_tests/ref-output/restricted_subprocesses_2.ref \ unit_tests/ref-output/restricted_subprocesses_3.ref \ unit_tests/ref-output/restricted_subprocesses_4.ref \ unit_tests/ref-output/restricted_subprocesses_5.ref \ unit_tests/ref-output/restricted_subprocesses_6.ref \ unit_tests/ref-output/simulations_1.ref \ unit_tests/ref-output/simulations_2.ref \ unit_tests/ref-output/simulations_3.ref \ unit_tests/ref-output/simulations_4.ref \ unit_tests/ref-output/simulations_5.ref \ unit_tests/ref-output/simulations_6.ref \ unit_tests/ref-output/simulations_7.ref \ unit_tests/ref-output/simulations_8.ref \ unit_tests/ref-output/simulations_9.ref \ unit_tests/ref-output/simulations_10.ref \ unit_tests/ref-output/simulations_11.ref \ unit_tests/ref-output/simulations_12.ref \ unit_tests/ref-output/simulations_13.ref \ unit_tests/ref-output/simulations_14.ref \ unit_tests/ref-output/simulations_15.ref \ unit_tests/ref-output/commands_1.ref \ unit_tests/ref-output/commands_2.ref \ unit_tests/ref-output/commands_3.ref \ unit_tests/ref-output/commands_4.ref \ unit_tests/ref-output/commands_5.ref \ unit_tests/ref-output/commands_6.ref \ unit_tests/ref-output/commands_7.ref \ unit_tests/ref-output/commands_8.ref \ unit_tests/ref-output/commands_9.ref \ unit_tests/ref-output/commands_10.ref \ unit_tests/ref-output/commands_11.ref \ unit_tests/ref-output/commands_12.ref \ unit_tests/ref-output/commands_13.ref \ unit_tests/ref-output/commands_14.ref \ unit_tests/ref-output/commands_15.ref \ unit_tests/ref-output/commands_16.ref \ unit_tests/ref-output/commands_17.ref \ unit_tests/ref-output/commands_18.ref \ unit_tests/ref-output/commands_19.ref \ unit_tests/ref-output/commands_20.ref \ unit_tests/ref-output/commands_21.ref \ unit_tests/ref-output/commands_22.ref \ unit_tests/ref-output/commands_23.ref \ unit_tests/ref-output/commands_24.ref \ unit_tests/ref-output/commands_25.ref \ unit_tests/ref-output/commands_26.ref \ unit_tests/ref-output/commands_27.ref \ unit_tests/ref-output/commands_28.ref \ unit_tests/ref-output/commands_29.ref \ unit_tests/ref-output/commands_30.ref \ unit_tests/ref-output/commands_31.ref \ unit_tests/ref-output/commands_32.ref \ unit_tests/ref-output/commands_33.ref \ unit_tests/ref-output/commands_34.ref \ unit_tests/ref-output/jets_1.ref \ unit_tests/ref-output/hepmc_interface_1.ref \ unit_tests/ref-output/lcio_interface_1.ref \ unit_tests/ref-output/ttv_formfactors_1.ref \ unit_tests/ref-output/ttv_formfactors_2.ref \ unit_tests/ref-output/blha_1.ref \ unit_tests/ref-output/blha_2.ref \ unit_tests/ref-output/blha_3.ref \ unit_tests/ref-output/whizard_lha_1.ref \ functional_tests/ref-output/pack_1.ref \ functional_tests/ref-output/structure_1.ref \ functional_tests/ref-output/structure_2.ref \ functional_tests/ref-output/structure_3.ref \ functional_tests/ref-output/structure_4.ref \ functional_tests/ref-output/structure_5.ref \ functional_tests/ref-output/structure_6.ref \ functional_tests/ref-output/structure_7.ref \ functional_tests/ref-output/structure_8.ref \ functional_tests/ref-output/vars.ref \ functional_tests/ref-output/extpar.ref \ functional_tests/ref-output/testproc_1.ref \ functional_tests/ref-output/testproc_2.ref \ functional_tests/ref-output/testproc_3.ref \ functional_tests/ref-output/testproc_4.ref \ functional_tests/ref-output/testproc_5.ref \ functional_tests/ref-output/testproc_6.ref \ functional_tests/ref-output/testproc_7.ref \ functional_tests/ref-output/testproc_8.ref \ functional_tests/ref-output/testproc_9.ref \ functional_tests/ref-output/testproc_10.ref \ functional_tests/ref-output/testproc_11.ref \ functional_tests/ref-output/testproc_12.ref \ functional_tests/ref-output/template_me_1.ref \ functional_tests/ref-output/template_me_2.ref \ functional_tests/ref-output/susyhit.ref \ functional_tests/ref-output/restrictions.ref \ functional_tests/ref-output/process_log.ref \ functional_tests/ref-output/static_1.ref \ functional_tests/ref-output/static_2.ref \ functional_tests/ref-output/libraries_1.ref \ functional_tests/ref-output/libraries_2.ref \ functional_tests/ref-output/libraries_4.ref \ functional_tests/ref-output/job_id_1.ref \ functional_tests/ref-output/job_id_2.ref \ functional_tests/ref-output/job_id_3.ref \ functional_tests/ref-output/job_id_4.ref \ functional_tests/ref-output/rebuild_2.ref \ functional_tests/ref-output/rebuild_3.ref \ functional_tests/ref-output/rebuild_4.ref \ functional_tests/ref-output/fatal.ref \ functional_tests/ref-output/model_change_1.ref \ functional_tests/ref-output/model_change_2.ref \ functional_tests/ref-output/model_change_3.ref \ functional_tests/ref-output/model_scheme_1.ref \ functional_tests/ref-output/model_test.ref \ functional_tests/ref-output/cuts.ref \ functional_tests/ref-output/user_cuts.ref \ functional_tests/ref-output/user_prc_threshold_1.ref \ functional_tests/ref-output/user_prc_threshold_2.ref \ functional_tests/ref-output/qedtest_1.ref \ functional_tests/ref-output/qedtest_2.ref \ functional_tests/ref-output/qedtest_5.ref \ functional_tests/ref-output/qedtest_6.ref \ functional_tests/ref-output/qedtest_7.ref \ functional_tests/ref-output/qedtest_8.ref \ functional_tests/ref-output/qedtest_9.ref \ functional_tests/ref-output/qedtest_10.ref \ functional_tests/ref-output/qcdtest_4.ref \ functional_tests/ref-output/qcdtest_5.ref \ functional_tests/ref-output/qcdtest_6.ref \ functional_tests/ref-output/beam_setup_1.ref \ functional_tests/ref-output/beam_setup_2.ref \ functional_tests/ref-output/beam_setup_3.ref \ functional_tests/ref-output/beam_setup_4.ref \ functional_tests/ref-output/observables_1.ref \ functional_tests/ref-output/event_weights_1.ref \ functional_tests/ref-output/event_weights_2.ref \ functional_tests/ref-output/event_eff_1.ref \ functional_tests/ref-output/event_eff_2.ref \ functional_tests/ref-output/event_dump_1.ref \ functional_tests/ref-output/event_dump_2.ref \ functional_tests/ref-output/reweight_1.ref \ functional_tests/ref-output/reweight_2.ref \ functional_tests/ref-output/reweight_3.ref \ functional_tests/ref-output/reweight_4.ref \ functional_tests/ref-output/reweight_5.ref \ functional_tests/ref-output/reweight_6.ref \ functional_tests/ref-output/reweight_7.ref \ functional_tests/ref-output/reweight_8.ref \ functional_tests/ref-output/analyze_1.ref \ functional_tests/ref-output/analyze_2.ref \ functional_tests/ref-output/analyze_3.ref \ functional_tests/ref-output/analyze_4.ref \ functional_tests/ref-output/analyze_5.ref \ functional_tests/ref-output/analyze_6.ref \ functional_tests/ref-output/colors.ref \ functional_tests/ref-output/colors_hgg.ref \ functional_tests/ref-output/alphas.ref \ functional_tests/ref-output/jets_xsec.ref \ functional_tests/ref-output/shower_err_1.ref \ functional_tests/ref-output/parton_shower_1.ref \ functional_tests/ref-output/pythia6_1.ref \ functional_tests/ref-output/pythia6_2.ref \ functional_tests/ref-output/hadronize_1.ref \ functional_tests/ref-output/mlm_matching_fsr.ref \ functional_tests/ref-output/mlm_pythia6_isr.ref \ functional_tests/ref-output/hepmc_1.ref \ functional_tests/ref-output/hepmc_2.ref \ functional_tests/ref-output/hepmc_3.ref \ functional_tests/ref-output/hepmc_4.ref \ functional_tests/ref-output/hepmc_5.ref \ functional_tests/ref-output/hepmc_6.ref \ functional_tests/ref-output/hepmc_7.ref \ functional_tests/ref-output/hepmc_9.ref \ functional_tests/ref-output/hepmc_10.ref \ functional_tests/ref-output/lhef_1.ref \ functional_tests/ref-output/lhef_2.ref \ functional_tests/ref-output/lhef_3.ref \ functional_tests/ref-output/lhef_4.ref \ functional_tests/ref-output/lhef_5.ref \ functional_tests/ref-output/lhef_6.ref \ functional_tests/ref-output/lhef_9.ref \ functional_tests/ref-output/lhef_10.ref \ functional_tests/ref-output/lhef_11.ref \ functional_tests/ref-output/select_1.ref \ functional_tests/ref-output/select_2.ref \ functional_tests/ref-output/stdhep_1.ref \ functional_tests/ref-output/stdhep_2.ref \ functional_tests/ref-output/stdhep_3.ref \ functional_tests/ref-output/stdhep_4.ref \ functional_tests/ref-output/stdhep_5.ref \ functional_tests/ref-output/stdhep_6.ref \ functional_tests/ref-output/lcio_1.ref \ functional_tests/ref-output/lcio_3.ref \ functional_tests/ref-output/lcio_4.ref \ functional_tests/ref-output/lcio_5.ref \ functional_tests/ref-output/fatal_beam_decay.ref \ functional_tests/ref-output/smtest_1.ref \ functional_tests/ref-output/smtest_3.ref \ functional_tests/ref-output/smtest_4.ref \ functional_tests/ref-output/smtest_5.ref \ functional_tests/ref-output/smtest_6.ref \ functional_tests/ref-output/smtest_7.ref \ functional_tests/ref-output/smtest_9.ref \ functional_tests/ref-output/smtest_10.ref \ functional_tests/ref-output/smtest_11.ref \ functional_tests/ref-output/smtest_12.ref \ functional_tests/ref-output/smtest_13.ref \ functional_tests/ref-output/smtest_14.ref \ functional_tests/ref-output/smtest_15.ref \ functional_tests/ref-output/smtest_16.ref \ functional_tests/ref-output/sm_cms_1.ref \ functional_tests/ref-output/resonances_5.ref \ functional_tests/ref-output/resonances_6.ref \ functional_tests/ref-output/resonances_7.ref \ functional_tests/ref-output/resonances_8.ref \ functional_tests/ref-output/resonances_9.ref \ functional_tests/ref-output/resonances_12.ref \ functional_tests/ref-output/ufo_1.ref \ functional_tests/ref-output/ufo_2.ref \ functional_tests/ref-output/ufo_3.ref \ functional_tests/ref-output/nlo_1.ref \ functional_tests/ref-output/nlo_2.ref \ functional_tests/ref-output/nlo_6.ref \ functional_tests/ref-output/real_partition_1.ref \ functional_tests/ref-output/fks_res_2.ref \ functional_tests/ref-output/openloops_1.ref \ functional_tests/ref-output/openloops_2.ref \ functional_tests/ref-output/openloops_4.ref \ functional_tests/ref-output/openloops_5.ref \ functional_tests/ref-output/openloops_6.ref \ functional_tests/ref-output/openloops_7.ref \ functional_tests/ref-output/openloops_8.ref \ functional_tests/ref-output/openloops_9.ref \ functional_tests/ref-output/openloops_10.ref \ + functional_tests/ref-output/openloops_11.ref \ functional_tests/ref-output/recola_1.ref \ functional_tests/ref-output/recola_2.ref \ functional_tests/ref-output/recola_3.ref \ functional_tests/ref-output/recola_4.ref \ functional_tests/ref-output/recola_5.ref \ functional_tests/ref-output/recola_6.ref \ functional_tests/ref-output/recola_7.ref \ functional_tests/ref-output/recola_8.ref \ functional_tests/ref-output/nlo_decay_1.ref \ functional_tests/ref-output/mssmtest_1.ref \ functional_tests/ref-output/mssmtest_2.ref \ functional_tests/ref-output/mssmtest_3.ref \ functional_tests/ref-output/spincor_1.ref \ functional_tests/ref-output/show_1.ref \ functional_tests/ref-output/show_2.ref \ functional_tests/ref-output/show_3.ref \ functional_tests/ref-output/show_4.ref \ functional_tests/ref-output/show_5.ref \ functional_tests/ref-output/method_ovm_1.ref \ functional_tests/ref-output/multi_comp_4.ref \ functional_tests/ref-output/flvsum_1.ref \ functional_tests/ref-output/br_redef_1.ref \ functional_tests/ref-output/decay_err_1.ref \ functional_tests/ref-output/decay_err_2.ref \ functional_tests/ref-output/decay_err_3.ref \ functional_tests/ref-output/polarized_1.ref \ functional_tests/ref-output/circe1_1.ref \ functional_tests/ref-output/circe1_2.ref \ functional_tests/ref-output/circe1_3.ref \ functional_tests/ref-output/circe1_6.ref \ functional_tests/ref-output/circe1_10.ref \ functional_tests/ref-output/circe1_errors_1.ref \ functional_tests/ref-output/circe2_1.ref \ functional_tests/ref-output/circe2_2.ref \ functional_tests/ref-output/circe2_3.ref \ functional_tests/ref-output/isr_1.ref \ functional_tests/ref-output/epa_1.ref \ functional_tests/ref-output/epa_2.ref \ functional_tests/ref-output/isr_epa_1.ref \ functional_tests/ref-output/ep_3.ref \ functional_tests/ref-output/ewa_4.ref \ functional_tests/ref-output/gaussian_1.ref \ functional_tests/ref-output/gaussian_2.ref \ functional_tests/ref-output/beam_events_1.ref \ functional_tests/ref-output/beam_events_4.ref \ functional_tests/ref-output/energy_scan_1.ref \ functional_tests/ref-output/cascades2_phs_1.ref # Reference files that depend on the numerical precision REF_OUTPUT_FILES_DOUBLE = \ functional_tests/ref-output-double/qedtest_3.ref \ functional_tests/ref-output-double/qedtest_4.ref \ functional_tests/ref-output-double/qcdtest_1.ref \ functional_tests/ref-output-double/qcdtest_2.ref \ functional_tests/ref-output-double/qcdtest_3.ref \ functional_tests/ref-output-double/smtest_2.ref \ functional_tests/ref-output-double/smtest_8.ref \ functional_tests/ref-output-double/observables_2.ref \ functional_tests/ref-output-double/colors_2.ref \ functional_tests/ref-output-double/resonances_1.ref \ functional_tests/ref-output-double/resonances_2.ref \ functional_tests/ref-output-double/resonances_3.ref \ functional_tests/ref-output-double/resonances_4.ref \ functional_tests/ref-output-double/resonances_10.ref \ functional_tests/ref-output-double/resonances_11.ref \ functional_tests/ref-output-double/beam_setup_5.ref \ functional_tests/ref-output-double/nlo_3.ref \ functional_tests/ref-output-double/nlo_4.ref \ functional_tests/ref-output-double/nlo_5.ref \ functional_tests/ref-output-double/fks_res_1.ref \ functional_tests/ref-output-double/fks_res_3.ref \ functional_tests/ref-output-double/openloops_3.ref \ functional_tests/ref-output-double/powheg_1.ref \ functional_tests/ref-output-double/defaultcuts.ref \ functional_tests/ref-output-double/parton_shower_2.ref \ functional_tests/ref-output-double/helicity.ref \ functional_tests/ref-output-double/lhef_7.ref \ functional_tests/ref-output-double/hepmc_8.ref \ functional_tests/ref-output-double/lcio_2.ref \ functional_tests/ref-output-double/multi_comp_1.ref \ functional_tests/ref-output-double/multi_comp_2.ref \ functional_tests/ref-output-double/multi_comp_3.ref \ functional_tests/ref-output-double/pdf_builtin.ref \ functional_tests/ref-output-double/lhapdf5.ref \ functional_tests/ref-output-double/lhapdf6.ref \ functional_tests/ref-output-double/ep_1.ref \ functional_tests/ref-output-double/ep_2.ref \ functional_tests/ref-output-double/circe1_4.ref \ functional_tests/ref-output-double/circe1_5.ref \ functional_tests/ref-output-double/circe1_7.ref \ functional_tests/ref-output-double/circe1_8.ref \ functional_tests/ref-output-double/circe1_9.ref \ functional_tests/ref-output-double/circe1_photons_1.ref \ functional_tests/ref-output-double/circe1_photons_2.ref \ functional_tests/ref-output-double/circe1_photons_3.ref \ functional_tests/ref-output-double/circe1_photons_4.ref \ functional_tests/ref-output-double/circe1_photons_5.ref \ functional_tests/ref-output-double/isr_2.ref \ functional_tests/ref-output-double/isr_3.ref \ functional_tests/ref-output-double/isr_4.ref \ functional_tests/ref-output-double/isr_5.ref \ functional_tests/ref-output-double/pythia6_3.ref \ functional_tests/ref-output-double/pythia6_4.ref \ functional_tests/ref-output-double/tauola_1.ref \ functional_tests/ref-output-double/tauola_2.ref \ functional_tests/ref-output-double/mlm_matching_isr.ref \ functional_tests/ref-output-double/ewa_1.ref \ functional_tests/ref-output-double/ewa_2.ref \ functional_tests/ref-output-double/ewa_3.ref \ functional_tests/ref-output-double/ilc.ref \ functional_tests/ref-output-double/beam_events_2.ref \ functional_tests/ref-output-double/beam_events_3.ref REF_OUTPUT_FILES_PREC = \ functional_tests/ref-output-prec/qedtest_3.ref \ functional_tests/ref-output-prec/qedtest_4.ref \ functional_tests/ref-output-prec/qcdtest_1.ref \ functional_tests/ref-output-prec/qcdtest_2.ref \ functional_tests/ref-output-prec/qcdtest_3.ref \ functional_tests/ref-output-prec/smtest_2.ref \ functional_tests/ref-output-prec/smtest_8.ref \ functional_tests/ref-output-prec/colors_2.ref \ functional_tests/ref-output-prec/beam_setup_5.ref \ functional_tests/ref-output-prec/nlo_3.ref \ functional_tests/ref-output-prec/nlo_4.ref \ functional_tests/ref-output-prec/fks_res_1.ref \ functional_tests/ref-output-prec/fks_res_3.ref \ functional_tests/ref-output-prec/openloops_3.ref \ functional_tests/ref-output-prec/defaultcuts.ref \ functional_tests/ref-output-prec/parton_shower_2.ref \ functional_tests/ref-output-prec/helicity.ref \ functional_tests/ref-output-prec/lhef_7.ref \ functional_tests/ref-output-prec/multi_comp_1.ref \ functional_tests/ref-output-prec/multi_comp_2.ref \ functional_tests/ref-output-prec/multi_comp_3.ref \ functional_tests/ref-output-prec/pdf_builtin.ref \ functional_tests/ref-output-prec/lhapdf5.ref \ functional_tests/ref-output-prec/lhapdf6.ref \ functional_tests/ref-output-prec/ep_1.ref \ functional_tests/ref-output-prec/ep_2.ref \ functional_tests/ref-output-prec/ilc.ref \ functional_tests/ref-output-prec/circe1_9.ref \ functional_tests/ref-output-prec/circe1_photons_1.ref \ functional_tests/ref-output-prec/circe1_photons_2.ref \ functional_tests/ref-output-prec/circe1_photons_3.ref \ functional_tests/ref-output-prec/circe1_photons_4.ref \ functional_tests/ref-output-prec/circe1_photons_5.ref \ functional_tests/ref-output-prec/ewa_1.ref REF_OUTPUT_FILES_EXT = \ functional_tests/ref-output-ext/observables_2.ref \ functional_tests/ref-output-ext/resonances_1.ref \ functional_tests/ref-output-ext/resonances_2.ref \ functional_tests/ref-output-ext/resonances_3.ref \ functional_tests/ref-output-ext/resonances_4.ref \ functional_tests/ref-output-ext/resonances_10.ref \ functional_tests/ref-output-ext/resonances_11.ref \ functional_tests/ref-output-ext/circe1_4.ref \ functional_tests/ref-output-ext/circe1_5.ref \ functional_tests/ref-output-ext/circe1_7.ref \ functional_tests/ref-output-ext/circe1_8.ref \ functional_tests/ref-output-ext/isr_2.ref \ functional_tests/ref-output-ext/isr_3.ref \ functional_tests/ref-output-ext/isr_4.ref \ functional_tests/ref-output-ext/isr_5.ref \ functional_tests/ref-output-ext/nlo_5.ref \ functional_tests/ref-output-ext/powheg_1.ref \ functional_tests/ref-output-ext/pythia6_3.ref \ functional_tests/ref-output-ext/pythia6_4.ref \ functional_tests/ref-output-ext/tauola_1.ref \ functional_tests/ref-output-ext/tauola_2.ref \ functional_tests/ref-output-ext/ewa_2.ref \ functional_tests/ref-output-ext/ewa_3.ref \ functional_tests/ref-output-ext/beam_events_2.ref \ functional_tests/ref-output-ext/beam_events_3.ref \ functional_tests/ref-output-ext/mlm_matching_isr.ref \ functional_tests/ref-output-ext/hepmc_8.ref \ functional_tests/ref-output-ext/lcio_2.ref REF_OUTPUT_FILES_QUAD = \ functional_tests/ref-output-quad/observables_2.ref \ functional_tests/ref-output-quad/resonances_1.ref \ functional_tests/ref-output-quad/resonances_2.ref \ functional_tests/ref-output-quad/resonances_3.ref \ functional_tests/ref-output-quad/resonances_4.ref \ functional_tests/ref-output-quad/resonances_10.ref \ functional_tests/ref-output-quad/resonances_11.ref \ functional_tests/ref-output-quad/circe1_4.ref \ functional_tests/ref-output-quad/circe1_5.ref \ functional_tests/ref-output-quad/circe1_7.ref \ functional_tests/ref-output-quad/circe1_8.ref \ functional_tests/ref-output-quad/isr_2.ref \ functional_tests/ref-output-quad/isr_3.ref \ functional_tests/ref-output-quad/isr_4.ref \ functional_tests/ref-output-quad/isr_5.ref \ functional_tests/ref-output-quad/nlo_5.ref \ functional_tests/ref-output-quad/powheg_1.ref \ functional_tests/ref-output-quad/pythia6_3.ref \ functional_tests/ref-output-quad/pythia6_4.ref \ functional_tests/ref-output-quad/tauola_1.ref \ functional_tests/ref-output-quad/tauola_2.ref \ functional_tests/ref-output-quad/ewa_2.ref \ functional_tests/ref-output-quad/ewa_3.ref \ functional_tests/ref-output-quad/beam_events_2.ref \ functional_tests/ref-output-quad/beam_events_3.ref \ functional_tests/ref-output-quad/mlm_matching_isr.ref \ functional_tests/ref-output-quad/hepmc_8.ref \ functional_tests/ref-output-quad/lcio_2.ref TESTSUITES_M4 = \ $(MISC_TESTS_M4) \ $(EXT_MSSM_M4) \ $(EXT_NMSSM_M4) TESTSUITES_SIN = \ $(MISC_TESTS_SIN) \ $(EXT_ILC_SIN) \ $(EXT_MSSM_SIN) \ $(EXT_NMSSM_SIN) \ $(EXT_SHOWER_SIN) \ $(EXT_NLO_SIN) MISC_TESTS_M4 = MISC_TESTS_SIN = \ functional_tests/empty.sin \ functional_tests/fatal.sin \ functional_tests/pack_1.sin \ functional_tests/defaultcuts.sin \ functional_tests/cuts.sin \ functional_tests/model_change_1.sin \ functional_tests/model_change_2.sin \ functional_tests/model_change_3.sin \ functional_tests/model_scheme_1.sin \ functional_tests/model_test.sin \ functional_tests/structure_1.sin \ functional_tests/structure_2.sin \ functional_tests/structure_3.sin \ functional_tests/structure_4.sin \ functional_tests/structure_5.sin \ functional_tests/structure_6.sin \ functional_tests/structure_7.sin \ functional_tests/structure_8.sin \ functional_tests/vars.sin \ functional_tests/extpar.sin \ functional_tests/testproc_1.sin \ functional_tests/testproc_2.sin \ functional_tests/testproc_3.sin \ functional_tests/testproc_4.sin \ functional_tests/testproc_5.sin \ functional_tests/testproc_6.sin \ functional_tests/testproc_7.sin \ functional_tests/testproc_8.sin \ functional_tests/testproc_9.sin \ functional_tests/testproc_10.sin \ functional_tests/testproc_11.sin \ functional_tests/testproc_12.sin \ functional_tests/template_me_1.sin \ functional_tests/template_me_2.sin \ functional_tests/libraries_1.sin \ functional_tests/libraries_2.sin \ functional_tests/libraries_3.sin \ functional_tests/libraries_4.sin \ functional_tests/job_id_1.sin \ functional_tests/job_id_2.sin \ functional_tests/job_id_3.sin \ functional_tests/job_id_4.sin \ functional_tests/rebuild_1.sin \ functional_tests/rebuild_2.sin \ functional_tests/rebuild_3.sin \ functional_tests/rebuild_4.sin \ functional_tests/rebuild_5.sin \ functional_tests/qedtest_1.sin \ functional_tests/qedtest_2.sin \ functional_tests/qedtest_3.sin \ functional_tests/qedtest_4.sin \ functional_tests/qedtest_5.sin \ functional_tests/qedtest_6.sin \ functional_tests/qedtest_7.sin \ functional_tests/qedtest_8.sin \ functional_tests/qedtest_9.sin \ functional_tests/qedtest_10.sin \ functional_tests/beam_setup_1.sin \ functional_tests/beam_setup_2.sin \ functional_tests/beam_setup_3.sin \ functional_tests/beam_setup_4.sin \ functional_tests/beam_setup_5.sin \ functional_tests/qcdtest_1.sin \ functional_tests/qcdtest_2.sin \ functional_tests/qcdtest_3.sin \ functional_tests/qcdtest_4.sin \ functional_tests/qcdtest_5.sin \ functional_tests/qcdtest_6.sin \ functional_tests/observables_1.sin \ functional_tests/observables_2.sin \ functional_tests/event_weights_1.sin \ functional_tests/event_weights_2.sin \ functional_tests/event_eff_1.sin \ functional_tests/event_eff_2.sin \ functional_tests/event_dump_1.sin \ functional_tests/event_dump_2.sin \ functional_tests/reweight_1.sin \ functional_tests/reweight_2.sin \ functional_tests/reweight_3.sin \ functional_tests/reweight_4.sin \ functional_tests/reweight_5.sin \ functional_tests/reweight_6.sin \ functional_tests/reweight_7.sin \ functional_tests/reweight_8.sin \ functional_tests/analyze_1.sin \ functional_tests/analyze_2.sin \ functional_tests/analyze_3.sin \ functional_tests/analyze_4.sin \ functional_tests/analyze_5.sin \ functional_tests/analyze_6.sin \ functional_tests/colors.sin \ functional_tests/colors_2.sin \ functional_tests/colors_hgg.sin \ functional_tests/alphas.sin \ functional_tests/jets_xsec.sin \ functional_tests/lhef_1.sin \ functional_tests/lhef_2.sin \ functional_tests/lhef_3.sin \ functional_tests/lhef_4.sin \ functional_tests/lhef_5.sin \ functional_tests/lhef_6.sin \ functional_tests/lhef_7.sin \ functional_tests/lhef_8.sin \ functional_tests/lhef_9.sin \ functional_tests/lhef_10.sin \ functional_tests/lhef_11.sin \ functional_tests/select_1.sin \ functional_tests/select_2.sin \ functional_tests/shower_err_1.sin \ functional_tests/parton_shower_1.sin \ functional_tests/parton_shower_2.sin \ functional_tests/pythia6_1.sin \ functional_tests/pythia6_2.sin \ functional_tests/pythia6_3.sin \ functional_tests/pythia6_4.sin \ functional_tests/pythia8_1.sin \ functional_tests/pythia8_2.sin \ functional_tests/hadronize_1.sin \ functional_tests/tauola_1.sin \ functional_tests/tauola_2.sin \ functional_tests/mlm_matching_fsr.sin \ functional_tests/mlm_matching_isr.sin \ functional_tests/mlm_pythia6_isr.sin \ functional_tests/hepmc_1.sin \ functional_tests/hepmc_2.sin \ functional_tests/hepmc_3.sin \ functional_tests/hepmc_4.sin \ functional_tests/hepmc_5.sin \ functional_tests/hepmc_6.sin \ functional_tests/hepmc_7.sin \ functional_tests/hepmc_8.sin \ functional_tests/hepmc_9.sin \ functional_tests/hepmc_10.sin \ functional_tests/stdhep_1.sin \ functional_tests/stdhep_2.sin \ functional_tests/stdhep_3.sin \ functional_tests/stdhep_4.sin \ functional_tests/stdhep_5.sin \ functional_tests/stdhep_6.sin \ functional_tests/lcio_1.sin \ functional_tests/lcio_2.sin \ functional_tests/lcio_3.sin \ functional_tests/lcio_4.sin \ functional_tests/lcio_5.sin \ functional_tests/fatal_beam_decay.sin \ functional_tests/smtest_1.sin \ functional_tests/smtest_2.sin \ functional_tests/smtest_3.sin \ functional_tests/smtest_4.sin \ functional_tests/smtest_5.sin \ functional_tests/smtest_6.sin \ functional_tests/smtest_7.sin \ functional_tests/smtest_8.sin \ functional_tests/smtest_9.sin \ functional_tests/smtest_10.sin \ functional_tests/smtest_11.sin \ functional_tests/smtest_12.sin \ functional_tests/smtest_13.sin \ functional_tests/smtest_14.sin \ functional_tests/smtest_15.sin \ functional_tests/smtest_16.sin \ functional_tests/resonances_1.sin \ functional_tests/resonances_2.sin \ functional_tests/resonances_3.sin \ functional_tests/resonances_4.sin \ functional_tests/resonances_5.sin \ functional_tests/resonances_6.sin \ functional_tests/resonances_7.sin \ functional_tests/resonances_8.sin \ functional_tests/resonances_9.sin \ functional_tests/resonances_10.sin \ functional_tests/resonances_11.sin \ functional_tests/resonances_12.sin \ functional_tests/sm_cms_1.sin \ functional_tests/ufo_1.sin \ functional_tests/ufo_2.sin \ functional_tests/ufo_3.sin \ functional_tests/nlo_1.sin \ functional_tests/nlo_2.sin \ functional_tests/nlo_3.sin \ functional_tests/nlo_4.sin \ functional_tests/nlo_5.sin \ functional_tests/nlo_6.sin \ functional_tests/nlo_decay_1.sin \ functional_tests/real_partition_1.sin \ functional_tests/fks_res_1.sin \ functional_tests/fks_res_2.sin \ functional_tests/fks_res_3.sin \ functional_tests/openloops_1.sin \ functional_tests/openloops_2.sin \ functional_tests/openloops_3.sin \ functional_tests/openloops_4.sin \ functional_tests/openloops_5.sin \ functional_tests/openloops_6.sin \ functional_tests/openloops_7.sin \ functional_tests/openloops_8.sin \ functional_tests/openloops_9.sin \ functional_tests/openloops_10.sin \ + functional_tests/openloops_11.sin \ functional_tests/recola_1.sin \ functional_tests/recola_2.sin \ functional_tests/recola_3.sin \ functional_tests/recola_4.sin \ functional_tests/recola_5.sin \ functional_tests/recola_6.sin \ functional_tests/recola_7.sin \ functional_tests/recola_8.sin \ functional_tests/powheg_1.sin \ functional_tests/mssmtest_1.sin \ functional_tests/mssmtest_2.sin \ functional_tests/mssmtest_3.sin \ functional_tests/spincor_1.sin \ functional_tests/show_1.sin \ functional_tests/show_2.sin \ functional_tests/show_3.sin \ functional_tests/show_4.sin \ functional_tests/show_5.sin \ functional_tests/method_ovm_1.sin \ functional_tests/multi_comp_1.sin \ functional_tests/multi_comp_2.sin \ functional_tests/multi_comp_3.sin \ functional_tests/multi_comp_4.sin \ functional_tests/flvsum_1.sin \ functional_tests/br_redef_1.sin \ functional_tests/decay_err_1.sin \ functional_tests/decay_err_2.sin \ functional_tests/decay_err_3.sin \ functional_tests/polarized_1.sin \ functional_tests/pdf_builtin.sin \ functional_tests/lhapdf5.sin \ functional_tests/lhapdf6.sin \ functional_tests/ep_1.sin \ functional_tests/ep_2.sin \ functional_tests/ep_3.sin \ functional_tests/circe1_1.sin \ functional_tests/circe1_2.sin \ functional_tests/circe1_3.sin \ functional_tests/circe1_4.sin \ functional_tests/circe1_5.sin \ functional_tests/circe1_6.sin \ functional_tests/circe1_7.sin \ functional_tests/circe1_8.sin \ functional_tests/circe1_9.sin \ functional_tests/circe1_10.sin \ functional_tests/circe1_photons_1.sin \ functional_tests/circe1_photons_2.sin \ functional_tests/circe1_photons_3.sin \ functional_tests/circe1_photons_4.sin \ functional_tests/circe1_photons_5.sin \ functional_tests/circe1_errors_1.sin \ functional_tests/circe2_1.sin \ functional_tests/circe2_2.sin \ functional_tests/circe2_3.sin \ functional_tests/isr_1.sin \ functional_tests/isr_2.sin \ functional_tests/isr_3.sin \ functional_tests/isr_4.sin \ functional_tests/isr_5.sin \ functional_tests/epa_1.sin \ functional_tests/epa_2.sin \ functional_tests/isr_epa_1.sin \ functional_tests/ewa_1.sin \ functional_tests/ewa_2.sin \ functional_tests/ewa_3.sin \ functional_tests/ewa_4.sin \ functional_tests/ilc.sin \ functional_tests/gaussian_1.sin \ functional_tests/gaussian_2.sin \ functional_tests/beam_events_1.sin \ functional_tests/beam_events_2.sin \ functional_tests/beam_events_3.sin \ functional_tests/beam_events_4.sin \ functional_tests/energy_scan_1.sin \ functional_tests/susyhit.sin \ functional_tests/restrictions.sin \ functional_tests/helicity.sin \ functional_tests/process_log.sin \ functional_tests/static_1.sin \ functional_tests/static_1.exe.sin \ functional_tests/static_2.sin \ functional_tests/static_2.exe.sin \ functional_tests/user_cuts.sin \ functional_tests/user_prc_threshold_1.sin \ functional_tests/cascades2_phs_1.sin \ functional_tests/user_prc_threshold_2.sin EXT_MSSM_M4 = \ ext_tests_mssm/mssm_ext-ee.m4 \ ext_tests_mssm/mssm_ext-ee2.m4 \ ext_tests_mssm/mssm_ext-en.m4 \ ext_tests_mssm/mssm_ext-tn.m4 \ ext_tests_mssm/mssm_ext-uu.m4 \ ext_tests_mssm/mssm_ext-uu2.m4 \ ext_tests_mssm/mssm_ext-uuckm.m4 \ ext_tests_mssm/mssm_ext-dd.m4 \ ext_tests_mssm/mssm_ext-dd2.m4 \ ext_tests_mssm/mssm_ext-ddckm.m4 \ ext_tests_mssm/mssm_ext-bb.m4 \ ext_tests_mssm/mssm_ext-bt.m4 \ ext_tests_mssm/mssm_ext-tt.m4 \ ext_tests_mssm/mssm_ext-ug.m4 \ ext_tests_mssm/mssm_ext-dg.m4 \ ext_tests_mssm/mssm_ext-aa.m4 \ ext_tests_mssm/mssm_ext-wa.m4 \ ext_tests_mssm/mssm_ext-za.m4 \ ext_tests_mssm/mssm_ext-ww.m4 \ ext_tests_mssm/mssm_ext-wz.m4 \ ext_tests_mssm/mssm_ext-zz.m4 \ ext_tests_mssm/mssm_ext-gg.m4 \ ext_tests_mssm/mssm_ext-ga.m4 \ ext_tests_mssm/mssm_ext-gw.m4 \ ext_tests_mssm/mssm_ext-gz.m4 EXT_NMSSM_M4 = \ ext_tests_nmssm/nmssm_ext-aa.m4 \ ext_tests_nmssm/nmssm_ext-bb1.m4 \ ext_tests_nmssm/nmssm_ext-bb2.m4 \ ext_tests_nmssm/nmssm_ext-bt.m4 \ ext_tests_nmssm/nmssm_ext-dd1.m4 \ ext_tests_nmssm/nmssm_ext-dd2.m4 \ ext_tests_nmssm/nmssm_ext-ee1.m4 \ ext_tests_nmssm/nmssm_ext-ee2.m4 \ ext_tests_nmssm/nmssm_ext-en.m4 \ ext_tests_nmssm/nmssm_ext-ga.m4 \ ext_tests_nmssm/nmssm_ext-gg.m4 \ ext_tests_nmssm/nmssm_ext-gw.m4 \ ext_tests_nmssm/nmssm_ext-gz.m4 \ ext_tests_nmssm/nmssm_ext-qg.m4 \ ext_tests_nmssm/nmssm_ext-tn.m4 \ ext_tests_nmssm/nmssm_ext-tt1.m4 \ ext_tests_nmssm/nmssm_ext-tt2.m4 \ ext_tests_nmssm/nmssm_ext-uu1.m4 \ ext_tests_nmssm/nmssm_ext-uu2.m4 \ ext_tests_nmssm/nmssm_ext-wa.m4 \ ext_tests_nmssm/nmssm_ext-ww1.m4 \ ext_tests_nmssm/nmssm_ext-ww2.m4 \ ext_tests_nmssm/nmssm_ext-wz.m4 \ ext_tests_nmssm/nmssm_ext-za.m4 \ ext_tests_nmssm/nmssm_ext-zz1.m4 \ ext_tests_nmssm/nmssm_ext-zz2.m4 EXT_MSSM_SIN = $(EXT_MSSM_M4:.m4=.sin) EXT_NMSSM_SIN = $(EXT_NMSSM_M4:.m4=.sin) EXT_ILC_SIN = \ ext_tests_ilc/ilc_ext.sin EXT_SHOWER_SIN = \ ext_tests_shower/shower_1_norad.sin \ ext_tests_shower/shower_2_aall.sin \ ext_tests_shower/shower_3_bb.sin \ ext_tests_shower/shower_3_jj.sin \ ext_tests_shower/shower_3_qqqq.sin \ ext_tests_shower/shower_3_tt.sin \ ext_tests_shower/shower_3_z_nu.sin \ ext_tests_shower/shower_3_z_tau.sin \ ext_tests_shower/shower_4_ee.sin \ ext_tests_shower/shower_5.sin \ ext_tests_shower/shower_6.sin EXT_NLO_SIN = \ ext_tests_nlo/nlo_decay_tbw.sin \ ext_tests_nlo/nlo_tt.sin \ ext_tests_nlo/nlo_tt_powheg.sin \ ext_tests_nlo/nlo_tt_powheg_sudakov.sin \ ext_tests_nlo/nlo_uu.sin \ ext_tests_nlo/nlo_uu_powheg.sin \ ext_tests_nlo/nlo_qq_powheg.sin \ ext_tests_nlo/nlo_threshold.sin \ ext_tests_nlo/nlo_threshold_factorized.sin \ ext_tests_nlo/nlo_methods_gosam.sin \ ext_tests_nlo/nlo_jets.sin \ ext_tests_nlo/nlo_settings.sin \ ext_tests_nlo/nlo_eejj.sin \ ext_tests_nlo/nlo_eejjj.sin \ ext_tests_nlo/nlo_ee4j.sin \ ext_tests_nlo/nlo_ee5j.sin \ ext_tests_nlo/nlo_eebb.sin \ ext_tests_nlo/nlo_eebbj.sin \ ext_tests_nlo/nlo_eebbjj.sin \ ext_tests_nlo/nlo_ee4b.sin \ ext_tests_nlo/nlo_eett.sin \ ext_tests_nlo/nlo_eettj.sin \ ext_tests_nlo/nlo_eettjj.sin \ ext_tests_nlo/nlo_eettjjj.sin \ ext_tests_nlo/nlo_eettbb.sin \ ext_tests_nlo/nlo_eetta.sin \ ext_tests_nlo/nlo_eettaa.sin \ ext_tests_nlo/nlo_eettaj.sin \ ext_tests_nlo/nlo_eettajj.sin \ ext_tests_nlo/nlo_eettaz.sin \ ext_tests_nlo/nlo_eettah.sin \ ext_tests_nlo/nlo_eettz.sin \ ext_tests_nlo/nlo_eettzj.sin \ ext_tests_nlo/nlo_eettzjj.sin \ ext_tests_nlo/nlo_eettzz.sin \ ext_tests_nlo/nlo_eettwjj.sin \ ext_tests_nlo/nlo_eettww.sin \ ext_tests_nlo/nlo_eetth.sin \ ext_tests_nlo/nlo_eetthj.sin \ ext_tests_nlo/nlo_eetthjj.sin \ ext_tests_nlo/nlo_eetthh.sin \ ext_tests_nlo/nlo_eetthz.sin \ ext_tests_nlo/nlo_ee4t.sin \ ext_tests_nlo/nlo_ee4tj.sin all-local: $(TESTSUITES_SIN) if M4_AVAILABLE SUFFIXES = .m4 .sin .m4.sin: case "$@" in \ */*) \ mkdir -p `sed 's,/.[^/]*$$,,g' <<< "$@"` ;; \ esac $(M4) $(srcdir)/$(TESTSUITE_MACROS) $< > $@ endif M4_AVAILABLE Index: trunk/share/tests/functional_tests/openloops_11.sin =================================================================== --- trunk/share/tests/functional_tests/openloops_11.sin (revision 0) +++ trunk/share/tests/functional_tests/openloops_11.sin (revision 8225) @@ -0,0 +1,42 @@ +# SINDARIN input for WHIZARD self-test +# Testing LO event generation for external/OpenLoops matrix elements +# with structure functions + +model = "SM" + +?logging = true +?openmp_logging = false +?vis_history = false +?integration_timer = false +?pacify = true + +alpha_power = 2 +alphas_power = 0 + +alias jet = u:d:U:D + +### The OpenLoops version installed might not be new enough to support Collier +?openloops_use_collier = false +?openloops_use_cms = false +$method = "openloops" + +!!! Tests should be run single-threaded +openmp_num_threads = 1 + +process openloops_11_p1 = e1, E1 => jet, jet +beams = e1, E1 => isr +seed = 42 + +sqrts = 200 GeV + +integrate (openloops_11_p1) { iterations = 1:100:"gw" } + +n_events = 2 +sample_format = debug +?debug_decay = false +?debug_process = false +?debug_verbose = false +?sample_pacify = true +?write_raw = false + +simulate (openloops_11_p1) \ No newline at end of file Index: trunk/share/tests/functional_tests/ref-output/openloops_11.ref =================================================================== --- trunk/share/tests/functional_tests/ref-output/openloops_11.ref (revision 0) +++ trunk/share/tests/functional_tests/ref-output/openloops_11.ref (revision 8225) @@ -0,0 +1,289 @@ +?openmp_logging = false +?vis_history = false +?integration_timer = false +?pacify = true +alpha_power = 2 +alphas_power = 0 +[user variable] jet = PDG(2, 1, -2, -1) +?openloops_use_collier = false +?openloops_use_cms = false +$method = "openloops" +openmp_num_threads = 1 +| Process library 'openloops_11_lib': recorded process 'openloops_11_p1' +seed = 42 +sqrts = 2.00000E+02 +| Integrate: current process library needs compilation +| Process library 'openloops_11_lib': compiling ... +| Process library 'openloops_11_lib': writing makefile +| Process library 'openloops_11_lib': removing old files +| Process library 'openloops_11_lib': writing driver +| Process library 'openloops_11_lib': creating source code +| Process library 'openloops_11_lib': compiling sources +| Process library 'openloops_11_lib': linking +| Process library 'openloops_11_lib': loading +| Process library 'openloops_11_lib': ... success. +| Integrate: compilation done +| RNG: Initializing TAO random-number generator +| RNG: Setting seed for random-number generator to 42 +| Initializing integration for process openloops_11_p1: +| Beam structure: e-, e+ => isr +| Beam data (collision): +| e- (mass = 5.1099700E-04 GeV) +| e+ (mass = 5.1099700E-04 GeV) +| sqrts = 2.000000000000E+02 GeV +| Phase space: generating configuration ... +| Phase space: ... success. +| Phase space: writing configuration file 'openloops_11_p1.i1.phs' +| One-Loop-Provider: Using OpenLoops +| Loading library: [...] +| One-Loop-Provider: Using OpenLoops +| Loading library: [...] +| ------------------------------------------------------------------------ +| Process [scattering]: 'openloops_11_p1' +| Library name = 'openloops_11_lib' +| Process index = 1 +| Process components: +| 1: 'openloops_11_p1_i1': e-, e+ => u:d:ubar:dbar, u:d:ubar:dbar [openloops] +| ------------------------------------------------------------------------ +| Phase space: 2 channels, 2 dimensions +| Phase space: found 2 channels, collected in 2 groves. +| Phase space: Using 2 equivalences between channels. +| Phase space: wood +| Beam structure: isr, none => none, isr +| Beam structure: 2 channels, 2 dimensions +Warning: No cuts have been defined. +| Starting integration for process 'openloops_11_p1' +| Integrate: iterations = 1:100:"gw" +| Integrator: 2 chains, 2 channels, 4 dimensions +| Integrator: Using VAMP channel equivalences +| Integrator: 100 initial calls, 20 bins, stratified = T +| Integrator: VAMP +|=============================================================================| +| It Calls Integral[fb] Error[fb] Err[%] Acc Eff[%] Chi2 N[It] | +|=============================================================================| + 1 100 3.422E+04 2.10E+03 6.14 0.61 32.6 +|-----------------------------------------------------------------------------| + 1 100 3.422E+04 2.10E+03 6.14 0.61 32.6 +|=============================================================================| +n_events = 2 +?debug_decay = false +?debug_process = false +?debug_verbose = false +?sample_pacify = true +?write_raw = false +| Starting simulation for process 'openloops_11_p1' +| Simulate: using integration grids from file 'openloops_11_p1.m1.vg' +| RNG: Initializing TAO random-number generator +| RNG: Setting seed for random-number generator to 43 +| Simulation: requested number of events = 2 +| corr. to luminosity [fb-1] = 5.8452E-05 +| Events: writing to ASCII file 'openloops_11_p1.debug' +| Events: generating 2 unweighted, unpolarized events ... +| Events: event normalization mode '1' +| ... event sample complete. +| Events: actual unweighting efficiency = 33.33 % +| Events: closing ASCII file 'openloops_11_p1.debug' +| There were no errors and 1 warning(s). +| WHIZARD run finished. +|=============================================================================| +Contents of openloops_11_p1.debug: +======================================================================== + Event #1 +------------------------------------------------------------------------ + Unweighted = T + Normalization = '1' + Helicity handling = drop + Keep correlations = F +------------------------------------------------------------------------ + Squared matrix el. (ref) = 5.60819E+05 + Squared matrix el. (prc) = 5.60819E+05 + Event weight (ref) = 1.00000E+00 + Event weight (prc) = 1.00000E+00 +------------------------------------------------------------------------ + Selected MCI group = 1 + Selected term = 1 + Selected channel = 2 +------------------------------------------------------------------------ + Passed selection = T + Reweighting factor = 1.00000E+00 + Analysis flag = T +======================================================================== + Event transform: trivial (hard process) +------------------------------------------------------------------------ + Associated process: 'openloops_11_p1' + TAO random-number generator: + seed = 2752514 + calls = 3 + Number of tries = 1 +------------------------------------------------------------------------ + Particle set: +------------------------------------------------------------------------ + Particle 1 [b] f(11) + E = 1.000000E+02 + P = 0.000000E+00 0.000000E+00 1.000000E+02 + T = 2.611179340E-07 + Children: 3 5 + Particle 2 [b] f(-11) + E = 1.000000E+02 + P = 0.000000E+00 0.000000E+00 -1.000000E+02 + T = 2.611179340E-07 + Children: 4 6 + Particle 3 [i] f(11) + E = 2.270555E+01 + P = 0.000000E+00 0.000000E+00 2.270555E+01 + T = 2.611179340E-07 + Parents: 1 + Children: 7 8 + Particle 4 [i] f(-11) + E = 1.000000E+02 + P = 0.000000E+00 0.000000E+00 -1.000000E+02 + T = 2.611179340E-07 + Parents: 2 + Children: 7 8 + Particle 5 [x] f(22*) + E = 7.729445E+01 + P = 0.000000E+00 0.000000E+00 7.729445E+01 + T = 0.000000000E+00 + Parents: 1 + Particle 6 [x] f(22*) + E = 1.798613E-07 + P = 0.000000E+00 0.000000E+00 -1.798613E-07 + T = 0.000000000E+00 + Parents: 2 + Particle 7 [o] f(-1) + E = 6.416907E+01 + P = -3.536678E+01 3.174411E+01 -4.311812E+01 + T = 0.000000000E+00 + Parents: 3 4 + Particle 8 [o] f(1) + E = 5.853648E+01 + P = 3.536678E+01 -3.174411E+01 -3.417633E+01 + T = 0.000000000E+00 + Parents: 3 4 +======================================================================== + Local variables: +------------------------------------------------------------------------ +sqrts* = 2.00000E+02 +sqrts_hat* => 9.53007E+01 +n_in* => 2 +n_out* => 4 +n_tot* => 6 +$process_id* => "openloops_11_p1" +process_num_id* => [unknown integer] +sqme* => 5.60819E+05 +sqme_ref* => 5.60819E+05 +event_index* => 1 +event_weight* => 1.00000E+00 +event_weight_ref* => 1.00000E+00 +event_excess* => 0.00000E+00 +------------------------------------------------------------------------ + subevent: + 1 prt(b:11|-1.0000000E+02; 0.0000000E+00, 0.0000000E+00,-1.0000000E+02| 2.6111793E-07| 1) + 2 prt(b:-11|-1.0000000E+02; 0.0000000E+00, 0.0000000E+00, 1.0000000E+02| 2.6111793E-07| 2) + 3 prt(i:11|-2.2705548E+01; 0.0000000E+00, 0.0000000E+00,-2.2705548E+01| 2.6111793E-07| 3) + 4 prt(i:-11|-1.0000000E+02; 0.0000000E+00, 0.0000000E+00, 1.0000000E+02| 2.6111793E-07| 4) + 5 prt(o:22| 7.7294452E+01; 0.0000000E+00, 0.0000000E+00, 7.7294452E+01| 0.0000000E+00| 5) + 6 prt(o:22| 1.7986125E-07; 0.0000000E+00, 0.0000000E+00,-1.7986125E-07| 0.0000000E+00| 6) + 7 prt(o:-1| 6.4169072E+01;-3.5366776E+01, 3.1744111E+01,-4.3118121E+01| 0.0000000E+00| 7) + 8 prt(o:1| 5.8536476E+01; 3.5366776E+01,-3.1744111E+01,-3.4176331E+01| 0.0000000E+00| 8) +======================================================================== +======================================================================== + Event #2 +------------------------------------------------------------------------ + Unweighted = T + Normalization = '1' + Helicity handling = drop + Keep correlations = F +------------------------------------------------------------------------ + Squared matrix el. (ref) = 1.13248E+02 + Squared matrix el. (prc) = 1.13248E+02 + Event weight (ref) = 1.00000E+00 + Event weight (prc) = 1.00000E+00 +------------------------------------------------------------------------ + Selected MCI group = 1 + Selected term = 1 + Selected channel = 2 +------------------------------------------------------------------------ + Passed selection = T + Reweighting factor = 1.00000E+00 + Analysis flag = T +======================================================================== + Event transform: trivial (hard process) +------------------------------------------------------------------------ + Associated process: 'openloops_11_p1' + TAO random-number generator: + seed = 2752514 + calls = 6 + Number of tries = 1 +------------------------------------------------------------------------ + Particle set: +------------------------------------------------------------------------ + Particle 1 [b] f(11) + E = 1.000000E+02 + P = 0.000000E+00 0.000000E+00 1.000000E+02 + T = 2.611179340E-07 + Children: 3 5 + Particle 2 [b] f(-11) + E = 1.000000E+02 + P = 0.000000E+00 0.000000E+00 -1.000000E+02 + T = 2.611179340E-07 + Children: 4 6 + Particle 3 [i] f(11) + E = 2.118626E+01 + P = 0.000000E+00 0.000000E+00 2.118626E+01 + T = 2.611179340E-07 + Parents: 1 + Children: 7 8 + Particle 4 [i] f(-11) + E = 9.998534E+01 + P = 0.000000E+00 0.000000E+00 -9.998534E+01 + T = 2.611179340E-07 + Parents: 2 + Children: 7 8 + Particle 5 [x] f(22*) + E = 7.881374E+01 + P = 0.000000E+00 0.000000E+00 7.881374E+01 + T = 0.000000000E+00 + Parents: 1 + Particle 6 [x] f(22*) + E = 1.465807E-02 + P = 0.000000E+00 0.000000E+00 -1.465807E-02 + T = 0.000000000E+00 + Parents: 2 + Particle 7 [o] f(-1) + E = 3.059445E+01 + P = -2.982130E+01 -1.251369E+00 6.719002E+00 + T = 0.000000000E+00 + Parents: 3 4 + Particle 8 [o] f(1) + E = 9.057714E+01 + P = 2.982130E+01 1.251369E+00 -8.551809E+01 + T = 0.000000000E+00 + Parents: 3 4 +======================================================================== + Local variables: +------------------------------------------------------------------------ +sqrts* = 2.00000E+02 +sqrts_hat* => 9.20503E+01 +n_in* => 2 +n_out* => 4 +n_tot* => 6 +$process_id* => "openloops_11_p1" +process_num_id* => [unknown integer] +sqme* => 1.13248E+02 +sqme_ref* => 1.13248E+02 +event_index* => 2 +event_weight* => 1.00000E+00 +event_weight_ref* => 1.00000E+00 +event_excess* => 0.00000E+00 +------------------------------------------------------------------------ + subevent: + 1 prt(b:11|-1.0000000E+02; 0.0000000E+00, 0.0000000E+00,-1.0000000E+02| 2.6111793E-07| 1) + 2 prt(b:-11|-1.0000000E+02; 0.0000000E+00, 0.0000000E+00, 1.0000000E+02| 2.6111793E-07| 2) + 3 prt(i:11|-2.1186255E+01; 0.0000000E+00, 0.0000000E+00,-2.1186255E+01| 2.6111793E-07| 3) + 4 prt(i:-11|-9.9985342E+01; 0.0000000E+00, 0.0000000E+00, 9.9985342E+01| 2.6111793E-07| 4) + 5 prt(o:22| 7.8813745E+01; 0.0000000E+00, 0.0000000E+00, 7.8813745E+01| 0.0000000E+00| 5) + 6 prt(o:22| 1.4658069E-02; 0.0000000E+00, 0.0000000E+00,-1.4658069E-02| 0.0000000E+00| 6) + 7 prt(o:-1| 3.0594453E+01;-2.9821295E+01,-1.2513692E+00, 6.7190019E+00| 0.0000000E+00| 7) + 8 prt(o:1| 9.0577144E+01; 2.9821295E+01, 1.2513692E+00,-8.5518089E+01| 0.0000000E+00| 8) +======================================================================== Index: trunk/src/phase_space/phase_space.nw =================================================================== --- trunk/src/phase_space/phase_space.nw (revision 8224) +++ trunk/src/phase_space/phase_space.nw (revision 8225) @@ -1,27616 +1,27615 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: phase space %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Phase Space} \includemodulegraph{phase_space} The abstract representation of a type that parameterizes phase space, with methods for construction and evaluation. \begin{description} \item[phs\_base] Abstract phase-space representation. \end{description} A simple implementation: \begin{description} \item[phs\_1none] This implements a non-functional dummy module for the phase space. A process which uses this module cannot be integrated. The purpose of this module is to provide a placeholder for processes which do not require phase-space evaluation. They may still allow for evaluating matrix elements. \item[phs\_single] Parameterize the phase space of a single particle, i.e., the solid angle. This is useful only for very restricted problems, but it avoids the complexity of a generic approach in those trivial cases. \end{description} The standard implementation is called \emph{wood} phase space. It consists of several auxiliary modules and the actual implementation module. \begin{description} \item[mappings] Generate invariant masses and decay angles from given random numbers (or the inverse operation). Each mapping pertains to a particular node in a phase-space tree. Different mappings account for uniform distributions, resonances, zero-mass behavior, and so on. \item[phs\_trees] Phase space parameterizations for scattering processes are defined recursively as if there was an initial particle decaying. This module sets up a representation in terms of abstract trees, where each node gets a unique binary number. Each tree is stored as an array of branches, where integers indicate the connections. This emulates pointers in a transparent way. Real pointers would also be possible, but seem to be less efficient for this particular case. \item[phs\_forests] The type defined by this module collects the decay trees corresponding to a given process and the applicable mappings. To set this up, a file is read which is either written by the user or by the \textbf{cascades} module functions. The module also contains the routines that evaluate phase space, i.e., generate momenta from random numbers and back. \item[cascades] This module is a pseudo Feynman diagram generator with the particular purpose of finding the phase space parameterizations best suited for a given process. It uses a model file to set up the possible vertices, generates all possible diagrams, identifies resonances and singularities, and simplifies the list by merging equivalent diagrams and dropping irrelevant ones. This process can be controlled at several points by user-defined parameters. Note that it depends on the particular values of particle masses, so it cannot be done before reading the input file. \item[phs\_wood] Make the functionality available in form of an implementation of the abstract phase-space type. \item[phs\_fks] Phase-space parameterization with modifications for the FKS scheme. \end{description} \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Abstract phase-space module} In this module we define an abstract base type (and a trivial test implementation) for multi-channel phase-space parameterizations. <<[[phs_base.f90]]>>= <> module phs_base <> <> use io_units use constants, only: TWOPI, TWOPI4 use string_utils, only: split_string use format_defs, only: FMT_19 use numeric_utils use diagnostics use md5 use physics_defs use lorentz use model_data use flavors use process_constants <> <> <> <> contains <> end module phs_base @ %def phs_base @ \subsection{Phase-space channels} The kinematics configuration may generate multiple parameterizations of phase space. Some of those have specific properties, such as a resonance in the s channel. \subsubsection{Channel properties} This is the abstract type for the channel properties. We need them as a data transfer container, so everything is public and transparent. <>= public :: channel_prop_t <>= type, abstract :: channel_prop_t contains procedure (channel_prop_to_string), deferred :: to_string generic :: operator (==) => is_equal procedure (channel_eq), deferred :: is_equal end type channel_prop_t @ %def channel_prop_t <>= abstract interface function channel_prop_to_string (object) result (string) import class(channel_prop_t), intent(in) :: object type(string_t) :: string end function channel_prop_to_string end interface @ %def channel_prop_to_string <>= abstract interface function channel_eq (prop1, prop2) result (flag) import class(channel_prop_t), intent(in) :: prop1, prop2 logical :: flag end function channel_eq end interface @ %def channel_prop_to_string @ Here is a resonance as a channel property. Mass and width are stored here in physical units. <>= public :: resonance_t <>= type, extends (channel_prop_t) :: resonance_t real(default) :: mass = 0 real(default) :: width = 0 contains procedure :: to_string => resonance_to_string procedure :: is_equal => resonance_is_equal end type resonance_t @ %def resonance_t @ Print mass and width. <>= function resonance_to_string (object) result (string) class(resonance_t), intent(in) :: object type(string_t) :: string character(32) :: buffer string = "resonant: m =" write (buffer, "(" // FMT_19 // ")") object%mass string = string // trim (buffer) // " GeV, w =" write (buffer, "(" // FMT_19 // ")") object%width string = string // trim (buffer) // " GeV" end function resonance_to_string @ %def resonance_to_string @ Equality. <>= function resonance_is_equal (prop1, prop2) result (flag) class(resonance_t), intent(in) :: prop1 class(channel_prop_t), intent(in) :: prop2 logical :: flag select type (prop2) type is (resonance_t) flag = prop1%mass == prop2%mass .and. prop1%width == prop2%width class default flag = .false. end select end function resonance_is_equal @ %def resonance_is_equal @ This is the limiting case of a resonance, namely an on-shell particle. We just store the mass in physical units. <>= public :: on_shell_t <>= type, extends (channel_prop_t) :: on_shell_t real(default) :: mass = 0 contains procedure :: to_string => on_shell_to_string procedure :: is_equal => on_shell_is_equal end type on_shell_t @ %def on_shell_t @ Print mass and width. <>= function on_shell_to_string (object) result (string) class(on_shell_t), intent(in) :: object type(string_t) :: string character(32) :: buffer string = "on shell: m =" write (buffer, "(" // FMT_19 // ")") object%mass string = string // trim (buffer) // " GeV" end function on_shell_to_string @ %def on_shell_to_string @ Equality. <>= function on_shell_is_equal (prop1, prop2) result (flag) class(on_shell_t), intent(in) :: prop1 class(channel_prop_t), intent(in) :: prop2 logical :: flag select type (prop2) type is (on_shell_t) flag = prop1%mass == prop2%mass class default flag = .false. end select end function on_shell_is_equal @ %def on_shell_is_equal @ \subsubsection{Channel equivalences} This type describes an equivalence. The current channel is equivalent to channel [[c]]. The equivalence involves a permutation [[perm]] of integration dimensions and, within each integration dimension, a mapping [[mode]]. <>= type :: phs_equivalence_t integer :: c = 0 integer, dimension(:), allocatable :: perm integer, dimension(:), allocatable :: mode contains <> end type phs_equivalence_t @ %def phs_equivalence_t @ The mapping modes are <>= integer, parameter, public :: & EQ_IDENTITY = 0, EQ_INVERT = 1, EQ_SYMMETRIC = 2, EQ_INVARIANT = 3 @ %def EQ_IDENTITY EQ_INVERT EQ_SYMMETRIC @ In particular, if a channel is equivalent to itself in the [[EQ_SYMMETRIC]] mode, the integrand can be assumed to be symmetric w.r.t.\ a reflection $x\to 1 - x$ of the correponding integration variable. These are the associated tags, for output: <>= character, dimension(0:3), parameter :: TAG = ["+", "-", ":", "x"] @ %def TAG @ Write an equivalence. <>= procedure :: write => phs_equivalence_write <>= subroutine phs_equivalence_write (object, unit) class(phs_equivalence_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, j u = given_output_unit (unit) write (u, "(5x,'=',1x,I0,1x)", advance = "no") object%c if (allocated (object%perm)) then write (u, "(A)", advance = "no") "(" do j = 1, size (object%perm) if (j > 1) write (u, "(1x)", advance = "no") write (u, "(I0,A1)", advance = "no") & object%perm(j), TAG(object%mode(j)) end do write (u, "(A)") ")" else write (u, "(A)") end if end subroutine phs_equivalence_write @ %def phs_equivalence_write @ Initialize an equivalence. This allocates the [[perm]] and [[mode]] arrays with equal size. <>= procedure :: init => phs_equivalence_init <>= subroutine phs_equivalence_init (eq, n_dim) class(phs_equivalence_t), intent(out) :: eq integer, intent(in) :: n_dim allocate (eq%perm (n_dim), source = 0) allocate (eq%mode (n_dim), source = EQ_IDENTITY) end subroutine phs_equivalence_init @ %def phs_equivalence_init @ \subsubsection{Channel objects} The channel entry holds (optionally) specific properties. [[sf_channel]] is the structure-function channel that corresponds to this phase-space channel. The structure-function channel may be set up with a specific mapping that depends on the phase-space channel properties. (The default setting is to leave the properties empty.) <>= public :: phs_channel_t <>= type :: phs_channel_t class(channel_prop_t), allocatable :: prop integer :: sf_channel = 1 type(phs_equivalence_t), dimension(:), allocatable :: eq contains <> end type phs_channel_t @ %def phs_channel_t @ Output. <>= procedure :: write => phs_channel_write <>= subroutine phs_channel_write (object, unit) class(phs_channel_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, j u = given_output_unit (unit) write (u, "(1x,I0)", advance="no") object%sf_channel if (allocated (object%prop)) then write (u, "(1x,A)") char (object%prop%to_string ()) else write (u, *) end if if (allocated (object%eq)) then do j = 1, size (object%eq) call object%eq(j)%write (u) end do end if end subroutine phs_channel_write @ %def phs_channel_write @ Identify the channel with an s-channel resonance. <>= procedure :: set_resonant => channel_set_resonant <>= subroutine channel_set_resonant (channel, mass, width) class(phs_channel_t), intent(inout) :: channel real(default), intent(in) :: mass, width allocate (resonance_t :: channel%prop) select type (prop => channel%prop) type is (resonance_t) prop%mass = mass prop%width = width end select end subroutine channel_set_resonant @ %def channel_set_resonant @ Identify the channel with an on-shell particle. <>= procedure :: set_on_shell => channel_set_on_shell <>= subroutine channel_set_on_shell (channel, mass) class(phs_channel_t), intent(inout) :: channel real(default), intent(in) :: mass allocate (on_shell_t :: channel%prop) select type (prop => channel%prop) type is (on_shell_t) prop%mass = mass end select end subroutine channel_set_on_shell @ %def channel_set_on_shell @ \subsection{Property collection} We can set up a list of all distinct channel properties for a given set of channels. <>= public :: phs_channel_collection_t <>= type :: prop_entry_t integer :: i = 0 class(channel_prop_t), allocatable :: prop type(prop_entry_t), pointer :: next => null () end type prop_entry_t type :: phs_channel_collection_t integer :: n = 0 type(prop_entry_t), pointer :: first => null () contains <> end type phs_channel_collection_t @ %def prop_entry_t @ %def phs_channel_collection_t @ Finalizer for the list. <>= procedure :: final => phs_channel_collection_final <>= subroutine phs_channel_collection_final (object) class(phs_channel_collection_t), intent(inout) :: object type(prop_entry_t), pointer :: entry do while (associated (object%first)) entry => object%first object%first => entry%next deallocate (entry) end do end subroutine phs_channel_collection_final @ %def phs_channel_collection_final @ Output. Note: eliminating the [[string]] auxiliary triggers an ICE in gfortran 4.7.2. <>= procedure :: write => phs_channel_collection_write <>= subroutine phs_channel_collection_write (object, unit) class(phs_channel_collection_t), intent(in) :: object integer, intent(in), optional :: unit type(prop_entry_t), pointer :: entry type(string_t) :: string integer :: u u = given_output_unit (unit) entry => object%first do while (associated (entry)) if (allocated (entry%prop)) then string = entry%prop%to_string () write (u, "(1x,I0,1x,A)") entry%i, char (string) else write (u, "(1x,I0)") entry%i end if entry => entry%next end do end subroutine phs_channel_collection_write @ %def phs_channel_collection_write @ Push a new property to the stack if it is not yet included. Simultaneously, set the [[sf_channel]] entry in the phase-space channel object to the index of the matching entry, or the new entry if there was no match. <>= procedure :: push => phs_channel_collection_push <>= subroutine phs_channel_collection_push (coll, channel) class(phs_channel_collection_t), intent(inout) :: coll type(phs_channel_t), intent(inout) :: channel type(prop_entry_t), pointer :: entry, new if (associated (coll%first)) then entry => coll%first do if (allocated (entry%prop)) then if (allocated (channel%prop)) then if (entry%prop == channel%prop) then channel%sf_channel = entry%i return end if end if else if (.not. allocated (channel%prop)) then channel%sf_channel = entry%i return end if if (associated (entry%next)) then entry => entry%next else exit end if end do allocate (new) entry%next => new else allocate (new) coll%first => new end if coll%n = coll%n + 1 new%i = coll%n channel%sf_channel = new%i if (allocated (channel%prop)) then allocate (new%prop, source = channel%prop) end if end subroutine phs_channel_collection_push @ %def phs_channel_collection_push @ Return the number of collected distinct channels. <>= procedure :: get_n => phs_channel_collection_get_n <>= function phs_channel_collection_get_n (coll) result (n) class(phs_channel_collection_t), intent(in) :: coll integer :: n n = coll%n end function phs_channel_collection_get_n @ %def phs_channel_collection_get_n @ Return a specific channel (property object). <>= procedure :: get_entry => phs_channel_collection_get_entry <>= subroutine phs_channel_collection_get_entry (coll, i, prop) class(phs_channel_collection_t), intent(in) :: coll integer, intent(in) :: i class(channel_prop_t), intent(out), allocatable :: prop type(prop_entry_t), pointer :: entry integer :: k if (i > 0 .and. i <= coll%n) then entry => coll%first do k = 2, i entry => entry%next end do if (allocated (entry%prop)) then if (allocated (prop)) deallocate (prop) allocate (prop, source = entry%prop) end if else call msg_bug ("PHS channel collection: get entry: illegal index") end if end subroutine phs_channel_collection_get_entry @ %def phs_channel_collection_get_entry @ \subsection{Kinematics configuration} Here, we store the universal information that is specifically relevant for phase-space generation. It is a subset of the process data, supplemented by basic information on phase-space parameterization channels. A concrete implementation will contain more data, that describe the phase space in detail. MD5 sums: the phase space setup depends on the process, it depends on the model parameters (the masses, that is), and on the configuration parameters. (It does not depend on the QCD setup.) <>= public :: phs_config_t <>= type, abstract :: phs_config_t ! private type(string_t) :: id integer :: n_in = 0 integer :: n_out = 0 integer :: n_tot = 0 integer :: n_state = 0 integer :: n_par = 0 integer :: n_channel = 0 real(default) :: sqrts = 0 logical :: sqrts_fixed = .true. logical :: cm_frame = .true. logical :: azimuthal_dependence = .false. integer, dimension(:), allocatable :: dim_flat logical :: provides_equivalences = .false. logical :: provides_chains = .false. logical :: vis_channels = .false. integer, dimension(:), allocatable :: chain class(model_data_t), pointer :: model => null () type(flavor_t), dimension(:,:), allocatable :: flv type(phs_channel_t), dimension(:), allocatable :: channel character(32) :: md5sum_process = "" character(32) :: md5sum_model_par = "" character(32) :: md5sum_phs_config = "" integer :: nlo_type contains <> end type phs_config_t @ %def phs_config_t @ Finalizer, deferred. <>= procedure (phs_config_final), deferred :: final <>= abstract interface subroutine phs_config_final (object) import class(phs_config_t), intent(inout) :: object end subroutine phs_config_final end interface @ %def phs_config_final @ Output. We provide an implementation for the output of the base-type contents and an interface for the actual write method. <>= procedure (phs_config_write), deferred :: write procedure :: base_write => phs_config_write <>= subroutine phs_config_write (object, unit, include_id) class(phs_config_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: include_id integer :: u, i, j integer :: n_tot_flv logical :: use_id n_tot_flv = object%n_tot u = given_output_unit (unit) use_id = .true.; if (present (include_id)) use_id = include_id if (use_id) write (u, "(3x,A,A,A)") "ID = '", char (object%id), "'" write (u, "(3x,A,I0)") "n_in = ", object%n_in write (u, "(3x,A,I0)") "n_out = ", object%n_out write (u, "(3x,A,I0)") "n_tot = ", object%n_tot write (u, "(3x,A,I0)") "n_state = ", object%n_state write (u, "(3x,A,I0)") "n_par = ", object%n_par write (u, "(3x,A,I0)") "n_channel = ", object%n_channel write (u, "(3x,A," // FMT_19 // ")") "sqrts = ", object%sqrts write (u, "(3x,A,L1)") "s_fixed = ", object%sqrts_fixed write (u, "(3x,A,L1)") "cm_frame = ", object%cm_frame write (u, "(3x,A,L1)") "azim.dep. = ", object%azimuthal_dependence if (allocated (object%dim_flat)) then write (u, "(3x,A,I0)") "flat dim. = ", object%dim_flat end if write (u, "(1x,A)") "Flavor combinations:" do i = 1, object%n_state write (u, "(3x,I0,':')", advance="no") i ! do j = 1, object%n_tot do j = 1, n_tot_flv write (u, "(1x,A)", advance="no") char (object%flv(j,i)%get_name ()) end do write (u, "(A)") end do if (allocated (object%channel)) then write (u, "(1x,A)") "Phase-space / structure-function channels:" do i = 1, object%n_channel write (u, "(3x,I0,':')", advance="no") i call object%channel(i)%write (u) end do end if if (object%md5sum_process /= "") then write (u, "(3x,A,A,A)") "MD5 sum (process) = '", & object%md5sum_process, "'" end if if (object%md5sum_model_par /= "") then write (u, "(3x,A,A,A)") "MD5 sum (model par) = '", & object%md5sum_model_par, "'" end if if (object%md5sum_phs_config /= "") then write (u, "(3x,A,A,A)") "MD5 sum (phs config) = '", & object%md5sum_phs_config, "'" end if end subroutine phs_config_write @ %def phs_config_write @ Similarly, a basic initializer and an interface. The model pointer is taken as an argument; we may verify that this has the expected model name. The intent is [[inout]]. We want to be able to set parameters in advance. <>= procedure :: init => phs_config_init <>= subroutine phs_config_init (phs_config, data, model) class(phs_config_t), intent(inout) :: phs_config type(process_constants_t), intent(in) :: data class(model_data_t), intent(in), target :: model integer :: i, j phs_config%id = data%id phs_config%n_in = data%n_in phs_config%n_out = data%n_out phs_config%n_tot = data%n_in + data%n_out phs_config%n_state = data%n_flv if (data%model_name == model%get_name ()) then phs_config%model => model else call msg_bug ("phs_config_init: model name mismatch") end if allocate (phs_config%flv (phs_config%n_tot, phs_config%n_state)) do i = 1, phs_config%n_state do j = 1, phs_config%n_tot call phs_config%flv(j,i)%init (data%flv_state(j,i), & phs_config%model) end do end do phs_config%md5sum_process = data%md5sum end subroutine phs_config_init @ %def phs_config_init @ WK 2018-04-05: This procedure appears to be redundant? <>= procedure :: set_component_index => phs_config_set_component_index <>= subroutine phs_config_set_component_index (phs_config, index) class(phs_config_t), intent(inout) :: phs_config integer, intent(in) :: index type(string_t), dimension(:), allocatable :: id type(string_t) :: suffix integer :: i, n suffix = var_str ('i') // int2string (index) call split_string (phs_config%id, var_str ('_'), id) phs_config%id = var_str ('') n = size (id) - 1 do i = 1, n phs_config%id = phs_config%id // id(i) // var_str ('_') end do phs_config%id = phs_config%id // suffix end subroutine phs_config_set_component_index @ %def phs_config_set_component_index @ This procedure should complete the phase-space configuration. We need the [[sqrts]] value as overall scale, which is known only after the beams have been defined. The procedure should determine the number of channels, their properties (if any), and allocate and fill the [[channel]] array accordingly. <>= procedure (phs_config_configure), deferred :: configure <>= abstract interface subroutine phs_config_configure (phs_config, sqrts, & sqrts_fixed, cm_frame, azimuthal_dependence, rebuild, ignore_mismatch, & nlo_type, subdir) import class(phs_config_t), intent(inout) :: phs_config real(default), intent(in) :: sqrts logical, intent(in), optional :: sqrts_fixed logical, intent(in), optional :: cm_frame logical, intent(in), optional :: azimuthal_dependence logical, intent(in), optional :: rebuild logical, intent(in), optional :: ignore_mismatch integer, intent(in), optional :: nlo_type type(string_t), intent(in), optional :: subdir end subroutine phs_config_configure end interface @ %def phs_config_configure @ Manually assign structure-function channel indices to the phase-space channel objects. (Used by a test routine.) <>= procedure :: set_sf_channel => phs_config_set_sf_channel <>= subroutine phs_config_set_sf_channel (phs_config, sf_channel) class(phs_config_t), intent(inout) :: phs_config integer, dimension(:), intent(in) :: sf_channel phs_config%channel%sf_channel = sf_channel end subroutine phs_config_set_sf_channel @ %def phs_config_set_sf_channel @ Collect new channels not yet in the collection from this phase-space configuration object. At the same time, assign structure-function channels. <>= procedure :: collect_channels => phs_config_collect_channels <>= subroutine phs_config_collect_channels (phs_config, coll) class(phs_config_t), intent(inout) :: phs_config type(phs_channel_collection_t), intent(inout) :: coll integer :: c do c = 1, phs_config%n_channel call coll%push (phs_config%channel(c)) end do end subroutine phs_config_collect_channels @ %def phs_config_collect_channels @ Compute the MD5 sum. We abuse the [[write]] method. In type implementations, [[write]] should only display information that is relevant for the MD5 sum. The data include the process MD5 sum which is taken from the process constants, and the MD5 sum of the model parameters. This may change, so it is computed here. <>= procedure :: compute_md5sum => phs_config_compute_md5sum <>= subroutine phs_config_compute_md5sum (phs_config, include_id) class(phs_config_t), intent(inout) :: phs_config logical, intent(in), optional :: include_id integer :: u phs_config%md5sum_model_par = phs_config%model%get_parameters_md5sum () phs_config%md5sum_phs_config = "" u = free_unit () open (u, status = "scratch", action = "readwrite") call phs_config%write (u, include_id) rewind (u) phs_config%md5sum_phs_config = md5sum (u) close (u) end subroutine phs_config_compute_md5sum @ %def phs_config_compute_md5sum @ Print an informative message after phase-space configuration. <>= procedure (phs_startup_message), deferred :: startup_message procedure :: base_startup_message => phs_startup_message <>= subroutine phs_startup_message (phs_config, unit) class(phs_config_t), intent(in) :: phs_config integer, intent(in), optional :: unit write (msg_buffer, "(A,3(1x,I0,1x,A))") & "Phase space:", & phs_config%n_channel, "channels,", & phs_config%n_par, "dimensions" call msg_message (unit = unit) end subroutine phs_startup_message @ %def phs_startup_message @ This procedure should be implemented such that the phase-space configuration object allocates a phase-space instance of matching type. <>= procedure (phs_config_allocate_instance), nopass, deferred :: & allocate_instance <>= abstract interface subroutine phs_config_allocate_instance (phs) import class(phs_t), intent(inout), pointer :: phs end subroutine phs_config_allocate_instance end interface @ %def phs_config_allocate_instance @ \subsection{Extract data} Return the number of MC input parameters. <>= procedure :: get_n_par => phs_config_get_n_par <>= function phs_config_get_n_par (phs_config) result (n) class(phs_config_t), intent(in) :: phs_config integer :: n n = phs_config%n_par end function phs_config_get_n_par @ %def phs_config_get_n_par @ Return dimensions (parameter indices) for which the phase-space dimension is flat, so integration and event generation can be simplified. <>= procedure :: get_flat_dimensions => phs_config_get_flat_dimensions <>= function phs_config_get_flat_dimensions (phs_config) result (dim_flat) class(phs_config_t), intent(in) :: phs_config integer, dimension(:), allocatable :: dim_flat if (allocated (phs_config%dim_flat)) then allocate (dim_flat (size (phs_config%dim_flat))) dim_flat = phs_config%dim_flat else allocate (dim_flat (0)) end if end function phs_config_get_flat_dimensions @ %def phs_config_get_flat_dimensions @ Return the number of phase-space channels. <>= procedure :: get_n_channel => phs_config_get_n_channel <>= function phs_config_get_n_channel (phs_config) result (n) class(phs_config_t), intent(in) :: phs_config integer :: n n = phs_config%n_channel end function phs_config_get_n_channel @ %def phs_config_get_n_channel @ Return the structure-function channel that corresponds to the phase-space channel [[c]]. If the channel array is not allocated (which happens if there is no structure function), return zero. <>= procedure :: get_sf_channel => phs_config_get_sf_channel <>= function phs_config_get_sf_channel (phs_config, c) result (c_sf) class(phs_config_t), intent(in) :: phs_config integer, intent(in) :: c integer :: c_sf if (allocated (phs_config%channel)) then c_sf = phs_config%channel(c)%sf_channel else c_sf = 0 end if end function phs_config_get_sf_channel @ %def phs_config_get_sf_channel @ Return the mass(es) of the incoming particle(s). We take the first flavor combination in the array, assuming that masses must be degenerate among flavors. <>= procedure :: get_masses_in => phs_config_get_masses_in <>= subroutine phs_config_get_masses_in (phs_config, m) class(phs_config_t), intent(in) :: phs_config real(default), dimension(:), intent(out) :: m integer :: i do i = 1, phs_config%n_in m(i) = phs_config%flv(i,1)%get_mass () end do end subroutine phs_config_get_masses_in @ %def phs_config_get_masses_in @ Return the MD5 sum of the configuration. <>= procedure :: get_md5sum => phs_config_get_md5sum <>= function phs_config_get_md5sum (phs_config) result (md5sum) class(phs_config_t), intent(in) :: phs_config character(32) :: md5sum md5sum = phs_config%md5sum_phs_config end function phs_config_get_md5sum @ %def phs_config_get_md5sum @ \subsection{Phase-space point instance} The [[phs_t]] object holds the workspace for phase-space generation. In the base object, we have the MC input parameters [[r]] and the Jacobian factor [[f]], for each channel, and the incoming and outgoing momenta. Note: The [[active_channel]] array is not used yet, all elements are initialized with [[.true.]]. It should be touched by the integrator if it decides to drop irrelevant channels. <>= public :: phs_t <>= type, abstract :: phs_t class(phs_config_t), pointer :: config => null () logical :: r_defined = .false. integer :: selected_channel = 0 logical, dimension(:), allocatable :: active_channel real(default), dimension(:,:), allocatable :: r real(default), dimension(:), allocatable :: f real(default), dimension(:), allocatable :: m_in real(default), dimension(:), allocatable :: m_out real(default) :: flux = 0 real(default) :: volume = 0 type(lorentz_transformation_t) :: lt_cm_to_lab logical :: p_defined = .false. real(default) :: sqrts_hat = 0 type(vector4_t), dimension(:), allocatable :: p logical :: q_defined = .false. type(vector4_t), dimension(:), allocatable :: q contains <> end type phs_t @ %def phs_t @ Output. Since phase space may get complicated, we include a [[verbose]] option for the abstract [[write]] procedure. <>= procedure (phs_write), deferred :: write <>= abstract interface subroutine phs_write (object, unit, verbose) import class(phs_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: verbose end subroutine phs_write end interface @ %def phs_write @ This procedure can be called to print the contents of the base type. <>= procedure :: base_write => phs_base_write <>= subroutine phs_base_write (object, unit) class(phs_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, c, i u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "Partonic phase space: parameters" if (object%r_defined) then write (u, *) else write (u, "(1x,A)") "[undefined]" end if write (u, "(3x,A,999(1x," // FMT_19 // "))") "m_in =", object%m_in write (u, "(3x,A,999(1x," // FMT_19 // "))") "m_out =", object%m_out write (u, "(3x,A," // FMT_19 // ")") "Flux = ", object%flux write (u, "(3x,A," // FMT_19 // ")") "Volume = ", object%volume if (allocated (object%f)) then do c = 1, size (object%r, 2) write (u, "(1x,A,I0,A)", advance="no") "Channel #", c, ":" if (c == object%selected_channel) then write (u, "(1x,A)") "[selected]" else write (u, *) end if write (u, "(3x,A)", advance="no") "r =" do i = 1, size (object%r, 1) write (u, "(1x,F9.7)", advance="no") object%r(i,c) end do write (u, *) write (u, "(3x,A,1x,ES13.7)") "f =", object%f(c) end do end if write (u, "(1x,A)") "Partonic phase space: momenta" if (object%p_defined) then write (u, "(3x,A," // FMT_19 // ")") "sqrts = ", object%sqrts_hat end if write (u, "(1x,A)", advance="no") "Incoming:" if (object%p_defined) then write (u, *) else write (u, "(1x,A)") "[undefined]" end if if (allocated (object%p)) then do i = 1, size (object%p) call vector4_write (object%p(i), u) end do end if write (u, "(1x,A)", advance="no") "Outgoing:" if (object%q_defined) then write (u, *) else write (u, "(1x,A)") "[undefined]" end if if (allocated (object%q)) then do i = 1, size (object%q) call vector4_write (object%q(i), u) end do end if if (object%p_defined .and. .not. object%config%cm_frame) then write (u, "(1x,A)") "Transformation c.m -> lab frame" call lorentz_transformation_write (object%lt_cm_to_lab, u) end if end subroutine phs_base_write @ %def phs_base_write @ Finalizer. The base type does not need it, but extensions may. <>= procedure (phs_final), deferred :: final <>= abstract interface subroutine phs_final (object) import class(phs_t), intent(inout) :: object end subroutine phs_final end interface @ %def phs_final @ Initializer. Everything should be contained in the [[process_data]] configuration object, so we can require a universal interface. <>= procedure (phs_init), deferred :: init <>= abstract interface subroutine phs_init (phs, phs_config) import class(phs_t), intent(out) :: phs class(phs_config_t), intent(in), target :: phs_config end subroutine phs_init end interface @ %def phs_init @ The base version will just allocate the arrays. It should be called at the beginning of the implementation of [[phs_init]]. <>= procedure :: base_init => phs_base_init <>= subroutine phs_base_init (phs, phs_config) class(phs_t), intent(out) :: phs class(phs_config_t), intent(in), target :: phs_config real(default), dimension(phs_config%n_in) :: m_in real(default), dimension(phs_config%n_out) :: m_out phs%config => phs_config allocate (phs%active_channel (phs%config%n_channel)) phs%active_channel = .true. allocate (phs%r (phs%config%n_par, phs%config%n_channel)); phs%r = 0 allocate (phs%f (phs%config%n_channel)); phs%f = 0 allocate (phs%p (phs%config%n_in)) !!! !!! !!! Workaround for gfortran 5.0 ICE m_in = phs_config%flv(:phs_config%n_in, 1)%get_mass () m_out = phs_config%flv(phs_config%n_in+1:, 1)%get_mass () allocate (phs%m_in (phs%config%n_in), source = m_in) !!! allocate (phs%m_in (phs%config%n_in), & !!! source = phs_config%flv(:phs_config%n_in, 1)%get_mass ()) allocate (phs%q (phs%config%n_out)) allocate (phs%m_out (phs%config%n_out), source = m_out) !!! allocate (phs%m_out (phs%config%n_out), & !!! source = phs_config%flv(phs_config%n_in+1:, 1)%get_mass ()) call phs%compute_flux () end subroutine phs_base_init @ %def phs_base_init @ Manually select a channel. <>= procedure :: select_channel => phs_base_select_channel <>= subroutine phs_base_select_channel (phs, channel) class(phs_t), intent(inout) :: phs integer, intent(in), optional :: channel if (present (channel)) then phs%selected_channel = channel else phs%selected_channel = 0 end if end subroutine phs_base_select_channel @ %def phs_base_select_channel @ Set incoming momenta. Assume that array shapes match. If requested, compute the Lorentz transformation from the c.m.\ to the lab frame and apply that transformation to the incoming momenta. In the c.m.\ frame, the sum of three-momenta is zero. In a scattering process, the $z$ axis is the direction of the first beam, the second beam is along the negative $z$ axis. The transformation from the c.m.\ to the lab frame is a rotation from the $z$ axis to the boost axis followed by a boost, such that the c.m.\ momenta are transformed into the lab-frame momenta. In a decay process, we just boost along the flight direction, without rotation. <>= procedure :: set_incoming_momenta => phs_set_incoming_momenta <>= subroutine phs_set_incoming_momenta (phs, p) class(phs_t), intent(inout) :: phs type(vector4_t), dimension(:), intent(in) :: p type(vector4_t) :: p0, p1 type(lorentz_transformation_t) :: lt0 integer :: i phs%p = p if (phs%config%cm_frame) then phs%sqrts_hat = phs%config%sqrts phs%p = p phs%lt_cm_to_lab = identity else p0 = sum (p) if (phs%config%sqrts_fixed) then phs%sqrts_hat = phs%config%sqrts else phs%sqrts_hat = p0 ** 1 end if lt0 = boost (p0, phs%sqrts_hat) select case (phs%config%n_in) case (1) phs%lt_cm_to_lab = lt0 case (2) p1 = inverse (lt0) * p(1) phs%lt_cm_to_lab = lt0 * rotation_to_2nd (3, space_part (p1)) end select phs%p = inverse (phs%lt_cm_to_lab) * p end if phs%p_defined = .true. end subroutine phs_set_incoming_momenta @ %def phs_set_incoming_momenta @ Set outgoing momenta. Assume that array shapes match. The incoming momenta must be known, so can apply the Lorentz transformation from c.m.\ to lab (inverse) to the momenta. <>= procedure :: set_outgoing_momenta => phs_set_outgoing_momenta <>= subroutine phs_set_outgoing_momenta (phs, q) class(phs_t), intent(inout) :: phs type(vector4_t), dimension(:), intent(in) :: q integer :: i if (phs%p_defined) then if (phs%config%cm_frame) then phs%q = q else phs%q = inverse (phs%lt_cm_to_lab) * q end if phs%q_defined = .true. end if end subroutine phs_set_outgoing_momenta @ %def phs_set_outgoing_momenta @ Return outgoing momenta. Apply the c.m.\ to lab transformation if necessary. <>= procedure :: get_outgoing_momenta => phs_get_outgoing_momenta <>= subroutine phs_get_outgoing_momenta (phs, q) class(phs_t), intent(in) :: phs type(vector4_t), dimension(:), intent(out) :: q if (phs%p_defined .and. phs%q_defined) then if (phs%config%cm_frame) then q = phs%q else q = phs%lt_cm_to_lab * phs%q end if else q = vector4_null end if end subroutine phs_get_outgoing_momenta @ %def phs_get_outgoing_momenta @ <>= procedure :: is_cm_frame => phs_is_cm_frame <>= function phs_is_cm_frame (phs) result (cm_frame) logical :: cm_frame class(phs_t), intent(in) :: phs cm_frame = phs%config%cm_frame end function phs_is_cm_frame @ %def phs_is_cm_frame @ <>= procedure :: get_n_tot => phs_get_n_tot <>= elemental function phs_get_n_tot (phs) result (n_tot) integer :: n_tot class(phs_t), intent(in) :: phs n_tot = phs%config%n_tot end function phs_get_n_tot @ %def phs_get_n_tot @ <>= procedure :: set_lorentz_transformation => phs_set_lorentz_transformation <>= subroutine phs_set_lorentz_transformation (phs, lt) class(phs_t), intent(inout) :: phs type(lorentz_transformation_t), intent(in) :: lt phs%lt_cm_to_lab = lt end subroutine phs_set_lorentz_transformation @ %def phs_set_lorentz_transformation @ <>= procedure :: get_lorentz_transformation => phs_get_lorentz_transformation <>= function phs_get_lorentz_transformation (phs) result (lt) type(lorentz_transformation_t) :: lt class(phs_t), intent(in) :: phs lt = phs%lt_cm_to_lab end function phs_get_lorentz_transformation @ %def phs_get_lorentz_transformation @ Return the input parameter array for a channel. <>= procedure :: get_mcpar => phs_get_mcpar <>= subroutine phs_get_mcpar (phs, c, r) class(phs_t), intent(in) :: phs integer, intent(in) :: c real(default), dimension(:), intent(out) :: r if (phs%r_defined) then r = phs%r(:,c) else r = 0 end if end subroutine phs_get_mcpar @ %def phs_get_mcpar @ Return the Jacobian factor for a channel. <>= procedure :: get_f => phs_get_f <>= function phs_get_f (phs, c) result (f) class(phs_t), intent(in) :: phs integer, intent(in) :: c real(default) :: f if (phs%r_defined) then f = phs%f(c) else f = 0 end if end function phs_get_f @ %def phs_get_f @ Return the overall factor, which is the product of the flux factor for the incoming partons and the phase-space volume for the outgoing partons. <>= procedure :: get_overall_factor => phs_get_overall_factor <>= function phs_get_overall_factor (phs) result (f) class(phs_t), intent(in) :: phs real(default) :: f f = phs%flux * phs%volume end function phs_get_overall_factor @ %def phs_get_overall_factor @ Compute flux factor. We do this during initialization (when the incoming momenta [[p]] are undefined), unless [[sqrts]] is variable. We do this again once for each phase-space point, but then we skip the calculation if [[sqrts]] is fixed. There are three different flux factors. \begin{enumerate} \item For a decaying massive particle, the factor is \begin{equation} f = (2\pi)^4 / (2M) \end{equation} \item For a $2\to n$ scattering process with $n>1$, the factor is \begin{equation} f = (2\pi)^4 / (2\sqrt{\lambda}) \end{equation} where for massless incoming particles, $\sqrt{\lambda} = s$. \item For a $2\to 1$ on-shell production process, the factor includes an extra $1/(2\pi)^3$ factor and a $1/m^2$ factor from the phase-space delta function $\delta (x_1x_2 - m^2/s)$, which originate from the one-particle phase space that we integrate out. \begin{equation} f = 2\pi / (2s m^2) \end{equation} The delta function is handled by the structure-function parameterization. \end{enumerate} <>= procedure :: compute_flux => phs_compute_flux <>= subroutine phs_compute_flux (phs) class(phs_t), intent(inout) :: phs real(default) :: s_hat, lda select case (phs%config%n_in) case (1) if (.not. phs%p_defined) then phs%flux = twopi4 / (2 * phs%m_in(1)) end if case (2) if (phs%p_defined) then if (phs%config%sqrts_fixed) then return else s_hat = sum (phs%p) ** 2 end if else if (phs%config%sqrts_fixed) then s_hat = phs%config%sqrts ** 2 else return end if end if select case (phs%config%n_out) case (2:) lda = lambda (s_hat, phs%m_in(1) ** 2, phs%m_in(2) ** 2) if (lda > 0) then phs%flux = conv * twopi4 / (2 * sqrt (lda)) else phs%flux = 0 end if case (1) phs%flux = conv * twopi & / (2 * phs%config%sqrts ** 2 * phs%m_out(1) ** 2) case default phs%flux = 0 end select end select end subroutine phs_compute_flux @ %def phs_compute_flux @ Evaluate the phase-space point for a particular channel and compute momenta, Jacobian, and phase-space volume. This is, of course, deferred to the implementation. <>= procedure (phs_evaluate_selected_channel), deferred :: & evaluate_selected_channel <>= abstract interface subroutine phs_evaluate_selected_channel (phs, c_in, r_in) import class(phs_t), intent(inout) :: phs integer, intent(in) :: c_in real(default), dimension(:), intent(in) :: r_in end subroutine phs_evaluate_selected_channel end interface @ %def phs_evaluate_selected_channel @ Compute the inverse mappings to completely fill the [[r]] and [[f]] arrays, for the non-selected channels. <>= procedure (phs_evaluate_other_channels), deferred :: & evaluate_other_channels <>= abstract interface subroutine phs_evaluate_other_channels (phs, c_in) import class(phs_t), intent(inout) :: phs integer, intent(in) :: c_in end subroutine phs_evaluate_other_channels end interface @ %def phs_evaluate_other_channels @ Inverse evaluation. If all momenta are known, we compute the inverse mappings to fill the [[r]] and [[f]] arrays. <>= procedure (phs_inverse), deferred :: inverse <>= abstract interface subroutine phs_inverse (phs) import class(phs_t), intent(inout) :: phs end subroutine phs_inverse end interface @ %def phs_inverse @ <>= procedure :: get_sqrts => phs_get_sqrts <>= function phs_get_sqrts (phs) result (sqrts) real(default) :: sqrts class(phs_t), intent(in) :: phs sqrts = phs%config%sqrts end function phs_get_sqrts @ %def phs_get_sqrts @ \subsubsection{Uniform angular distribution} These procedures implement the uniform angular distribution, generated from two parameters $x_1$ and $x_2$: \begin{equation} \cos\theta = 1 - 2x_1, \qquad \phi = 2\pi x_2 \end{equation} We generate a rotation (Lorentz transformation) which rotates the positive $z$ axis into this point on the unit sphere. This rotation is applied to the [[p]] momenta, which are assumed to be back-to-back, on-shell, and with the correct mass. We do not compute a Jacobian (constant). The uniform distribution is assumed to be normalized. <>= public :: compute_kinematics_solid_angle <>= subroutine compute_kinematics_solid_angle (p, q, x) type(vector4_t), dimension(2), intent(in) :: p type(vector4_t), dimension(2), intent(out) :: q real(default), dimension(2), intent(in) :: x real(default) :: ct, st, phi type(lorentz_transformation_t) :: rot integer :: i ct = 1 - 2*x(1) st = sqrt (1 - ct**2) phi = twopi * x(2) rot = rotation (phi, 3) * rotation (ct, st, 2) do i = 1, 2 q(i) = rot * p(i) end do end subroutine compute_kinematics_solid_angle @ %def compute_kinematics_solid_angle @ This is the inverse transformation. We assume that the outgoing momenta are rotated versions of the incoming momenta, back-to-back. Thus, we determine the angles from $q(1)$ alone. [[p]] is unused. <>= public :: inverse_kinematics_solid_angle <>= subroutine inverse_kinematics_solid_angle (p, q, x) type(vector4_t), dimension(:), intent(in) :: p type(vector4_t), dimension(2), intent(in) :: q real(default), dimension(2), intent(out) :: x real(default) :: ct, phi ct = polar_angle_ct (q(1)) phi = azimuthal_angle (q(1)) x(1) = (1 - ct) / 2 x(2) = phi / twopi end subroutine inverse_kinematics_solid_angle @ %def inverse_kinematics_solid_angle @ \subsection{Auxiliary stuff} The [[pacify]] subroutine, which is provided by the Lorentz module, has the purpose of setting numbers to zero which are (by comparing with a [[tolerance]] parameter) considered equivalent with zero. This is useful for numerical checks. <>= public :: pacify <>= interface pacify module procedure pacify_phs end interface pacify <>= subroutine pacify_phs (phs) class(phs_t), intent(inout) :: phs if (phs%p_defined) then call pacify (phs%p, 30 * epsilon (1._default) * phs%config%sqrts) call pacify (phs%lt_cm_to_lab, 30 * epsilon (1._default)) end if if (phs%q_defined) then call pacify (phs%q, 30 * epsilon (1._default) * phs%config%sqrts) end if end subroutine pacify_phs @ %def pacify @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[phs_base_ut.f90]]>>= <> module phs_base_ut use unit_tests use phs_base_uti <> <> <> contains <> end module phs_base_ut @ %def phs_base_ut @ <<[[phs_base_uti.f90]]>>= <> module phs_base_uti <> <> use diagnostics use io_units use format_defs, only: FMT_19 use physics_defs, only: BORN use lorentz use flavors use model_data use process_constants use phs_base <> <> <> <> contains <> <> end module phs_base_uti @ %def phs_base_ut @ API: driver for the unit tests below. <>= public :: phs_base_test <>= subroutine phs_base_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine phs_base_test @ %def phs_base_test @ \subsubsection{Test process data} We provide a procedure that initializes a test case for the process constants. This set of process data contains just the minimal contents that we need for the phase space. The rest is left uninitialized. <>= public :: init_test_process_data <>= subroutine init_test_process_data (id, data) type(process_constants_t), intent(out) :: data type(string_t), intent(in), optional :: id if (present (id)) then data%id = id else data%id = "testproc" end if data%model_name = "Test" data%n_in = 2 data%n_out = 2 data%n_flv = 1 allocate (data%flv_state (data%n_in + data%n_out, data%n_flv)) data%flv_state = 25 end subroutine init_test_process_data @ %def init_test_process_data @ This is the variant for a decay process. <>= public :: init_test_decay_data <>= subroutine init_test_decay_data (id, data) type(process_constants_t), intent(out) :: data type(string_t), intent(in), optional :: id if (present (id)) then data%id = id else data%id = "testproc" end if data%model_name = "Test" data%n_in = 1 data%n_out = 2 data%n_flv = 1 allocate (data%flv_state (data%n_in + data%n_out, data%n_flv)) data%flv_state(:,1) = [25, 6, -6] end subroutine init_test_decay_data @ %def init_test_decay_data @ \subsubsection{Test kinematics configuration} This is a trivial implementation of the [[phs_config_t]] configuration object. <>= public :: phs_test_config_t <>= type, extends (phs_config_t) :: phs_test_config_t logical :: create_equivalences = .false. contains procedure :: final => phs_test_config_final procedure :: write => phs_test_config_write procedure :: configure => phs_test_config_configure procedure :: startup_message => phs_test_config_startup_message procedure, nopass :: allocate_instance => phs_test_config_allocate_instance end type phs_test_config_t @ %def phs_test_config_t @ The finalizer is empty. <>= subroutine phs_test_config_final (object) class(phs_test_config_t), intent(inout) :: object end subroutine phs_test_config_final @ %def phs_test_config_final @ The [[cm_frame]] parameter is not tested here; we defer this to the [[phs_single]] implementation. <>= subroutine phs_test_config_write (object, unit, include_id) class(phs_test_config_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: include_id integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Partonic phase-space configuration:" call object%base_write (unit) end subroutine phs_test_config_write subroutine phs_test_config_configure (phs_config, sqrts, & sqrts_fixed, cm_frame, azimuthal_dependence, rebuild, & ignore_mismatch, nlo_type, subdir) class(phs_test_config_t), intent(inout) :: phs_config real(default), intent(in) :: sqrts logical, intent(in), optional :: sqrts_fixed logical, intent(in), optional :: cm_frame logical, intent(in), optional :: azimuthal_dependence logical, intent(in), optional :: rebuild logical, intent(in), optional :: ignore_mismatch integer, intent(in), optional :: nlo_type type(string_t), intent(in), optional :: subdir phs_config%n_channel = 2 phs_config%n_par = 2 phs_config%sqrts = sqrts if (.not. present (nlo_type)) & phs_config%nlo_type = BORN if (present (sqrts_fixed)) then phs_config%sqrts_fixed = sqrts_fixed end if if (present (cm_frame)) then phs_config%cm_frame = cm_frame end if if (present (azimuthal_dependence)) then phs_config%azimuthal_dependence = azimuthal_dependence end if if (allocated (phs_config%channel)) deallocate (phs_config%channel) allocate (phs_config%channel (phs_config%n_channel)) if (phs_config%create_equivalences) then call setup_test_equivalences (phs_config) call setup_test_channel_props (phs_config) end if call phs_config%compute_md5sum () end subroutine phs_test_config_configure @ %def phs_test_config_write @ %def phs_test_config_configure @ If requested, we make up an arbitrary set of equivalences. <>= subroutine setup_test_equivalences (phs_config) class(phs_test_config_t), intent(inout) :: phs_config integer :: i associate (channel => phs_config%channel(1)) allocate (channel%eq (2)) do i = 1, size (channel%eq) call channel%eq(i)%init (phs_config%n_par) end do associate (eq => channel%eq(1)) eq%c = 1; eq%perm = [1, 2]; eq%mode = [EQ_IDENTITY, EQ_SYMMETRIC] end associate associate (eq => channel%eq(2)) eq%c = 2; eq%perm = [2, 1]; eq%mode = [EQ_INVARIANT, EQ_IDENTITY] end associate end associate end subroutine setup_test_equivalences @ %def setup_test_equivalences @ Ditto, for channel properties. <>= subroutine setup_test_channel_props (phs_config) class(phs_test_config_t), intent(inout) :: phs_config associate (channel => phs_config%channel(2)) call channel%set_resonant (140._default, 3.1415_default) end associate end subroutine setup_test_channel_props @ %def setup_test_channel_props @ Startup message <>= subroutine phs_test_config_startup_message (phs_config, unit) class(phs_test_config_t), intent(in) :: phs_config integer, intent(in), optional :: unit call phs_config%base_startup_message (unit) write (msg_buffer, "(A)") "Phase space: Test" call msg_message (unit = unit) end subroutine phs_test_config_startup_message @ %def phs_test_config_startup_message @ The instance type that matches [[phs_test_config_t]] is [[phs_test_t]]. <>= subroutine phs_test_config_allocate_instance (phs) class(phs_t), intent(inout), pointer :: phs allocate (phs_test_t :: phs) end subroutine phs_test_config_allocate_instance @ %def phs_test_config_allocate_instance @ \subsubsection{Test kinematics implementation} This implementation of kinematics generates a simple two-particle configuration from the incoming momenta. The incoming momenta must be in the c.m.\ system, all masses equal. There are two channels: one generates $\cos\theta$ and $\phi$ uniformly, in the other channel we map the $r_1$ parameter which belongs to $\cos\theta$. We should store the mass parameter that we need. <>= public :: phs_test_t <>= type, extends (phs_t) :: phs_test_t real(default) :: m = 0 real(default), dimension(:), allocatable :: x contains <> end type phs_test_t @ %def phs_test_t @ Output. The specific data are displayed only if [[verbose]] is set. <>= procedure :: write => phs_test_write <>= subroutine phs_test_write (object, unit, verbose) class(phs_test_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u logical :: verb u = given_output_unit (unit) verb = .false.; if (present (verbose)) verb = verbose if (verb) then write (u, "(1x,A)") "Partonic phase space: data" write (u, "(3x,A," // FMT_19 // ")") "m = ", object%m end if call object%base_write (u) end subroutine phs_test_write @ %def phs_test_write @ The finalizer is empty. <>= procedure :: final => phs_test_final <>= subroutine phs_test_final (object) class(phs_test_t), intent(inout) :: object end subroutine phs_test_final @ %def phs_test_final @ Initialization: set the mass value. <>= procedure :: init => phs_test_init <>= subroutine phs_test_init (phs, phs_config) class(phs_test_t), intent(out) :: phs class(phs_config_t), intent(in), target :: phs_config call phs%base_init (phs_config) phs%m = phs%config%flv(1,1)%get_mass () allocate (phs%x (phs_config%n_par), source = 0._default) end subroutine phs_test_init @ %def phs_test_init @ Evaluation. In channel 1, we uniformly generate $\cos\theta$ and $\phi$, with Jacobian normalized to one. In channel 2, we prepend a mapping $r_1 \to r_1^(1/3)$ with Jacobian $f=3r_1^2$. The component [[x]] is allocated in the first subroutine, used and deallocated in the second one. <>= procedure :: evaluate_selected_channel => phs_test_evaluate_selected_channel procedure :: evaluate_other_channels => phs_test_evaluate_other_channels <>= subroutine phs_test_evaluate_selected_channel (phs, c_in, r_in) class(phs_test_t), intent(inout) :: phs integer, intent(in) :: c_in real(default), intent(in), dimension(:) :: r_in if (phs%p_defined) then call phs%select_channel (c_in) phs%r(:,c_in) = r_in select case (c_in) case (1) phs%x = r_in case (2) phs%x(1) = r_in(1) ** (1 / 3._default) phs%x(2) = r_in(2) end select call compute_kinematics_solid_angle (phs%p, phs%q, phs%x) phs%volume = 1 phs%q_defined = .true. end if end subroutine phs_test_evaluate_selected_channel subroutine phs_test_evaluate_other_channels (phs, c_in) class(phs_test_t), intent(inout) :: phs integer, intent(in) :: c_in integer :: c, n_channel if (phs%p_defined) then n_channel = phs%config%n_channel do c = 1, n_channel if (c /= c_in) then call inverse_kinematics_solid_angle (phs%p, phs%q, phs%x) select case (c) case (1) phs%r(:,c) = phs%x case (2) phs%r(1,c) = phs%x(1) ** 3 phs%r(2,c) = phs%x(2) end select end if end do phs%f(1) = 1 if (phs%r(1,2) /= 0) then phs%f(2) = 1 / (3 * phs%r(1,2) ** (2/3._default)) else phs%f(2) = 0 end if phs%r_defined = .true. end if end subroutine phs_test_evaluate_other_channels @ %def phs_test_evaluate_selected_channels @ %def phs_test_evaluate_other_channels @ Inverse evaluation. <>= procedure :: inverse => phs_test_inverse <>= subroutine phs_test_inverse (phs) class(phs_test_t), intent(inout) :: phs integer :: c, n_channel real(default), dimension(:), allocatable :: x if (phs%p_defined .and. phs%q_defined) then call phs%select_channel () n_channel = phs%config%n_channel allocate (x (phs%config%n_par)) do c = 1, n_channel call inverse_kinematics_solid_angle (phs%p, phs%q, x) select case (c) case (1) phs%r(:,c) = x case (2) phs%r(1,c) = x(1) ** 3 phs%r(2,c) = x(2) end select end do phs%f(1) = 1 if (phs%r(1,2) /= 0) then phs%f(2) = 1 / (3 * phs%r(1,2) ** (2/3._default)) else phs%f(2) = 0 end if phs%volume = 1 phs%r_defined = .true. end if end subroutine phs_test_inverse @ %def phs_test_inverse @ \subsubsection{Phase-space configuration data} Construct and display a test phase-space configuration object. <>= call test (phs_base_1, "phs_base_1", & "phase-space configuration", & u, results) <>= public :: phs_base_1 <>= subroutine phs_base_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(process_constants_t) :: process_data class(phs_config_t), allocatable :: phs_data write (u, "(A)") "* Test output: phs_base_1" write (u, "(A)") "* Purpose: initialize and display & &test phase-space configuration data" write (u, "(A)") call model%init_test () write (u, "(A)") "* Initialize a process and a matching & &phase-space configuration" write (u, "(A)") call init_test_process_data (var_str ("phs_base_1"), process_data) allocate (phs_test_config_t :: phs_data) call phs_data%init (process_data, model) call phs_data%write (u) call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_base_1" end subroutine phs_base_1 @ %def phs_base_1 @ \subsubsection{Phase space evaluation} Compute kinematics for given parameters, also invert the calculation. <>= call test (phs_base_2, "phs_base_2", & "phase-space evaluation", & u, results) <>= public :: phs_base_2 <>= subroutine phs_base_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(process_constants_t) :: process_data real(default) :: sqrts, E class(phs_config_t), allocatable, target :: phs_data class(phs_t), pointer :: phs => null () type(vector4_t), dimension(2) :: p, q write (u, "(A)") "* Test output: phs_base_2" write (u, "(A)") "* Purpose: test simple two-channel phase space" write (u, "(A)") call model%init_test () call flv%init (25, model) write (u, "(A)") "* Initialize a process and a matching & &phase-space configuration" write (u, "(A)") call init_test_process_data (var_str ("phs_base_2"), process_data) allocate (phs_test_config_t :: phs_data) call phs_data%init (process_data, model) sqrts = 1000._default call phs_data%configure (sqrts) call phs_data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize the phase-space instance" write (u, "(A)") call phs_data%allocate_instance (phs) select type (phs) type is (phs_test_t) call phs%init (phs_data) end select call phs%write (u, verbose=.true.) write (u, "(A)") write (u, "(A)") "* Set incoming momenta" write (u, "(A)") E = sqrts / 2 p(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) p(2) = vector4_moving (E,-sqrt (E**2 - flv%get_mass ()**2), 3) call phs%set_incoming_momenta (p) call phs%compute_flux () call phs%write (u) write (u, "(A)") write (u, "(A)") "* Compute phase-space point in channel 1 & &for x = 0.5, 0.125" write (u, "(A)") call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default]) call phs%evaluate_other_channels (1) call phs%write (u) write (u, "(A)") write (u, "(A)") "* Compute phase-space point in channel 2 & &for x = 0.125, 0.125" write (u, "(A)") call phs%evaluate_selected_channel (2, [0.125_default, 0.125_default]) call phs%evaluate_other_channels (2) call phs%write (u) write (u, "(A)") write (u, "(A)") "* Inverse kinematics" write (u, "(A)") call phs%get_outgoing_momenta (q) deallocate (phs) call phs_data%allocate_instance (phs) call phs%init (phs_data) sqrts = 1000._default select type (phs_data) type is (phs_test_config_t) call phs_data%configure (sqrts) end select call phs%set_incoming_momenta (p) call phs%compute_flux () call phs%set_outgoing_momenta (q) call phs%inverse () call phs%write (u) call phs%final () deallocate (phs) call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_base_2" end subroutine phs_base_2 @ %def phs_base_2 @ \subsubsection{Phase-space equivalences} Construct a test phase-space configuration which contains channel equivalences. <>= call test (phs_base_3, "phs_base_3", & "channel equivalences", & u, results) <>= public :: phs_base_3 <>= subroutine phs_base_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(process_constants_t) :: process_data class(phs_config_t), allocatable :: phs_data write (u, "(A)") "* Test output: phs_base_3" write (u, "(A)") "* Purpose: construct phase-space configuration data & &with equivalences" write (u, "(A)") call model%init_test () write (u, "(A)") "* Initialize a process and a matching & &phase-space configuration" write (u, "(A)") call init_test_process_data (var_str ("phs_base_3"), process_data) allocate (phs_test_config_t :: phs_data) call phs_data%init (process_data, model) select type (phs_data) type is (phs_test_config_t) phs_data%create_equivalences = .true. end select call phs_data%configure (1000._default) call phs_data%write (u) call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_base_3" end subroutine phs_base_3 @ %def phs_base_3 @ \subsubsection{MD5 sum checks} Construct a test phase-space configuration, compute and compare MD5 sums. <>= call test (phs_base_4, "phs_base_4", & "MD5 sum", & u, results) <>= public :: phs_base_4 <>= subroutine phs_base_4 (u) integer, intent(in) :: u type(model_data_t), target :: model type(process_constants_t) :: process_data class(phs_config_t), allocatable :: phs_data write (u, "(A)") "* Test output: phs_base_4" write (u, "(A)") "* Purpose: compute and compare MD5 sums" write (u, "(A)") call model%init_test () write (u, "(A)") "* Model parameters" write (u, "(A)") call model%write (unit = u, & show_parameters = .true., & show_particles = .false., show_vertices = .false.) write (u, "(A)") write (u, "(A)") "* Initialize a process and a matching & &phase-space configuration" write (u, "(A)") call init_test_process_data (var_str ("phs_base_4"), process_data) process_data%md5sum = "test_process_data_m6sum_12345678" allocate (phs_test_config_t :: phs_data) call phs_data%init (process_data, model) call phs_data%compute_md5sum () call phs_data%write (u) write (u, "(A)") write (u, "(A)") "* Modify model parameter" write (u, "(A)") call model%set_par (var_str ("ms"), 100._default) call model%write (show_parameters = .true., & show_particles = .false., show_vertices = .false.) write (u, "(A)") write (u, "(A)") "* PHS configuration" write (u, "(A)") call phs_data%compute_md5sum () call phs_data%write (u) call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_base_4" end subroutine phs_base_4 @ %def phs_base_4 @ \subsubsection{Phase-space channel collection} Set up an array of various phase-space channels and collect them in a list. <>= call test (phs_base_5, "phs_base_5", & "channel collection", & u, results) <>= public :: phs_base_5 <>= subroutine phs_base_5 (u) integer, intent(in) :: u type(phs_channel_t), dimension(:), allocatable :: channel type(phs_channel_collection_t) :: coll integer :: i, n write (u, "(A)") "* Test output: phs_base_5" write (u, "(A)") "* Purpose: collect channel properties" write (u, "(A)") write (u, "(A)") "* Set up an array of channels" write (u, "(A)") n = 6 allocate (channel (n)) call channel(2)%set_resonant (75._default, 3._default) call channel(4)%set_resonant (130._default, 1._default) call channel(5)%set_resonant (75._default, 3._default) call channel(6)%set_on_shell (33._default) do i = 1, n write (u, "(1x,I0)", advance="no") i call channel(i)%write (u) end do write (u, "(A)") write (u, "(A)") "* Collect distinct properties" write (u, "(A)") do i = 1, n call coll%push (channel(i)) end do write (u, "(1x,A,I0)") "n = ", coll%get_n () write (u, "(A)") call coll%write (u) write (u, "(A)") write (u, "(A)") "* Channel array with collection index assigned" write (u, "(A)") do i = 1, n write (u, "(1x,I0)", advance="no") i call channel(i)%write (u) end do write (u, "(A)") write (u, "(A)") "* Cleanup" call coll%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_base_5" end subroutine phs_base_5 @ %def phs_base_5 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \clearpage \section{Dummy phase space} This module implements a dummy phase space module for cases where the program structure demands the existence of a phase-space module, but no phase space integration is performed. <<[[phs_none.f90]]>>= <> module phs_none <> <> use io_units, only: given_output_unit use diagnostics, only: msg_message, msg_fatal use phs_base, only: phs_config_t, phs_t <> <> <> contains <> end module phs_none @ %def phs_none @ \subsection{Configuration} Nothing to configure, but we provide the type and methods. <>= public :: phs_none_config_t <>= type, extends (phs_config_t) :: phs_none_config_t contains <> end type phs_none_config_t @ %def phs_none_config_t @ The finalizer is empty. <>= procedure :: final => phs_none_config_final <>= subroutine phs_none_config_final (object) class(phs_none_config_t), intent(inout) :: object end subroutine phs_none_config_final @ %def phs_none_final @ Output. No contents, just an informative line. <>= procedure :: write => phs_none_config_write <>= subroutine phs_none_config_write (object, unit, include_id) class(phs_none_config_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: include_id integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Partonic phase-space configuration: non-functional dummy" end subroutine phs_none_config_write @ %def phs_none_config_write @ Configuration: we have to implement this method, but it obviously does nothing. <>= procedure :: configure => phs_none_config_configure <>= subroutine phs_none_config_configure (phs_config, sqrts, & sqrts_fixed, cm_frame, azimuthal_dependence, rebuild, ignore_mismatch, & nlo_type, subdir) class(phs_none_config_t), intent(inout) :: phs_config real(default), intent(in) :: sqrts logical, intent(in), optional :: sqrts_fixed logical, intent(in), optional :: cm_frame logical, intent(in), optional :: azimuthal_dependence logical, intent(in), optional :: rebuild logical, intent(in), optional :: ignore_mismatch integer, intent(in), optional :: nlo_type type(string_t), intent(in), optional :: subdir end subroutine phs_none_config_configure @ %def phs_none_config_configure @ Startup message, after configuration is complete. <>= procedure :: startup_message => phs_none_config_startup_message <>= subroutine phs_none_config_startup_message (phs_config, unit) class(phs_none_config_t), intent(in) :: phs_config integer, intent(in), optional :: unit call msg_message ("Phase space: none") end subroutine phs_none_config_startup_message @ %def phs_none_config_startup_message @ Allocate an instance: the actual phase-space object. <>= procedure, nopass :: allocate_instance => phs_none_config_allocate_instance <>= subroutine phs_none_config_allocate_instance (phs) class(phs_t), intent(inout), pointer :: phs allocate (phs_none_t :: phs) end subroutine phs_none_config_allocate_instance @ %def phs_none_config_allocate_instance @ \subsection{Kinematics implementation} This is considered as empty, but we have to implement the minimal set of methods. <>= public :: phs_none_t <>= type, extends (phs_t) :: phs_none_t contains <> end type phs_none_t @ %def phs_none_t @ Output. <>= procedure :: write => phs_none_write <>= subroutine phs_none_write (object, unit, verbose) class(phs_none_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit) write (u, "(A)") "Partonic phase space: none" end subroutine phs_none_write @ %def phs_none_write @ The finalizer is empty. <>= procedure :: final => phs_none_final <>= subroutine phs_none_final (object) class(phs_none_t), intent(inout) :: object end subroutine phs_none_final @ %def phs_none_final @ Initialization, trivial. <>= procedure :: init => phs_none_init <>= subroutine phs_none_init (phs, phs_config) class(phs_none_t), intent(out) :: phs class(phs_config_t), intent(in), target :: phs_config call phs%base_init (phs_config) end subroutine phs_none_init @ %def phs_none_init @ Evaluation. This must not be called at all. <>= procedure :: evaluate_selected_channel => phs_none_evaluate_selected_channel procedure :: evaluate_other_channels => phs_none_evaluate_other_channels <>= subroutine phs_none_evaluate_selected_channel (phs, c_in, r_in) class(phs_none_t), intent(inout) :: phs integer, intent(in) :: c_in real(default), intent(in), dimension(:) :: r_in call msg_fatal ("Phase space: attempt to evaluate with the 'phs_none' method") end subroutine phs_none_evaluate_selected_channel subroutine phs_none_evaluate_other_channels (phs, c_in) class(phs_none_t), intent(inout) :: phs integer, intent(in) :: c_in end subroutine phs_none_evaluate_other_channels @ %def phs_none_evaluate_selected_channel @ %def phs_none_evaluate_other_channels @ Inverse evaluation, likewise. <>= procedure :: inverse => phs_none_inverse <>= subroutine phs_none_inverse (phs) class(phs_none_t), intent(inout) :: phs call msg_fatal ("Phase space: attempt to evaluate inverse with the 'phs_none' method") end subroutine phs_none_inverse @ %def phs_none_inverse @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[phs_none_ut.f90]]>>= <> module phs_none_ut use unit_tests use phs_none_uti <> <> contains <> end module phs_none_ut @ %def phs_none_ut @ <<[[phs_none_uti.f90]]>>= <> module phs_none_uti <> <> use flavors use lorentz use model_data use process_constants use phs_base use phs_none use phs_base_ut, only: init_test_process_data, init_test_decay_data <> <> contains <> end module phs_none_uti @ %def phs_none_ut @ API: driver for the unit tests below. <>= public :: phs_none_test <>= subroutine phs_none_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine phs_none_test @ %def phs_none_test @ \subsubsection{Phase-space configuration data} Construct and display a test phase-space configuration object. Also check the [[azimuthal_dependence]] flag. <>= call test (phs_none_1, "phs_none_1", & "phase-space configuration dummy", & u, results) <>= public :: phs_none_1 <>= subroutine phs_none_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(process_constants_t) :: process_data class(phs_config_t), allocatable :: phs_data real(default) :: sqrts write (u, "(A)") "* Test output: phs_none_1" write (u, "(A)") "* Purpose: display & &phase-space configuration data" write (u, "(A)") allocate (phs_none_config_t :: phs_data) call phs_data%init (process_data, model) sqrts = 1000._default call phs_data%configure (sqrts, azimuthal_dependence=.false.) call phs_data%write (u) call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_none_1" end subroutine phs_none_1 @ %def phs_none_1 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \clearpage \section{Single-particle phase space} This module implements the phase space for a single particle, i.e., the solid angle, in a straightforward parameterization with a single channel. The phase-space implementation may be used either for $1\to 2$ decays or for $2\to 2$ scattering processes, so the number of incoming particles is the only free parameter in the configuration. In the latter case, we should restrict its use to non-resonant s-channel processes, because there is no mapping of the scattering angle. (We might extend this later to account for generic $2\to 2$ situations, e.g., account for a Coulomb singularity or detect an s-channel resonance structure that requires matching structure-function mappings.) This is derived from the [[phs_test]] implementation in the [[phs_base]] module above, even more simplified, but intended for actual use. <<[[phs_single.f90]]>>= <> module phs_single <> <> use io_units use constants use numeric_utils use diagnostics use os_interface use lorentz use physics_defs use model_data use flavors use process_constants use phs_base <> <> <> contains <> end module phs_single @ %def phs_single @ \subsection{Configuration} <>= public :: phs_single_config_t <>= type, extends (phs_config_t) :: phs_single_config_t contains <> end type phs_single_config_t @ %def phs_single_config_t @ The finalizer is empty. <>= procedure :: final => phs_single_config_final <>= subroutine phs_single_config_final (object) class(phs_single_config_t), intent(inout) :: object end subroutine phs_single_config_final @ %def phs_single_final @ Output. <>= procedure :: write => phs_single_config_write <>= subroutine phs_single_config_write (object, unit, include_id) class(phs_single_config_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: include_id integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Partonic phase-space configuration (single-particle):" call object%base_write (unit) end subroutine phs_single_config_write @ %def phs_single_config_write @ Configuration: there is only one channel and two parameters. The second parameter is the azimuthal angle, which may be a flat dimension. <>= procedure :: configure => phs_single_config_configure <>= subroutine phs_single_config_configure (phs_config, sqrts, & sqrts_fixed, cm_frame, azimuthal_dependence, rebuild, ignore_mismatch, & nlo_type, subdir) class(phs_single_config_t), intent(inout) :: phs_config real(default), intent(in) :: sqrts logical, intent(in), optional :: sqrts_fixed logical, intent(in), optional :: cm_frame logical, intent(in), optional :: azimuthal_dependence logical, intent(in), optional :: rebuild logical, intent(in), optional :: ignore_mismatch integer, intent(in), optional :: nlo_type type(string_t), intent(in), optional :: subdir if (.not. present (nlo_type)) & phs_config%nlo_type = BORN if (phs_config%n_out == 2) then phs_config%n_channel = 1 phs_config%n_par = 2 phs_config%sqrts = sqrts if (present (sqrts_fixed)) phs_config%sqrts_fixed = sqrts_fixed if (present (cm_frame)) phs_config%cm_frame = cm_frame if (present (azimuthal_dependence)) then phs_config%azimuthal_dependence = azimuthal_dependence if (.not. azimuthal_dependence) then allocate (phs_config%dim_flat (1)) phs_config%dim_flat(1) = 2 end if end if if (allocated (phs_config%channel)) deallocate (phs_config%channel) allocate (phs_config%channel (1)) call phs_config%compute_md5sum () else call msg_fatal ("Single-particle phase space requires n_out = 2") end if end subroutine phs_single_config_configure @ %def phs_single_config_configure @ Startup message, after configuration is complete. <>= procedure :: startup_message => phs_single_config_startup_message <>= subroutine phs_single_config_startup_message (phs_config, unit) class(phs_single_config_t), intent(in) :: phs_config integer, intent(in), optional :: unit call phs_config%base_startup_message (unit) write (msg_buffer, "(A,2(1x,I0,1x,A))") & "Phase space: single-particle" call msg_message (unit = unit) end subroutine phs_single_config_startup_message @ %def phs_single_config_startup_message @ Allocate an instance: the actual phase-space object. <>= procedure, nopass :: allocate_instance => phs_single_config_allocate_instance <>= subroutine phs_single_config_allocate_instance (phs) class(phs_t), intent(inout), pointer :: phs allocate (phs_single_t :: phs) end subroutine phs_single_config_allocate_instance @ %def phs_single_config_allocate_instance @ \subsection{Kinematics implementation} We generate $\cos\theta$ and $\phi$ uniformly, covering the solid angle. Note: The incoming momenta must be in the c.m. system. <>= public :: phs_single_t <>= type, extends (phs_t) :: phs_single_t contains <> end type phs_single_t @ %def phs_single_t @ Output. The [[verbose]] setting is irrelevant, we just display the contents of the base object. <>= procedure :: write => phs_single_write <>= subroutine phs_single_write (object, unit, verbose) class(phs_single_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit) call object%base_write (u) end subroutine phs_single_write @ %def phs_single_write @ The finalizer is empty. <>= procedure :: final => phs_single_final <>= subroutine phs_single_final (object) class(phs_single_t), intent(inout) :: object end subroutine phs_single_final @ %def phs_single_final @ Initialization. We allocate arrays ([[base_init]]) and adjust the phase-space volume. The massless two-particle phase space volume is \begin{equation} \Phi_2 = \frac{1}{4(2\pi)^5} = 2.55294034614 \times 10^{-5} \end{equation} For a decay with nonvanishing masses ($m_3$, $m_4$), there is a correction factor \begin{equation} \Phi_2(m) / \Phi_2(0) = \frac{1}{\hat s} \lambda^{1/2}(\hat s, m_3^2, m_4^2). \end{equation} For a scattering process with nonvanishing masses, the correction factor is \begin{equation} \Phi_2(m) / \Phi_2(0) = \frac{1}{\hat s ^ 2} \lambda^{1/2}(\hat s, m_1^2, m_2^2)\, \lambda^{1/2}(\hat s, m_3^2, m_4^2). \end{equation} If the energy is fixed, this is constant. Otherwise, we have to account for varying $\hat s$. <>= procedure :: init => phs_single_init <>= subroutine phs_single_init (phs, phs_config) class(phs_single_t), intent(out) :: phs class(phs_config_t), intent(in), target :: phs_config call phs%base_init (phs_config) phs%volume = 1 / (4 * twopi5) call phs%compute_factor () end subroutine phs_single_init @ %def phs_single_init @ Compute the correction factor for nonzero masses. We do this during initialization (when the incoming momenta [[p]] are undefined), unless [[sqrts]] is variable. We do this again once for each phase-space point, but then we skip the calculation if [[sqrts]] is fixed. <>= procedure :: compute_factor => phs_single_compute_factor <>= subroutine phs_single_compute_factor (phs) class(phs_single_t), intent(inout) :: phs real(default) :: s_hat select case (phs%config%n_in) case (1) if (.not. phs%p_defined) then if (sum (phs%m_out) < phs%m_in(1)) then s_hat = phs%m_in(1) ** 2 phs%f(1) = 1 / s_hat & * sqrt (lambda (s_hat, phs%m_out(1)**2, phs%m_out(2)**2)) else print *, "m_in = ", phs%m_in print *, "m_out = ", phs%m_out call msg_fatal ("Decay is kinematically forbidden") end if end if case (2) if (phs%config%sqrts_fixed) then if (phs%p_defined) return s_hat = phs%config%sqrts ** 2 else if (.not. phs%p_defined) return s_hat = sum (phs%p) ** 2 end if if (sum (phs%m_in)**2 < s_hat .and. sum (phs%m_out)**2 < s_hat) then phs%f(1) = 1 / s_hat * & ( lambda (s_hat, phs%m_in (1)**2, phs%m_in (2)**2) & * lambda (s_hat, phs%m_out(1)**2, phs%m_out(2)**2) ) & ** 0.25_default else phs%f(1) = 0 end if end select end subroutine phs_single_compute_factor @ %def phs_single_compute_factor @ Evaluation. We uniformly generate $\cos\theta$ and $\phi$, with Jacobian normalized to one. There is only a single channel, so the second subroutine does nothing. Note: the current implementation works for elastic scattering only. <>= procedure :: evaluate_selected_channel => phs_single_evaluate_selected_channel procedure :: evaluate_other_channels => phs_single_evaluate_other_channels <>= subroutine phs_single_evaluate_selected_channel (phs, c_in, r_in) class(phs_single_t), intent(inout) :: phs integer, intent(in) :: c_in real(default), intent(in), dimension(:) :: r_in !!! !!! !!! Catching a gfortran bogus warning type(vector4_t), dimension(2) :: p_dum if (phs%p_defined) then call phs%select_channel (c_in) phs%r(:,c_in) = r_in select case (phs%config%n_in) case (2) if (all (phs%m_in == phs%m_out)) then call compute_kinematics_solid_angle (phs%p, phs%q, r_in) else call msg_bug ("PHS single: inelastic scattering not implemented") end if case (1) !!! !!! !!! Catching a gfortran bogus warning !!! call compute_kinematics_solid_angle (phs%decay_p (), phs%q, x) p_dum = phs%decay_p () call compute_kinematics_solid_angle (p_dum, phs%q, r_in) end select call phs%compute_factor () phs%q_defined = .true. phs%r_defined = .true. end if end subroutine phs_single_evaluate_selected_channel subroutine phs_single_evaluate_other_channels (phs, c_in) class(phs_single_t), intent(inout) :: phs integer, intent(in) :: c_in end subroutine phs_single_evaluate_other_channels @ %def phs_single_evaluate_selected_channel @ %def phs_single_evaluate_other_channels @ Auxiliary: split a decaying particle at rest into the decay products, aligned along the $z$ axis. <>= procedure :: decay_p => phs_single_decay_p <>= function phs_single_decay_p (phs) result (p) class(phs_single_t), intent(in) :: phs type(vector4_t), dimension(2) :: p real(default) :: k real(default), dimension(2) :: E k = sqrt (lambda (phs%m_in(1) ** 2, phs%m_out(1) ** 2, phs%m_out(2) ** 2)) & / (2 * phs%m_in(1)) E = sqrt (phs%m_out ** 2 + k ** 2) p(1) = vector4_moving (E(1), k, 3) p(2) = vector4_moving (E(2),-k, 3) end function phs_single_decay_p @ %def phs_single_decay_p @ Inverse evaluation. <>= procedure :: inverse => phs_single_inverse <>= subroutine phs_single_inverse (phs) class(phs_single_t), intent(inout) :: phs real(default), dimension(:), allocatable :: x if (phs%p_defined .and. phs%q_defined) then call phs%select_channel () allocate (x (phs%config%n_par)) call inverse_kinematics_solid_angle (phs%p, phs%q, x) phs%r(:,1) = x call phs%compute_factor () phs%r_defined = .true. end if end subroutine phs_single_inverse @ %def phs_single_inverse @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[phs_single_ut.f90]]>>= <> module phs_single_ut use unit_tests use phs_single_uti <> <> contains <> end module phs_single_ut @ %def phs_single_ut @ <<[[phs_single_uti.f90]]>>= <> module phs_single_uti <> <> use flavors use lorentz use model_data use process_constants use phs_base use phs_single use phs_base_ut, only: init_test_process_data, init_test_decay_data <> <> contains <> end module phs_single_uti @ %def phs_single_ut @ API: driver for the unit tests below. <>= public :: phs_single_test <>= subroutine phs_single_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine phs_single_test @ %def phs_single_test @ \subsubsection{Phase-space configuration data} Construct and display a test phase-space configuration object. Also check the [[azimuthal_dependence]] flag. <>= call test (phs_single_1, "phs_single_1", & "phase-space configuration", & u, results) <>= public :: phs_single_1 <>= subroutine phs_single_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(process_constants_t) :: process_data class(phs_config_t), allocatable :: phs_data real(default) :: sqrts write (u, "(A)") "* Test output: phs_single_1" write (u, "(A)") "* Purpose: initialize and display & &phase-space configuration data" write (u, "(A)") call model%init_test () write (u, "(A)") "* Initialize a process and a matching & &phase-space configuration" write (u, "(A)") call init_test_process_data (var_str ("phs_single_1"), process_data) allocate (phs_single_config_t :: phs_data) call phs_data%init (process_data, model) sqrts = 1000._default call phs_data%configure (sqrts, azimuthal_dependence=.false.) call phs_data%write (u) call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_single_1" end subroutine phs_single_1 @ %def phs_single_1 @ \subsubsection{Phase space evaluation} Compute kinematics for given parameters, also invert the calculation. <>= call test (phs_single_2, "phs_single_2", & "phase-space evaluation", & u, results) <>= public :: phs_single_2 <>= subroutine phs_single_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(process_constants_t) :: process_data real(default) :: sqrts, E class(phs_config_t), allocatable, target :: phs_data class(phs_t), pointer :: phs => null () type(vector4_t), dimension(2) :: p, q write (u, "(A)") "* Test output: phs_single_2" write (u, "(A)") "* Purpose: test simple two-channel phase space" write (u, "(A)") call model%init_test () call flv%init (25, model) write (u, "(A)") "* Initialize a process and a matching & &phase-space configuration" write (u, "(A)") call init_test_process_data (var_str ("phs_single_2"), process_data) allocate (phs_single_config_t :: phs_data) call phs_data%init (process_data, model) sqrts = 1000._default call phs_data%configure (sqrts) call phs_data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize the phase-space instance" write (u, "(A)") call phs_data%allocate_instance (phs) call phs%init (phs_data) call phs%write (u, verbose=.true.) write (u, "(A)") write (u, "(A)") "* Set incoming momenta" write (u, "(A)") E = sqrts / 2 p(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) p(2) = vector4_moving (E,-sqrt (E**2 - flv%get_mass ()**2), 3) call phs%set_incoming_momenta (p) call phs%compute_flux () call phs%write (u) write (u, "(A)") write (u, "(A)") "* Compute phase-space point & &for x = 0.5, 0.125" write (u, "(A)") call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default]) call phs%evaluate_other_channels (1) call phs%write (u) write (u, "(A)") write (u, "(A)") "* Inverse kinematics" write (u, "(A)") call phs%get_outgoing_momenta (q) deallocate (phs) call phs_data%allocate_instance (phs) call phs%init (phs_data) sqrts = 1000._default call phs_data%configure (sqrts) call phs%set_incoming_momenta (p) call phs%compute_flux () call phs%set_outgoing_momenta (q) call phs%inverse () call phs%write (u) call phs%final () deallocate (phs) call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_single_2" end subroutine phs_single_2 @ %def phs_single_2 @ \subsubsection{Phase space for non-c.m. system} Compute kinematics for given parameters, also invert the calculation. Since this will involve cancellations, we call [[pacify]] to eliminate numerical noise. <>= call test (phs_single_3, "phs_single_3", & "phase-space evaluation in lab frame", & u, results) <>= public :: phs_single_3 <>= subroutine phs_single_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(process_constants_t) :: process_data real(default) :: sqrts, E class(phs_config_t), allocatable, target :: phs_data class(phs_t), pointer :: phs => null () type(vector4_t), dimension(2) :: p, q type(lorentz_transformation_t) :: lt write (u, "(A)") "* Test output: phs_single_3" write (u, "(A)") "* Purpose: test simple two-channel phase space" write (u, "(A)") "* without c.m. kinematics assumption" write (u, "(A)") call model%init_test () call flv%init (25, model) write (u, "(A)") "* Initialize a process and a matching & &phase-space configuration" write (u, "(A)") call init_test_process_data (var_str ("phs_single_3"), process_data) allocate (phs_single_config_t :: phs_data) call phs_data%init (process_data, model) sqrts = 1000._default call phs_data%configure (sqrts, cm_frame=.false., sqrts_fixed=.false.) call phs_data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize the phase-space instance" write (u, "(A)") call phs_data%allocate_instance (phs) call phs%init (phs_data) call phs%write (u, verbose=.true.) write (u, "(A)") write (u, "(A)") "* Set incoming momenta in lab system" write (u, "(A)") lt = boost (0.1_default, 1) * boost (0.3_default, 3) E = sqrts / 2 p(1) = lt * vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) p(2) = lt * vector4_moving (E,-sqrt (E**2 - flv%get_mass ()**2), 3) call vector4_write (p(1), u) call vector4_write (p(2), u) write (u, "(A)") write (u, "(A)") "* Compute phase-space point & &for x = 0.5, 0.125" write (u, "(A)") call phs%set_incoming_momenta (p) call phs%compute_flux () call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default]) call phs%evaluate_other_channels (1) call pacify (phs) call phs%write (u) write (u, "(A)") write (u, "(A)") "* Extract outgoing momenta in lab system" write (u, "(A)") call phs%get_outgoing_momenta (q) call vector4_write (q(1), u) call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "* Inverse kinematics" write (u, "(A)") deallocate (phs) call phs_data%allocate_instance (phs) call phs%init (phs_data) sqrts = 1000._default call phs_data%configure (sqrts) call phs%set_incoming_momenta (p) call phs%compute_flux () call phs%set_outgoing_momenta (q) call phs%inverse () call pacify (phs) call phs%write (u) call phs%final () deallocate (phs) call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_single_3" end subroutine phs_single_3 @ %def phs_single_3 @ \subsubsection{Decay Phase space evaluation} Compute kinematics for given parameters, also invert the calculation. This time, implement a decay process. <>= call test (phs_single_4, "phs_single_4", & "decay phase-space evaluation", & u, results) <>= public :: phs_single_4 <>= subroutine phs_single_4 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(process_constants_t) :: process_data class(phs_config_t), allocatable, target :: phs_data class(phs_t), pointer :: phs => null () type(vector4_t), dimension(1) :: p type(vector4_t), dimension(2) :: q write (u, "(A)") "* Test output: phs_single_4" write (u, "(A)") "* Purpose: test simple two-channel phase space" write (u, "(A)") call model%init_test () call model%set_par (var_str ("ff"), 0.4_default) call model%set_par (var_str ("mf"), & model%get_real (var_str ("ff")) * model%get_real (var_str ("ms"))) call flv%init (25, model) write (u, "(A)") "* Initialize a decay and a matching & &phase-space configuration" write (u, "(A)") call init_test_decay_data (var_str ("phs_single_4"), process_data) allocate (phs_single_config_t :: phs_data) call phs_data%init (process_data, model) call phs_data%configure (flv%get_mass ()) call phs_data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize the phase-space instance" write (u, "(A)") call phs_data%allocate_instance (phs) call phs%init (phs_data) call phs%write (u, verbose=.true.) write (u, "(A)") write (u, "(A)") "* Set incoming momenta" write (u, "(A)") p(1) = vector4_at_rest (flv%get_mass ()) call phs%set_incoming_momenta (p) call phs%compute_flux () call phs%write (u) write (u, "(A)") write (u, "(A)") "* Compute phase-space point & &for x = 0.5, 0.125" write (u, "(A)") call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default]) call phs%evaluate_other_channels (1) call phs%write (u) write (u, "(A)") write (u, "(A)") "* Inverse kinematics" write (u, "(A)") call phs%get_outgoing_momenta (q) deallocate (phs) call phs_data%allocate_instance (phs) call phs%init (phs_data) call phs_data%configure (flv%get_mass ()) call phs%set_incoming_momenta (p) call phs%compute_flux () call phs%set_outgoing_momenta (q) call phs%inverse () call phs%write (u) call phs%final () deallocate (phs) call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_single_4" end subroutine phs_single_4 @ %def phs_single_4 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Flat RAMBO phase space} This module implements the flat \texttt{RAMBO} phase space for massless and massive particles using the minimal d.o.f $3n - 4$ in a straightforward parameterization with a single channel. We generate $n$ mass systems $M_i$ with $M_0 = \sqrt{s}$ and $M_{n} = 0$. We let each mass system decay $1 \rightarrow 2$ in a four-momentum conserving way. The four-momenta of the two particles are generated back-to-back where we map the d.o.f. to energy, azimuthal and polar angle. The particle momenta are then boosted to CMS by an appriopriate boost using the kinematics of the parent mass system. <<[[phs_rambo.f90]]>>= <> module phs_rambo <> <> use io_units use constants use numeric_utils use format_defs, only: FMT_19 use permutations, only: factorial use diagnostics use os_interface use lorentz use physics_defs use model_data use flavors use process_constants use phs_base <> <> <> <> contains <> end module phs_rambo @ %def phs_rambo @ \subsection{Configuration} <>= public :: phs_rambo_config_t <>= type, extends (phs_config_t) :: phs_rambo_config_t contains <> end type phs_rambo_config_t @ %def phs_rambo_config_t @ The finalizer is empty. <>= procedure :: final => phs_rambo_config_final <>= subroutine phs_rambo_config_final (object) class(phs_rambo_config_t), intent(inout) :: object end subroutine phs_rambo_config_final @ %def phs_rambo_final @ Output. <>= procedure :: write => phs_rambo_config_write <>= subroutine phs_rambo_config_write (object, unit, include_id) class(phs_rambo_config_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: include_id integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Partonic, flat phase-space configuration (RAMBO):" call object%base_write (unit) end subroutine phs_rambo_config_write @ %def phs_rambo_config_write @ Configuration: there is only one channel and $3n - 4$ parameters. <>= procedure :: configure => phs_rambo_config_configure <>= subroutine phs_rambo_config_configure (phs_config, sqrts, & sqrts_fixed, cm_frame, azimuthal_dependence, rebuild, ignore_mismatch, & nlo_type, subdir) class(phs_rambo_config_t), intent(inout) :: phs_config real(default), intent(in) :: sqrts logical, intent(in), optional :: sqrts_fixed logical, intent(in), optional :: cm_frame logical, intent(in), optional :: azimuthal_dependence logical, intent(in), optional :: rebuild logical, intent(in), optional :: ignore_mismatch integer, intent(in), optional :: nlo_type type(string_t), intent(in), optional :: subdir if (.not. present (nlo_type)) & phs_config%nlo_type = BORN if (phs_config%n_out < 2) then call msg_fatal ("RAMBO phase space requires n_out >= 2") end if phs_config%n_channel = 1 phs_config%n_par = 3 * phs_config%n_out - 4 phs_config%sqrts = sqrts if (present (sqrts_fixed)) phs_config%sqrts_fixed = sqrts_fixed if (present (cm_frame)) phs_config%cm_frame = cm_frame if (allocated (phs_config%channel)) deallocate (phs_config%channel) allocate (phs_config%channel (1)) call phs_config%compute_md5sum () end subroutine phs_rambo_config_configure @ %def phs_rambo_config_configure @ Startup message, after configuration is complete. <>= procedure :: startup_message => phs_rambo_config_startup_message <>= subroutine phs_rambo_config_startup_message (phs_config, unit) class(phs_rambo_config_t), intent(in) :: phs_config integer, intent(in), optional :: unit call phs_config%base_startup_message (unit) write (msg_buffer, "(A,2(1x,I0,1x,A))") & "Phase space: flat (RAMBO)" call msg_message (unit = unit) end subroutine phs_rambo_config_startup_message @ %def phs_rambo_config_startup_message @ Allocate an instance: the actual phase-space object. <>= procedure, nopass :: allocate_instance => phs_rambo_config_allocate_instance <>= subroutine phs_rambo_config_allocate_instance (phs) class(phs_t), intent(inout), pointer :: phs allocate (phs_rambo_t :: phs) end subroutine phs_rambo_config_allocate_instance @ %def phs_rambo_config_allocate_instance @ \subsection{Kinematics implementation} We generate $n - 2$ mass systems $M_i$ with $M_0 = \sqrt{s}$ and $M_n = 0$... Note: The incoming momenta must be in the c.m. system. <>= public :: phs_rambo_t <>= type, extends (phs_t) :: phs_rambo_t real(default), dimension(:), allocatable :: k real(default), dimension(:), allocatable :: m contains <> end type phs_rambo_t @ %def phs_rambo_t @ Output. <>= procedure :: write => phs_rambo_write <>= subroutine phs_rambo_write (object, unit, verbose) class(phs_rambo_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit) call object%base_write (u) write (u, "(1X,A)") "Intermediate masses (massless):" write (u, "(3X,999(" // FMT_19 // "))") object%k write (u, "(1X,A)") "Intermediate masses (massive):" write (u, "(3X,999(" // FMT_19 // "))") object%m end subroutine phs_rambo_write @ %def phs_rambo_write @ The finalizer is empty. <>= procedure :: final => phs_rambo_final <>= subroutine phs_rambo_final (object) class(phs_rambo_t), intent(inout) :: object end subroutine phs_rambo_final @ %def phs_rambo_final @ Initialization. We allocate arrays ([[base_init]]) and adjust the phase-space volume. The energy dependent factor of $s^{n - 2}$ is applied later. <>= procedure :: init => phs_rambo_init <>= subroutine phs_rambo_init (phs, phs_config) class(phs_rambo_t), intent(out) :: phs class(phs_config_t), intent(in), target :: phs_config call phs%base_init (phs_config) associate (n => phs%config%n_out) select case (n) case (1) if (sum (phs%m_out) > phs%m_in (1)) then print *, "m_in = ", phs%m_in print *, "m_out = ", phs%m_out call msg_fatal ("[phs_rambo_init] Decay is kinematically forbidden.") end if end select allocate (phs%k(n), source = 0._default) allocate (phs%m(n), source = 0._default) phs%volume = 1. / (twopi)**(3 * n) & * (pi / 2.)**(n - 1) / (factorial(n - 1) * factorial(n - 2)) end associate end subroutine phs_rambo_init @ %def phs_rambo_init @ Evaluation. There is only one channel for RAMBO, so the second subroutine does nothing. Note: the current implementation works for elastic scattering only. <>= procedure :: evaluate_selected_channel => phs_rambo_evaluate_selected_channel procedure :: evaluate_other_channels => phs_rambo_evaluate_other_channels <>= subroutine phs_rambo_evaluate_selected_channel (phs, c_in, r_in) class(phs_rambo_t), intent(inout) :: phs integer, intent(in) :: c_in real(default), intent(in), dimension(:) :: r_in type(vector4_t), dimension(2) :: p_rest, p_boosted type(vector4_t) :: q real(default), dimension(2) :: r_angle integer :: i if (.not. phs%p_defined) return call phs%select_channel (c_in) phs%r(:,c_in) = r_in associate (n => phs%config%n_out, m => phs%m) call phs%generate_intermediates (r_in(:n - 2)) q = sum (phs%p) do i = 2, n r_angle(1) = r_in(n - 5 + 2 * i) r_angle(2) = r_in(n - 4 + 2 * i) call phs%decay_intermediate (i, r_angle, p_rest) p_boosted = boost(q, m(i - 1)) * p_rest q = p_boosted(1) phs%q(i - 1) = p_boosted(2) end do phs%q(n) = q end associate phs%q_defined = .true. phs%r_defined = .true. end subroutine phs_rambo_evaluate_selected_channel subroutine phs_rambo_evaluate_other_channels (phs, c_in) class(phs_rambo_t), intent(inout) :: phs integer, intent(in) :: c_in end subroutine phs_rambo_evaluate_other_channels @ %def phs_rambo_evaluate_selected_channel @ %def phs_rambo_evaluate_other_channels @ Decay intermediate mass system $M_{i - 1}$ into a on-shell particle with mass $m_{i - 1}$ and subsequent intermediate mass system with fixed $M_i$. <>= procedure, private :: decay_intermediate => phs_rambo_decay_intermediate <>= subroutine phs_rambo_decay_intermediate (phs, i, r_angle, p) class(phs_rambo_t), intent(in) :: phs integer, intent(in) :: i real(default), dimension(2), intent(in) :: r_angle type(vector4_t), dimension(2), intent(out) :: p real(default) :: k_abs, cos_theta, phi type(vector3_t):: k real(default), dimension(2) :: E cos_theta = 2. * r_angle(1) - 1. phi = twopi * r_angle(2) if (phi > pi) phi = phi - twopi k_abs = sqrt (lambda (phs%m(i - 1)**2, phs%m(i)**2, phs%m_out(i - 1)**2)) & / (2. * phs%m(i - 1)) k = k_abs * [cos(phi) * sqrt(1. - cos_theta**2), & sin(phi) * sqrt(1. - cos_theta**2), cos_theta] E(1) = sqrt (phs%m(i)**2 + k_abs**2) E(2) = sqrt (phs%m_out(i - 1)**2 + k_abs**2) p(1) = vector4_moving (E(1), -k) p(2) = vector4_moving (E(2), k) end subroutine phs_rambo_decay_intermediate @ %def phs_rambo_decay_intermediate @ Generate intermediate masses. <>= integer, parameter :: BISECT_MAX_ITERATIONS = 1000 real(default), parameter :: BISECT_MIN_PRECISION = tiny_10 <>= procedure, private :: generate_intermediates => phs_rambo_generate_intermediates procedure, private :: invert_intermediates => phs_rambo_invert_intermediates <>= subroutine phs_rambo_generate_intermediates (phs, r) class(phs_rambo_t), intent(inout) :: phs real(default), dimension(:), intent(in) :: r integer :: i, j associate (n => phs%config%n_out, k => phs%k, m => phs%m) m(1) = invariant_mass (sum (phs%p)) m(n) = phs%m_out (n) call calculate_k (r) do i = 2, n - 1 m(i) = k(i) + sum (phs%m_out (i:n)) end do ! Massless volume times reweighting for massive volume phs%f(1) = k(1)**(2 * n - 4) & * 8. * rho(m(n - 1), phs%m_out(n), phs%m_out(n - 1)) do i = 2, n - 1 phs%f(1) = phs%f(1) * & rho(m(i - 1), m(i), phs%m_out(i - 1)) / & rho(k(i - 1), k(i), 0._default) * & M(i) / K(i) end do end associate contains subroutine calculate_k (r) real(default), dimension(:), intent(in) :: r real(default), dimension(:), allocatable :: u integer :: i associate (n => phs%config%n_out, k => phs%k, m => phs%m) k = 0 k(1) = m(1) - sum(phs%m_out(1:n)) allocate (u(2:n - 1), source=0._default) call solve_for_u (r, u) do i = 2, n - 1 k(i) = sqrt (u(i) * k(i - 1)**2) end do end associate end subroutine calculate_k subroutine solve_for_u (r, u) real(default), dimension(phs%config%n_out - 2), intent(in) :: r real(default), dimension(2:phs%config%n_out - 1), intent(out) :: u integer :: i, j real(default) :: f, f_mid, xl, xr, xmid associate (n => phs%config%n_out) do i = 2, n - 1 xl = 0 xr = 1 if (r(i - 1) == 1 .or. r(i - 1) == 0) then u(i) = r(i - 1) else do j = 1, BISECT_MAX_ITERATIONS xmid = (xl + xr) / 2. f = f_rambo (xl, n - i) - r(i - 1) f_mid = f_rambo (xmid, n - i) - r(i - 1) if (f * f_mid > 0) then xl = xmid else xr = xmid end if if (abs(xl - xr) < BISECT_MIN_PRECISION) exit end do u(i) = xmid end if end do end associate end subroutine solve_for_u real(default) function f_rambo(u, n) real(default), intent(in) :: u integer, intent(in) :: n f_rambo = (n + 1) * u**n - n * u**(n + 1) end function f_rambo real(default) function rho (M1, M2, m) real(default), intent(in) :: M1, M2, m real(default) :: MP, MM rho = sqrt ((M1**2 - (M2 + m)**2) * (M1**2 - (M2 - m)**2)) ! MP = (M1 - (M2 + m)) * (M1 + (M2 + m)) ! MM = (M1 - (M2 - m)) * (M1 + (M2 - m)) ! rho = sqrt (MP) * sqrt (MM) rho = rho / (8._default * M1**2) end function rho end subroutine phs_rambo_generate_intermediates subroutine phs_rambo_invert_intermediates (phs) class(phs_rambo_t), intent(inout) :: phs real(default) :: u integer :: i associate (n => phs%config%n_out, k => phs%k, m => phs%m) k = m do i = 1, n - 1 k(i) = k(i) - sum (phs%m_out(i:n)) end do do i = 2, n - 1 u = (k(i) / k(i - 1))**2 phs%r(i - 1, 1) = (n + 1 - i) * u**(n - i) & - (n - i) * u**(n + 1 - i) end do end associate end subroutine phs_rambo_invert_intermediates @ %def phs_rambo_generate_intermediates @ Inverse evaluation. <>= procedure :: inverse => phs_rambo_inverse <>= subroutine phs_rambo_inverse (phs) class(phs_rambo_t), intent(inout) :: phs type(vector4_t), dimension(:), allocatable :: q type(vector4_t) :: p type(lorentz_transformation_t) :: L real(default) :: phi, cos_theta integer :: i if (.not. (phs%p_defined .and. phs%q_defined)) return call phs%select_channel () associate (n => phs%config%n_out, m => phs%m) allocate(q(n)) m(1) = invariant_mass (sum (phs%p)) q(1) = vector4_at_rest (m(1)) q(n) = phs%q(n) do i = 2, n - 1 q(i) = q(i) + sum (phs%q(i:n)) m(i) = invariant_mass (q(i)) end do call phs%invert_intermediates () do i = 2, n L = inverse (boost (q(i - 1), m(i - 1))) p = L * phs%q(i - 1) phi = azimuthal_angle (p); cos_theta = polar_angle_ct (p) phs%r(n - 5 + 2 * i, 1) = (cos_theta + 1.) / 2. phs%r(n - 4 + 2 * i, 1) = phi / twopi end do end associate phs%r_defined = .true. end subroutine phs_rambo_inverse @ %def phs_rambo_inverse @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[phs_rambo_ut.f90]]>>= <> module phs_rambo_ut use unit_tests use phs_rambo_uti <> <> contains <> end module phs_rambo_ut @ %def phs_rambo_ut @ <<[[phs_rambo_uti.f90]]>>= <> module phs_rambo_uti <> <> use flavors use lorentz use model_data use process_constants use phs_base use phs_rambo use phs_base_ut, only: init_test_process_data, init_test_decay_data <> <> contains <> end module phs_rambo_uti @ %def phs_rambo_ut @ API: driver for the unit tests below. <>= public :: phs_rambo_test <>= subroutine phs_rambo_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine phs_rambo_test @ %def phs_rambo_test @ \subsubsection{Phase-space configuration data} Construct and display a test phase-space configuration object. Also check the [[azimuthal_dependence]] flag. <>= call test (phs_rambo_1, "phs_rambo_1", & "phase-space configuration", & u, results) <>= public :: phs_rambo_1 <>= subroutine phs_rambo_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(process_constants_t) :: process_data class(phs_config_t), allocatable :: phs_data real(default) :: sqrts write (u, "(A)") "* Test output: phs_rambo_1" write (u, "(A)") "* Purpose: initialize and display & &phase-space configuration data" write (u, "(A)") call model%init_test () write (u, "(A)") "* Initialize a process and a matching & &phase-space configuration" write (u, "(A)") call init_test_process_data (var_str ("phs_rambo_1"), process_data) allocate (phs_rambo_config_t :: phs_data) call phs_data%init (process_data, model) sqrts = 1000._default call phs_data%configure (sqrts) call phs_data%write (u) call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_rambo_1" end subroutine phs_rambo_1 @ %def phs_rambo_1 @ \subsubsection{Phase space evaluation} Compute kinematics for given parameters, also invert the calculation. <>= call test (phs_rambo_2, "phs_rambo_2", & "phase-space evaluation", & u, results) <>= public :: phs_rambo_2 <>= subroutine phs_rambo_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(process_constants_t) :: process_data real(default) :: sqrts, E class(phs_config_t), allocatable, target :: phs_data class(phs_t), pointer :: phs => null () type(vector4_t), dimension(2) :: p, q write (u, "(A)") "* Test output: phs_rambo_2" write (u, "(A)") "* Purpose: test simple two-channel phase space" write (u, "(A)") call model%init_test () call flv%init (25, model) write (u, "(A)") "* Initialize a process and a matching & &phase-space configuration" write (u, "(A)") call init_test_process_data (var_str ("phs_rambo_2"), process_data) allocate (phs_rambo_config_t :: phs_data) call phs_data%init (process_data, model) sqrts = 1000._default call phs_data%configure (sqrts) call phs_data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize the phase-space instance" write (u, "(A)") call phs_data%allocate_instance (phs) call phs%init (phs_data) call phs%write (u, verbose=.true.) write (u, "(A)") write (u, "(A)") "* Set incoming momenta" write (u, "(A)") E = sqrts / 2 p(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) p(2) = vector4_moving (E,-sqrt (E**2 - flv%get_mass ()**2), 3) call phs%set_incoming_momenta (p) call phs%compute_flux () call phs%write (u) write (u, "(A)") write (u, "(A)") "* Compute phase-space point & &for x = 0.5, 0.125" write (u, "(A)") call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default]) call phs%evaluate_other_channels (1) call phs%write (u) write (u, "(A)") write (u, "(A)") "* Inverse kinematics" write (u, "(A)") call phs%get_outgoing_momenta (q) deallocate (phs) call phs_data%allocate_instance (phs) call phs%init (phs_data) sqrts = 1000._default call phs_data%configure (sqrts) call phs%set_incoming_momenta (p) call phs%compute_flux () call phs%set_outgoing_momenta (q) call phs%inverse () call phs%write (u) call phs%final () deallocate (phs) call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_rambo_2" end subroutine phs_rambo_2 @ %def phs_rambo_2 @ \subsubsection{Phase space for non-c.m. system} Compute kinematics for given parameters, also invert the calculation. Since this will involve cancellations, we call [[pacify]] to eliminate numerical noise. <>= call test (phs_rambo_3, "phs_rambo_3", & "phase-space evaluation in lab frame", & u, results) <>= public :: phs_rambo_3 <>= subroutine phs_rambo_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(process_constants_t) :: process_data real(default) :: sqrts, E class(phs_config_t), allocatable, target :: phs_data class(phs_t), pointer :: phs => null () type(vector4_t), dimension(2) :: p, q type(lorentz_transformation_t) :: lt write (u, "(A)") "* Test output: phs_rambo_3" write (u, "(A)") "* Purpose: phase-space evaluation in lab frame" write (u, "(A)") call model%init_test () call flv%init (25, model) write (u, "(A)") "* Initialize a process and a matching & &phase-space configuration" write (u, "(A)") call init_test_process_data (var_str ("phs_rambo_3"), process_data) allocate (phs_rambo_config_t :: phs_data) call phs_data%init (process_data, model) sqrts = 1000._default call phs_data%configure (sqrts, cm_frame=.false., sqrts_fixed=.false.) call phs_data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize the phase-space instance" write (u, "(A)") call phs_data%allocate_instance (phs) call phs%init (phs_data) call phs%write (u, verbose=.true.) write (u, "(A)") write (u, "(A)") "* Set incoming momenta in lab system" write (u, "(A)") lt = boost (0.1_default, 1) * boost (0.3_default, 3) E = sqrts / 2 p(1) = lt * vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) p(2) = lt * vector4_moving (E,-sqrt (E**2 - flv%get_mass ()**2), 3) call vector4_write (p(1), u) call vector4_write (p(2), u) write (u, "(A)") write (u, "(A)") "* Compute phase-space point & &for x = 0.5, 0.125" write (u, "(A)") call phs%set_incoming_momenta (p) call phs%compute_flux () call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default]) call phs%evaluate_other_channels (1) call pacify (phs) call phs%write (u) write (u, "(A)") write (u, "(A)") "* Extract outgoing momenta in lab system" write (u, "(A)") call phs%get_outgoing_momenta (q) call vector4_write (q(1), u) call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "* Inverse kinematics" write (u, "(A)") deallocate (phs) call phs_data%allocate_instance (phs) call phs%init (phs_data) sqrts = 1000._default call phs_data%configure (sqrts) call phs%set_incoming_momenta (p) call phs%compute_flux () call phs%set_outgoing_momenta (q) call phs%inverse () call pacify (phs) call phs%write (u) call phs%final () deallocate (phs) call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_rambo_3" end subroutine phs_rambo_3 @ %def phs_rambo_3 @ \subsubsection{Decay Phase space evaluation} Compute kinematics for given parameters, also invert the calculation. This time, implement a decay process. <>= call test (phs_rambo_4, "phs_rambo_4", & "decay phase-space evaluation", & u, results) <>= public :: phs_rambo_4 <>= subroutine phs_rambo_4 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(process_constants_t) :: process_data class(phs_config_t), allocatable, target :: phs_data class(phs_t), pointer :: phs => null () type(vector4_t), dimension(1) :: p type(vector4_t), dimension(2) :: q write (u, "(A)") "* Test output: phs_rambo_4" write (u, "(A)") "* Purpose: test simple two-channel phase space" write (u, "(A)") call model%init_test () call model%set_par (var_str ("ff"), 0.4_default) call model%set_par (var_str ("mf"), & model%get_real (var_str ("ff")) * model%get_real (var_str ("ms"))) call flv%init (25, model) write (u, "(A)") "* Initialize a decay and a matching & &phase-space configuration" write (u, "(A)") call init_test_decay_data (var_str ("phs_rambo_4"), process_data) allocate (phs_rambo_config_t :: phs_data) call phs_data%init (process_data, model) call phs_data%configure (flv%get_mass ()) call phs_data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize the phase-space instance" write (u, "(A)") call phs_data%allocate_instance (phs) call phs%init (phs_data) call phs%write (u, verbose=.true.) write (u, "(A)") write (u, "(A)") "* Set incoming momenta" write (u, "(A)") p(1) = vector4_at_rest (flv%get_mass ()) call phs%set_incoming_momenta (p) call phs%compute_flux () call phs%write (u) write (u, "(A)") write (u, "(A)") "* Compute phase-space point & &for x = 0.5, 0.125" write (u, "(A)") call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default]) call phs%evaluate_other_channels (1) call phs%write (u) write (u, "(A)") write (u, "(A)") "* Inverse kinematics" write (u, "(A)") call phs%get_outgoing_momenta (q) deallocate (phs) call phs_data%allocate_instance (phs) call phs%init (phs_data) call phs_data%configure (flv%get_mass ()) call phs%set_incoming_momenta (p) call phs%compute_flux () call phs%set_outgoing_momenta (q) call phs%inverse () call phs%write (u) call phs%final () deallocate (phs) call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_rambo_4" end subroutine phs_rambo_4 @ %def phs_rambo_4 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Resonance Handler} For various purposes (e.g., shower histories), we should extract the set of resonances and resonant channels from a phase-space tree set. A few methods do kinematics calculations specifically for those resonance data. <<[[resonances.f90]]>>= <> module resonances <> <> use string_utils, only: str use format_utils, only: write_indent use io_units use diagnostics use lorentz use constants, only: one use model_data, only: model_data_t use flavors, only: flavor_t <> <> <> <> contains <> end module resonances @ %def resonances @ \subsection{Decay products (contributors)} This stores the indices of the particles that contribute to a resonance, i.e., the decay products. <>= public :: resonance_contributors_t <>= type :: resonance_contributors_t integer, dimension(:), allocatable :: c contains <> end type resonance_contributors_t @ %def resonance_contributors_t @ Equality (comparison) <>= procedure, private :: resonance_contributors_equal generic :: operator(==) => resonance_contributors_equal <>= elemental function resonance_contributors_equal (c1, c2) result (equal) logical :: equal class(resonance_contributors_t), intent(in) :: c1, c2 equal = allocated (c1%c) .and. allocated (c2%c) if (equal) equal = size (c1%c) == size (c2%c) if (equal) equal = all (c1%c == c2%c) end function resonance_contributors_equal @ %def resonance_contributors_equal @ Assignment <>= procedure, private :: resonance_contributors_assign generic :: assignment(=) => resonance_contributors_assign <>= pure subroutine resonance_contributors_assign (contributors_out, contributors_in) class(resonance_contributors_t), intent(inout) :: contributors_out class(resonance_contributors_t), intent(in) :: contributors_in if (allocated (contributors_out%c)) deallocate (contributors_out%c) if (allocated (contributors_in%c)) then allocate (contributors_out%c (size (contributors_in%c))) contributors_out%c = contributors_in%c end if end subroutine resonance_contributors_assign @ %def resonance_contributors_assign @ \subsection{Resonance info object} This data structure augments the set of resonance contributors by a flavor object, such that we can perform calculations that take into account the particle properties, including mass and width. Avoiding nameclash with similar but different [[resonance_t]] of [[phs_base]]: <>= public :: resonance_info_t <>= type :: resonance_info_t type(flavor_t) :: flavor type(resonance_contributors_t) :: contributors contains <> end type resonance_info_t @ %def resonance_info_t @ <>= procedure :: copy => resonance_info_copy <>= subroutine resonance_info_copy (resonance_in, resonance_out) class(resonance_info_t), intent(in) :: resonance_in type(resonance_info_t), intent(out) :: resonance_out resonance_out%flavor = resonance_in%flavor if (allocated (resonance_in%contributors%c)) then associate (c => resonance_in%contributors%c) allocate (resonance_out%contributors%c (size (c))) resonance_out%contributors%c = c end associate end if end subroutine resonance_info_copy @ %def resonance_info_copy @ <>= procedure :: write => resonance_info_write <>= subroutine resonance_info_write (resonance, unit, verbose) class(resonance_info_t), intent(in) :: resonance integer, optional, intent(in) :: unit logical, optional, intent(in) :: verbose integer :: u, i logical :: verb u = given_output_unit (unit); if (u < 0) return verb = .true.; if (present (verbose)) verb = verbose if (verb) then write (u, '(A)', advance='no') "Resonance contributors: " else write (u, '(1x)', advance="no") end if if (allocated (resonance%contributors%c)) then do i = 1, size(resonance%contributors%c) write (u, '(I0,1X)', advance='no') resonance%contributors%c(i) end do else if (verb) then write (u, "(A)", advance="no") "[not allocated]" end if if (resonance%flavor%is_defined ()) call resonance%flavor%write (u) write (u, '(A)') end subroutine resonance_info_write @ %def resonance_info_write @ Create a resonance-info object. The particle info may be available in term of a flavor object or as a PDG code; in the latter case we have to require a model data object that provides mass and width information. <>= procedure, private :: resonance_info_init_pdg procedure, private :: resonance_info_init_flv generic :: init => resonance_info_init_pdg, resonance_info_init_flv <>= subroutine resonance_info_init_pdg (resonance, mom_id, pdg, model, n_out) class(resonance_info_t), intent(out) :: resonance integer, intent(in) :: mom_id integer, intent(in) :: pdg, n_out class(model_data_t), intent(in), target :: model type(flavor_t) :: flv call msg_debug (D_PHASESPACE, "resonance_info_init_pdg") call flv%init (pdg, model) call resonance%init (mom_id, flv, n_out) end subroutine resonance_info_init_pdg subroutine resonance_info_init_flv (resonance, mom_id, flv, n_out) class(resonance_info_t), intent(out) :: resonance integer, intent(in) :: mom_id type(flavor_t), intent(in) :: flv integer, intent(in) :: n_out integer :: i logical, dimension(n_out) :: contrib integer, dimension(n_out) :: tmp call msg_debug (D_PHASESPACE, "resonance_info_init_flv") resonance%flavor = flv do i = 1, n_out tmp(i) = i end do contrib = btest (mom_id, tmp - 1) allocate (resonance%contributors%c (count (contrib))) resonance%contributors%c = pack (tmp, contrib) end subroutine resonance_info_init_flv @ %def resonance_info_init @ <>= procedure, private :: resonance_info_equal generic :: operator(==) => resonance_info_equal <>= elemental function resonance_info_equal (r1, r2) result (equal) logical :: equal class(resonance_info_t), intent(in) :: r1, r2 equal = r1%flavor == r2%flavor .and. r1%contributors == r2%contributors end function resonance_info_equal @ %def resonance_info_equal @ With each resonance region we associate a Breit-Wigner function \begin{equation*} P = \frac{M_{res}^4}{(s - M_{res}^2)^2 + \Gamma_{res}^2 M_{res}^2}, \end{equation*} where $s$ denotes the invariant mass of the outgoing momenta originating from this resonance. Note that the $M_{res}^4$ in the nominator makes the mapping a dimensionless quantity. <>= procedure :: mapping => resonance_info_mapping <>= function resonance_info_mapping (resonance, s) result (bw) real(default) :: bw class(resonance_info_t), intent(in) :: resonance real(default), intent(in) :: s real(default) :: m, gamma if (resonance%flavor%is_defined ()) then m = resonance%flavor%get_mass () gamma = resonance%flavor%get_width () bw = m**4 / ((s - m**2)**2 + gamma**2 * m**2) else bw = one end if end function resonance_info_mapping @ %def resonance_info_mapping @ Used for building a resonance tree below. <>= procedure, private :: get_n_contributors => resonance_info_get_n_contributors procedure, private :: contains => resonance_info_contains <>= elemental function resonance_info_get_n_contributors (resonance) result (n) class(resonance_info_t), intent(in) :: resonance integer :: n if (allocated (resonance%contributors%c)) then n = size (resonance%contributors%c) else n = 0 end if end function resonance_info_get_n_contributors elemental function resonance_info_contains (resonance, c) result (flag) class(resonance_info_t), intent(in) :: resonance integer, intent(in) :: c logical :: flag if (allocated (resonance%contributors%c)) then flag = any (resonance%contributors%c == c) else flag = .false. end if end function resonance_info_contains @ %def resonance_info_get_n_contributors @ %def resonance_info_contains @ \subsection{Resonance history object} This data structure stores a set of resonances, i.e., the resonances that appear in a particular Feynman graph or, in the context of phase space, phase space diagram. <>= public :: resonance_history_t <>= type :: resonance_history_t type(resonance_info_t), dimension(:), allocatable :: resonances integer :: n_resonances = 0 contains <> end type resonance_history_t @ %def resonance_history_t @ Clear the resonance history. Assuming that there are no pointer-allocated parts, a straightforward [[intent(out)]] will do. <>= procedure :: clear => resonance_history_clear <>= subroutine resonance_history_clear (res_hist) class(resonance_history_t), intent(out) :: res_hist end subroutine resonance_history_clear @ %def resonance_history_clear @ <>= procedure :: copy => resonance_history_copy <>= subroutine resonance_history_copy (res_hist_in, res_hist_out) class(resonance_history_t), intent(in) :: res_hist_in type(resonance_history_t), intent(out) :: res_hist_out integer :: i res_hist_out%n_resonances = res_hist_in%n_resonances allocate (res_hist_out%resonances (size (res_hist_in%resonances))) do i = 1, size (res_hist_in%resonances) call res_hist_in%resonances(i)%copy (res_hist_out%resonances(i)) end do end subroutine resonance_history_copy @ %def resonance_history_copy @ <>= procedure :: write => resonance_history_write <>= subroutine resonance_history_write (res_hist, unit, verbose, indent) class(resonance_history_t), intent(in) :: res_hist integer, optional, intent(in) :: unit logical, optional, intent(in) :: verbose integer, optional, intent(in) :: indent integer :: u, i u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write(u, '(A,I0,A)') "Resonance history with ", & res_hist%n_resonances, " resonances:" do i = 1, res_hist%n_resonances call write_indent (u, indent) write (u, "(2x)", advance="no") call res_hist%resonances(i)%write (u, verbose) end do end subroutine resonance_history_write @ %def resonance_history_write @ Assignment. Indirectly calls type-bound assignment for the contributors. Strictly speaking, this is redundant. But NAGfor 6.208 intrinsic assignment crashes under certain conditions. <>= procedure, private :: resonance_history_assign generic :: assignment(=) => resonance_history_assign <>= subroutine resonance_history_assign (res_hist_out, res_hist_in) class(resonance_history_t), intent(out) :: res_hist_out class(resonance_history_t), intent(in) :: res_hist_in if (allocated (res_hist_in%resonances)) then res_hist_out%resonances = res_hist_in%resonances res_hist_out%n_resonances = res_hist_in%n_resonances end if end subroutine resonance_history_assign @ %def resonance_history_assign @ Equality. If this turns out to slow down the program, we should change the implementation or use hash codes. <>= procedure, private :: resonance_history_equal generic :: operator(==) => resonance_history_equal <>= elemental function resonance_history_equal (rh1, rh2) result (equal) logical :: equal class(resonance_history_t), intent(in) :: rh1, rh2 integer :: i equal = .false. if (rh1%n_resonances == rh2%n_resonances) then do i = 1, rh1%n_resonances if (.not. rh1%resonances(i) == rh2%resonances(i)) then return end if end do equal = .true. end if end function resonance_history_equal @ %def resonance_history_equal @ Check if a resonance history is a strict superset of another one. This is true if the first one is nonempty and the second one is empty. Otherwise, we check if each entry of the second argument appears in the first one. <>= procedure, private :: resonance_history_contains generic :: operator(.contains.) => resonance_history_contains @ <>= elemental function resonance_history_contains (rh1, rh2) result (flag) logical :: flag class(resonance_history_t), intent(in) :: rh1, rh2 integer :: i if (rh1%n_resonances > rh2%n_resonances) then flag = .true. do i = 1, rh2%n_resonances flag = flag .and. any (rh1%resonances == rh2%resonances(i)) end do else flag = .false. end if end function resonance_history_contains @ %def resonance_history_contains @ Number of entries for dynamically extending the resonance-info array. <>= integer, parameter :: n_max_resonances = 10 @ <>= procedure :: add_resonance => resonance_history_add_resonance <>= subroutine resonance_history_add_resonance (res_hist, resonance) class(resonance_history_t), intent(inout) :: res_hist type(resonance_info_t), intent(in) :: resonance type(resonance_info_t), dimension(:), allocatable :: tmp integer :: n, i call msg_debug (D_PHASESPACE, "resonance_history_add_resonance") if (.not. allocated (res_hist%resonances)) then n = 0 allocate (res_hist%resonances (1)) else n = res_hist%n_resonances allocate (tmp (n)) do i = 1, n call res_hist%resonances(i)%copy (tmp(i)) end do deallocate (res_hist%resonances) allocate (res_hist%resonances (n+1)) do i = 1, n call tmp(i)%copy (res_hist%resonances(i)) end do deallocate (tmp) end if call resonance%copy (res_hist%resonances(n+1)) res_hist%n_resonances = n + 1 call msg_debug & (D_PHASESPACE, "res_hist%n_resonances", res_hist%n_resonances) end subroutine resonance_history_add_resonance @ %def resonance_history_add_resonance @ <>= procedure :: remove_resonance => resonance_history_remove_resonance <>= subroutine resonance_history_remove_resonance (res_hist, i_res) class(resonance_history_t), intent(inout) :: res_hist integer, intent(in) :: i_res type(resonance_info_t), dimension(:), allocatable :: tmp_1, tmp_2 integer :: i, j, n n = res_hist%n_resonances res_hist%n_resonances = n - 1 if (res_hist%n_resonances == 0) then deallocate (res_hist%resonances) else if (i_res > 1) allocate (tmp_1(1:i_res-1)) if (i_res < n) allocate (tmp_2(i_res+1:n)) if (allocated (tmp_1)) then do i = 1, i_res - 1 call res_hist%resonances(i)%copy (tmp_1(i)) end do end if if (allocated (tmp_2)) then do i = i_res + 1, n call res_hist%resonances(i)%copy (tmp_2(i)) end do end if deallocate (res_hist%resonances) allocate (res_hist%resonances (res_hist%n_resonances)) j = 1 if (allocated (tmp_1)) then do i = 1, i_res - 1 call tmp_1(i)%copy (res_hist%resonances(j)) j = j + 1 end do deallocate (tmp_1) end if if (allocated (tmp_2)) then do i = i_res + 1, n call tmp_2(i)%copy (res_hist%resonances(j)) j = j + 1 end do deallocate (tmp_2) end if end if end subroutine resonance_history_remove_resonance @ %def resonance_history_remove_resonance @ <>= procedure :: add_offset => resonance_history_add_offset <>= subroutine resonance_history_add_offset (res_hist, n) class(resonance_history_t), intent(inout) :: res_hist integer, intent(in) :: n integer :: i_res do i_res = 1, res_hist%n_resonances associate (contributors => res_hist%resonances(i_res)%contributors%c) contributors = contributors + n end associate end do end subroutine resonance_history_add_offset @ %def resonance_history_add_offset @ <>= procedure :: contains_leg => resonance_history_contains_leg <>= function resonance_history_contains_leg (res_hist, i_leg) result (val) logical :: val class(resonance_history_t), intent(in) :: res_hist integer, intent(in) :: i_leg integer :: i_res val = .false. do i_res = 1, res_hist%n_resonances if (any (res_hist%resonances(i_res)%contributors%c == i_leg)) then val = .true. exit end if end do end function resonance_history_contains_leg @ %def resonance_history_contains_leg @ <>= procedure :: mapping => resonance_history_mapping <>= function resonance_history_mapping (res_hist, p, i_gluon) result (p_map) real(default) :: p_map class(resonance_history_t), intent(in) :: res_hist type(vector4_t), intent(in), dimension(:) :: p integer, intent(in), optional :: i_gluon integer :: i_res real(default) :: s p_map = one do i_res = 1, res_hist%n_resonances associate (res => res_hist%resonances(i_res)) s = compute_resonance_mass (p, res%contributors%c, i_gluon)**2 p_map = p_map * res%mapping (s) end associate end do end function resonance_history_mapping @ %def resonance_history_mapping @ This predicate is true if all resonances in the history have exactly [[n]] contributors. For instance, if $n=2$, all resonances have a two-particle decay. <>= procedure :: only_has_n_contributors => resonance_history_only_has_n_contributors <>= function resonance_history_only_has_n_contributors (res_hist, n) result (value) logical :: value class(resonance_history_t), intent(in) :: res_hist integer, intent(in) :: n integer :: i_res value = .true. do i_res = 1, res_hist%n_resonances associate (res => res_hist%resonances(i_res)) value = value .and. size (res%contributors%c) == n end associate end do end function resonance_history_only_has_n_contributors @ %def resonance_history_only_has_n_contributors @ <>= procedure :: has_flavor => resonance_history_has_flavor <>= function resonance_history_has_flavor (res_hist, flv) result (has_flv) logical :: has_flv class(resonance_history_t), intent(in) :: res_hist type(flavor_t), intent(in) :: flv integer :: i has_flv = .false. do i = 1, res_hist%n_resonances has_flv = has_flv .or. res_hist%resonances(i)%flavor == flv end do end function resonance_history_has_flavor @ %def resonance_history_has_flavor @ \subsection{Kinematics} Evaluate the distance from a resonance. The distance is given by $|p^2-m^2|/(m\Gamma)$. For $\Gamma\ll m$, this is the relative distance from the resonance peak in units of the half-width. <>= procedure :: evaluate_distance => resonance_info_evaluate_distance <>= subroutine resonance_info_evaluate_distance (res_info, p, dist) class(resonance_info_t), intent(in) :: res_info type(vector4_t), dimension(:), intent(in) :: p real(default), intent(out) :: dist real(default) :: m, w type(vector4_t) :: q m = res_info%flavor%get_mass () w = res_info%flavor%get_width () q = sum (p(res_info%contributors%c)) dist = abs (q**2 - m**2) / (m * w) end subroutine resonance_info_evaluate_distance @ %def resonance_info_evaluate_distance @ Evaluate the array of distances from a resonance history. We assume that the array has been allocated with correct size, namely the number of resonances in this history. <>= procedure :: evaluate_distances => resonance_history_evaluate_distances <>= subroutine resonance_history_evaluate_distances (res_hist, p, dist) class(resonance_history_t), intent(in) :: res_hist type(vector4_t), dimension(:), intent(in) :: p real(default), dimension(:), intent(out) :: dist integer :: i do i = 1, res_hist%n_resonances call res_hist%resonances(i)%evaluate_distance (p, dist(i)) end do end subroutine resonance_history_evaluate_distances @ %def resonance_history_evaluate_distances @ Use the distance to determine a Gaussian turnoff factor for a resonance. The factor is given by a Gaussian function $e^{-d^2/\sigma^2}$, where $\sigma$ is the [[gw]] parameter multiplied by the resonance width, and $d$ is the distance (see above). So, for $d=\sigma$, the factor is $0.37$, and for $d=2\sigma$ we get $0.018$. If the [[gw]] factor is less or equal to zero, return $1$. <>= procedure :: evaluate_gaussian => resonance_info_evaluate_gaussian <>= function resonance_info_evaluate_gaussian (res_info, p, gw) result (factor) class(resonance_info_t), intent(in) :: res_info type(vector4_t), dimension(:), intent(in) :: p real(default), intent(in) :: gw real(default) :: factor real(default) :: dist, w if (gw > 0) then w = res_info%flavor%get_width () call res_info%evaluate_distance (p, dist) factor = exp (- (dist / (gw * w)) **2) else factor = 1 end if end function resonance_info_evaluate_gaussian @ %def resonance_info_evaluate_gaussian @ The Gaussian factor of the history is the product of all factors. <>= procedure :: evaluate_gaussian => resonance_history_evaluate_gaussian <>= function resonance_history_evaluate_gaussian (res_hist, p, gw) result (factor) class(resonance_history_t), intent(in) :: res_hist type(vector4_t), dimension(:), intent(in) :: p real(default), intent(in) :: gw real(default), dimension(:), allocatable :: dist real(default) :: factor integer :: i factor = 1 do i = 1, res_hist%n_resonances factor = factor * res_hist%resonances(i)%evaluate_gaussian (p, gw) end do end function resonance_history_evaluate_gaussian @ %def resonance_history_evaluate_gaussian @ Use the distances to determine whether the resonance history can qualify as on-shell. The criterion is whether the distance is greater than the number of width values as given by [[on_shell_limit]]. <>= procedure :: is_on_shell => resonance_info_is_on_shell <>= function resonance_info_is_on_shell (res_info, p, on_shell_limit) & result (flag) class(resonance_info_t), intent(in) :: res_info type(vector4_t), dimension(:), intent(in) :: p real(default), intent(in) :: on_shell_limit logical :: flag real(default) :: dist call res_info%evaluate_distance (p, dist) flag = dist < on_shell_limit end function resonance_info_is_on_shell @ %def resonance_info_is_on_shell @ <>= procedure :: is_on_shell => resonance_history_is_on_shell <>= function resonance_history_is_on_shell (res_hist, p, on_shell_limit) & result (flag) class(resonance_history_t), intent(in) :: res_hist type(vector4_t), dimension(:), intent(in) :: p real(default), intent(in) :: on_shell_limit logical :: flag integer :: i flag = .true. do i = 1, res_hist%n_resonances flag = flag .and. res_hist%resonances(i)%is_on_shell (p, on_shell_limit) end do end function resonance_history_is_on_shell @ %def resonance_history_is_on_shell @ \subsection{OMega restriction strings} One application of the resonance module is creating restriction strings that can be fed into process definitions with the OMega generator. Since OMega counts the incoming particles first, we have to supply [[n_in]] as an offset. <>= procedure :: as_omega_string => resonance_info_as_omega_string <>= procedure :: as_omega_string => resonance_history_as_omega_string <>= function resonance_info_as_omega_string (res_info, n_in) result (string) class(resonance_info_t), intent(in) :: res_info integer, intent(in) :: n_in type(string_t) :: string integer :: i string = "" if (allocated (res_info%contributors%c)) then do i = 1, size (res_info%contributors%c) if (i > 1) string = string // "+" string = string // str (res_info%contributors%c(i) + n_in) end do string = string // "~" // res_info%flavor%get_name () end if end function resonance_info_as_omega_string function resonance_history_as_omega_string (res_hist, n_in) result (string) class(resonance_history_t), intent(in) :: res_hist integer, intent(in) :: n_in type(string_t) :: string integer :: i string = "" do i = 1, res_hist%n_resonances if (i > 1) string = string // " && " string = string // res_hist%resonances(i)%as_omega_string (n_in) end do end function resonance_history_as_omega_string @ %def resonance_info_as_omega_string @ %def resonance_history_as_omega_string @ \subsection{Resonance history as tree} If we want to organize the resonances and their decay products, it can be useful to have them explicitly as a tree structure. We implement this in the traditional event-record form with the resonances sorted by decreasing number of contributors, and their decay products added as an extra array. <>= public :: resonance_tree_t <>= type :: resonance_branch_t integer :: i = 0 type(flavor_t) :: flv integer, dimension(:), allocatable :: r_child integer, dimension(:), allocatable :: o_child end type resonance_branch_t type :: resonance_tree_t private integer :: n = 0 type(resonance_branch_t), dimension(:), allocatable :: branch contains <> end type resonance_tree_t @ %def resonance_branch_t resonance_tree_t @ <>= procedure :: write => resonance_tree_write <>= subroutine resonance_tree_write (tree, unit, indent) class(resonance_tree_t), intent(in) :: tree integer, intent(in), optional :: unit, indent integer :: u, b, c u = given_output_unit (unit) call write_indent (u, indent) write (u, "(A)", advance="no") "Resonance tree:" if (tree%n > 0) then write (u, *) do b = 1, tree%n call write_indent (u, indent) write (u, "(2x,'r',I0,':',1x)", advance="no") b associate (branch => tree%branch(b)) call branch%flv%write (u) write (u, "(1x,'=>')", advance="no") if (allocated (branch%r_child)) then do c = 1, size (branch%r_child) write (u, "(1x,'r',I0)", advance="no") branch%r_child(c) end do end if if (allocated (branch%o_child)) then do c = 1, size (branch%o_child) write (u, "(1x,I0)", advance="no") branch%o_child(c) end do end if write (u, *) end associate end do else write (u, "(1x,A)") "[empty]" end if end subroutine resonance_tree_write @ %def resonance_tree_write @ Contents. <>= procedure :: get_n_resonances => resonance_tree_get_n_resonances procedure :: get_flv => resonance_tree_get_flv <>= function resonance_tree_get_n_resonances (tree) result (n) class(resonance_tree_t), intent(in) :: tree integer :: n n = tree%n end function resonance_tree_get_n_resonances function resonance_tree_get_flv (tree, i) result (flv) class(resonance_tree_t), intent(in) :: tree integer, intent(in) :: i type(flavor_t) :: flv flv = tree%branch(i)%flv end function resonance_tree_get_flv @ %def resonance_tree_get_n_resonances @ %def resonance_tree_get_flv @ Return the shifted indices of the resonance children for branch [[i]]. For a child which is itself a resonance, add [[offset_r]] to the index value. For the others, add [[offset_o]]. Combine both in a single array. <>= procedure :: get_children => resonance_tree_get_children <>= function resonance_tree_get_children (tree, i, offset_r, offset_o) & result (child) class(resonance_tree_t), intent(in) :: tree integer, intent(in) :: i, offset_r, offset_o integer, dimension(:), allocatable :: child integer :: nr, no associate (branch => tree%branch(i)) nr = size (branch%r_child) no = size (branch%o_child) allocate (child (nr + no)) child(1:nr) = branch%r_child + offset_r child(nr+1:nr+no) = branch%o_child + offset_o end associate end function resonance_tree_get_children @ %def resonance_tree_get_children @ Transform a resonance history into a resonance tree. Algorithm: \begin{enumerate} \item Determine a mapping of the resonance array, such that in the new array the resonances are ordered by decreasing number of contributors. \item Copy the flavor entries to the mapped array. \item Scan all resonances and, for each one, find a resonance that is its parent. Since the resonances are ordered, later matches overwrite earlier ones. The last match is the correct one. Then scan again and, for each resonance, collect the resonances that have it as parent. This is the set of child resonances. \item Analogously, scan all outgoing particles that appear in any of the contributors list. Determine their immediate parent as above, and set the child outgoing parents for the resonances, as above. \end{enumerate} <>= procedure :: to_tree => resonance_history_to_tree <>= subroutine resonance_history_to_tree (res_hist, tree) class(resonance_history_t), intent(in) :: res_hist type(resonance_tree_t), intent(out) :: tree integer :: nr integer, dimension(:), allocatable :: r_branch, r_source nr = res_hist%n_resonances tree%n = nr allocate (tree%branch (tree%n), r_branch (tree%n), r_source (tree%n)) if (tree%n > 0) then call find_branch_ordering () call set_flavors () call set_child_resonances () call set_child_outgoing () end if contains subroutine find_branch_ordering () integer, dimension(:), allocatable :: nc_array integer :: r, ir, nc allocate (nc_array (tree%n)) nc_array(:) = res_hist%resonances%get_n_contributors () ir = 0 do nc = maxval (nc_array), minval (nc_array), -1 do r = 1, nr if (nc_array(r) == nc) then ir = ir + 1 r_branch(r) = ir r_source(ir) = r end if end do end do end subroutine find_branch_ordering subroutine set_flavors () integer :: r do r = 1, nr tree%branch(r_branch(r))%flv = res_hist%resonances(r)%flavor end do end subroutine set_flavors subroutine set_child_resonances () integer, dimension(:), allocatable :: r_child, r_parent integer :: r, ir, pr allocate (r_parent (nr), source = 0) SCAN_RES: do r = 1, nr associate (this_res => res_hist%resonances(r)) SCAN_PARENT: do ir = 1, nr pr = r_source(ir) if (pr == r) cycle SCAN_PARENT if (all (res_hist%resonances(pr)%contains & (this_res%contributors%c))) then r_parent (r) = pr end if end do SCAN_PARENT end associate end do SCAN_RES allocate (r_child (nr), source = [(r, r = 1, nr)]) do r = 1, nr ir = r_branch(r) tree%branch(ir)%r_child = r_branch (pack (r_child, r_parent == r)) end do end subroutine set_child_resonances subroutine set_child_outgoing () integer, dimension(:), allocatable :: o_child, o_parent integer :: o_max, r, o, ir o_max = 0 do r = 1, nr associate (this_res => res_hist%resonances(r)) o_max = max (o_max, maxval (this_res%contributors%c)) end associate end do allocate (o_parent (o_max), source=0) SCAN_OUT: do o = 1, o_max SCAN_PARENT: do ir = 1, nr r = r_source(ir) associate (this_res => res_hist%resonances(r)) if (this_res%contains (o)) o_parent(o) = r end associate end do SCAN_PARENT end do SCAN_OUT allocate (o_child (o_max), source = [(o, o = 1, o_max)]) do r = 1, nr ir = r_branch(r) tree%branch(ir)%o_child = pack (o_child, o_parent == r) end do end subroutine set_child_outgoing end subroutine resonance_history_to_tree @ %def resonance_history_to_tree @ \subsection{Resonance history set} This is an array of resonance histories. The elements are supposed to be unique. That is, entering a new element is successful only if the element does not already exist. The current implementation uses a straightforward linear search for comparison. If this should become an issue, we may change the implementation to a hash table. To keep this freedom, the set should be an opaque object. In fact, we expect to use it as a transient data structure. Once the set is complete, we transform it into a contiguous array. <>= public :: resonance_history_set_t <>= type :: index_array_t integer, dimension(:), allocatable :: i end type index_array_t type :: resonance_history_set_t private logical :: complete = .false. integer :: n_filter = 0 type(resonance_history_t), dimension(:), allocatable :: history type(index_array_t), dimension(:), allocatable :: contains_this type(resonance_tree_t), dimension(:), allocatable :: tree integer :: last = 0 contains <> end type resonance_history_set_t @ %def resonance_history_set_t @ Display. The tree-format version of the histories is displayed only upon request. <>= procedure :: write => resonance_history_set_write <>= subroutine resonance_history_set_write (res_set, unit, indent, show_trees) class(resonance_history_set_t), intent(in) :: res_set integer, intent(in), optional :: unit integer, intent(in), optional :: indent logical, intent(in), optional :: show_trees logical :: s_trees integer :: u, i, j, ind u = given_output_unit (unit) s_trees = .false.; if (present (show_trees)) s_trees = show_trees ind = 0; if (present (indent)) ind = indent call write_indent (u, indent) write (u, "(A)", advance="no") "Resonance history set:" if (res_set%complete) then write (u, *) else write (u, "(1x,A)") "[incomplete]" end if do i = 1, res_set%last write (u, "(1x,I0,1x)", advance="no") i call res_set%history(i)%write (u, verbose=.false., indent=indent) if (allocated (res_set%contains_this)) then call write_indent (u, indent) write (u, "(3x,A)", advance="no") "contained in (" do j = 1, size (res_set%contains_this(i)%i) if (j>1) write (u, "(',')", advance="no") write (u, "(I0)", advance="no") res_set%contains_this(i)%i(j) end do write (u, "(A)") ")" end if if (s_trees .and. allocated (res_set%tree)) then call res_set%tree(i)%write (u, ind + 1) end if end do end subroutine resonance_history_set_write @ %def resonance_history_set_write @ Initialization. The default initial size is 16 elements, to be doubled in size repeatedly as needed. <>= integer, parameter :: resonance_history_set_initial_size = 16 @ %def resonance_history_set_initial_size = 16 <>= procedure :: init => resonance_history_set_init <>= subroutine resonance_history_set_init (res_set, n_filter, initial_size) class(resonance_history_set_t), intent(out) :: res_set integer, intent(in), optional :: n_filter integer, intent(in), optional :: initial_size if (present (n_filter)) res_set%n_filter = n_filter if (present (initial_size)) then allocate (res_set%history (initial_size)) else allocate (res_set%history (resonance_history_set_initial_size)) end if end subroutine resonance_history_set_init @ %def resonance_history_set_init @ Enter an entry: append to the array if it does not yet exist, expand as needed. If a [[n_filter]] value has been provided, enter the resonance only if it fulfils the requirement. An empty resonance history is entered only if the [[trivial]] flag is set. <>= procedure :: enter => resonance_history_set_enter <>= subroutine resonance_history_set_enter (res_set, res_history, trivial) class(resonance_history_set_t), intent(inout) :: res_set type(resonance_history_t), intent(in) :: res_history logical, intent(in), optional :: trivial integer :: i, new if (res_history%n_resonances == 0) then if (present (trivial)) then if (.not. trivial) return else return end if end if if (res_set%n_filter > 0) then if (.not. res_history%only_has_n_contributors (res_set%n_filter)) return end if do i = 1, res_set%last if (res_set%history(i) == res_history) return end do new = res_set%last + 1 if (new > size (res_set%history)) call res_set%expand () res_set%history(new) = res_history res_set%last = new end subroutine resonance_history_set_enter @ %def resonance_history_set_enter @ Freeze the resonance history set: determine the array that determines in which other resonance histories a particular history is contained. This can only be done once, and once this is done, no further histories can be entered. <>= procedure :: freeze => resonance_history_set_freeze <>= subroutine resonance_history_set_freeze (res_set) class(resonance_history_set_t), intent(inout) :: res_set integer :: i, n, c logical, dimension(:), allocatable :: contains_this integer, dimension(:), allocatable :: index_array n = res_set%last allocate (contains_this (n)) allocate (index_array (n), source = [(i, i=1, n)]) allocate (res_set%contains_this (n)) do i = 1, n contains_this = resonance_history_contains & (res_set%history(1:n), res_set%history(i)) c = count (contains_this) allocate (res_set%contains_this(i)%i (c)) res_set%contains_this(i)%i = pack (index_array, contains_this) end do allocate (res_set%tree (n)) do i = 1, n call res_set%history(i)%to_tree (res_set%tree(i)) end do res_set%complete = .true. end subroutine resonance_history_set_freeze @ %def resonance_history_set_freeze @ Determine the histories (in form of their indices in the array) that can be considered on-shell, given a set of momenta and a maximum distance. The distance from the resonance is measured in multiples of the resonance width. Note that the momentum array must only contain the outgoing particles. If a particular history is on-shell, but there is another history which contains this and also is on-shell, only the latter is retained. <>= procedure :: determine_on_shell_histories & => resonance_history_set_determine_on_shell_histories <>= subroutine resonance_history_set_determine_on_shell_histories & (res_set, p, on_shell_limit, index_array) class(resonance_history_set_t), intent(in) :: res_set type(vector4_t), dimension(:), intent(in) :: p real(default), intent(in) :: on_shell_limit integer, dimension(:), allocatable, intent(out) :: index_array integer :: n, i integer, dimension(:), allocatable :: i_array if (res_set%complete) then n = res_set%last allocate (i_array (n), source=0) do i = 1, n if (res_set%history(i)%is_on_shell (p, on_shell_limit)) i_array(i) = i end do do i = 1, n if (any (i_array(res_set%contains_this(i)%i) /= 0)) then i_array(i) = 0 end if end do allocate (index_array (count (i_array /= 0))) index_array(:) = pack (i_array, i_array /= 0) end if end subroutine resonance_history_set_determine_on_shell_histories @ %def resonance_history_set_determine_on_shell_histories @ For the selected history, compute the Gaussian turnoff factor. The turnoff parameter is [[gw]]. <>= procedure :: evaluate_gaussian => resonance_history_set_evaluate_gaussian <>= function resonance_history_set_evaluate_gaussian (res_set, p, gw, i) & result (factor) class(resonance_history_set_t), intent(in) :: res_set type(vector4_t), dimension(:), intent(in) :: p real(default), intent(in) :: gw integer, intent(in) :: i real(default) :: factor factor = res_set%history(i)%evaluate_gaussian (p, gw) end function resonance_history_set_evaluate_gaussian @ %def resonance_history_set_evaluate_gaussian @ Return the number of histories. This is zero if there are none, or if [[freeze]] has not been called yet. <>= procedure :: get_n_history => resonance_history_set_get_n_history <>= function resonance_history_set_get_n_history (res_set) result (n) class(resonance_history_set_t), intent(in) :: res_set integer :: n if (res_set%complete) then n = res_set%last else n = 0 end if end function resonance_history_set_get_n_history @ %def resonance_history_set_get_n_history @ Return a single history. <>= procedure :: get_history => resonance_history_set_get_history <>= function resonance_history_set_get_history (res_set, i) result (res_history) class(resonance_history_set_t), intent(in) :: res_set integer, intent(in) :: i type(resonance_history_t) :: res_history if (res_set%complete .and. i <= res_set%last) then res_history = res_set%history(i) end if end function resonance_history_set_get_history @ %def resonance_history_set_get_history @ Conversion to a plain array, sized correctly. <>= procedure :: to_array => resonance_history_set_to_array <>= subroutine resonance_history_set_to_array (res_set, res_history) class(resonance_history_set_t), intent(in) :: res_set type(resonance_history_t), dimension(:), allocatable, intent(out) :: res_history if (res_set%complete) then allocate (res_history (res_set%last)) res_history(:) = res_set%history(1:res_set%last) end if end subroutine resonance_history_set_to_array @ %def resonance_history_set_to_array @ Return a selected history in tree form. <>= procedure :: get_tree => resonance_history_set_get_tree <>= subroutine resonance_history_set_get_tree (res_set, i, res_tree) class(resonance_history_set_t), intent(in) :: res_set integer, intent(in) :: i type(resonance_tree_t), intent(out) :: res_tree if (res_set%complete) then res_tree = res_set%tree(i) end if end subroutine resonance_history_set_get_tree @ %def resonance_history_set_to_array @ Expand: double the size of the array. We do not need this in the API. <>= procedure, private :: expand => resonance_history_set_expand <>= subroutine resonance_history_set_expand (res_set) class(resonance_history_set_t), intent(inout) :: res_set type(resonance_history_t), dimension(:), allocatable :: history_new integer :: s s = size (res_set%history) allocate (history_new (2 * s)) history_new(1:s) = res_set%history(1:s) call move_alloc (history_new, res_set%history) end subroutine resonance_history_set_expand @ %def resonance_history_set_expand @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[resonances_ut.f90]]>>= <> module resonances_ut use unit_tests use resonances_uti <> <> contains <> end module resonances_ut @ %def resonances_ut @ <<[[resonances_uti.f90]]>>= <> module resonances_uti <> <> use format_defs, only: FMF_12 use lorentz, only: vector4_t, vector4_at_rest use model_data, only: model_data_t use flavors, only: flavor_t use resonances, only: resonance_history_t use resonances <> <> contains <> end module resonances_uti @ %def resonances_ut @ API: driver for the unit tests below. <>= public :: resonances_test <>= subroutine resonances_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine resonances_test @ %def resonances_test @ Basic operations on a resonance history object. <>= call test (resonances_1, "resonances_1", & "check resonance history setup", & u, results) <>= public :: resonances_1 <>= subroutine resonances_1 (u) integer, intent(in) :: u type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(model_data_t), target :: model write (u, "(A)") "* Test output: resonances_1" write (u, "(A)") "* Purpose: test resonance history setup" write (u, "(A)") write (u, "(A)") "* Read model file" call model%init_sm_test () write (u, "(A)") write (u, "(A)") "* Empty resonance history" write (u, "(A)") call res_history%write (u) write (u, "(A)") write (u, "(A)") "* Add resonance" write (u, "(A)") call res_info%init (3, -24, model, 5) call res_history%add_resonance (res_info) call res_history%write (u) write (u, "(A)") write (u, "(A)") "* Add another resonance" write (u, "(A)") call res_info%init (7, 23, model, 5) call res_history%add_resonance (res_info) call res_history%write (u) write (u, "(A)") write (u, "(A)") "* Remove resonance" write (u, "(A)") call res_history%remove_resonance (1) call res_history%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: resonances_1" end subroutine resonances_1 @ %def resonances_1 @ Basic operations on a resonance history object. <>= call test (resonances_2, "resonances_2", & "check O'Mega restriction strings", & u, results) <>= public :: resonances_2 <>= subroutine resonances_2 (u) integer, intent(in) :: u type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(model_data_t), target :: model type(string_t) :: restrictions write (u, "(A)") "* Test output: resonances_2" write (u, "(A)") "* Purpose: test OMega restrictions strings & &for resonance history" write (u, "(A)") write (u, "(A)") "* Read model file" call model%init_sm_test () write (u, "(A)") write (u, "(A)") "* Empty resonance history" write (u, "(A)") restrictions = res_history%as_omega_string (2) write (u, "(A,A,A)") "restrictions = '", char (restrictions), "'" write (u, "(A)") write (u, "(A)") "* Add resonance" write (u, "(A)") call res_info%init (3, -24, model, 5) call res_history%add_resonance (res_info) restrictions = res_history%as_omega_string (2) write (u, "(A,A,A)") "restrictions = '", char (restrictions), "'" write (u, "(A)") write (u, "(A)") "* Add another resonance" write (u, "(A)") call res_info%init (7, 23, model, 5) call res_history%add_resonance (res_info) restrictions = res_history%as_omega_string (2) write (u, "(A,A,A)") "restrictions = '", char (restrictions), "'" write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: resonances_2" end subroutine resonances_2 @ %def resonances_2 @ Basic operations on a resonance history set. <>= call test (resonances_3, "resonances_3", & "check resonance history set", & u, results) <>= public :: resonances_3 <>= subroutine resonances_3 (u) integer, intent(in) :: u type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(resonance_history_t), dimension(:), allocatable :: res_histories type(resonance_history_set_t) :: res_set type(model_data_t), target :: model integer :: i write (u, "(A)") "* Test output: resonances_3" write (u, "(A)") "* Purpose: test resonance history set" write (u, "(A)") write (u, "(A)") "* Read model file" call model%init_sm_test () write (u, "(A)") write (u, "(A)") "* Initialize resonance history set" write (u, "(A)") call res_set%init (initial_size = 2) write (u, "(A)") "* Add resonance histories, one at a time" write (u, "(A)") call res_history%write (u) call res_set%enter (res_history) call res_history%clear () write (u, *) call res_info%init (3, -24, model, 5) call res_history%add_resonance (res_info) call res_history%write (u) call res_set%enter (res_history) call res_history%clear () write (u, *) call res_info%init (3, -24, model, 5) call res_history%add_resonance (res_info) call res_info%init (7, 23, model, 5) call res_history%add_resonance (res_info) call res_history%write (u) call res_set%enter (res_history) call res_history%clear () write (u, *) call res_info%init (7, 23, model, 5) call res_history%add_resonance (res_info) call res_history%write (u) call res_set%enter (res_history) call res_history%clear () write (u, *) call res_info%init (3, -24, model, 5) call res_history%add_resonance (res_info) call res_history%write (u) call res_set%enter (res_history) call res_history%clear () write (u, *) call res_info%init (3, -24, model, 5) call res_history%add_resonance (res_info) call res_info%init (7, 25, model, 5) call res_history%add_resonance (res_info) call res_history%write (u) call res_set%enter (res_history) call res_history%clear () call res_set%freeze () write (u, "(A)") write (u, "(A)") "* Result" write (u, "(A)") call res_set%write (u) write (u, "(A)") write (u, "(A)") "* Queries" write (u, "(A)") write (u, "(A,1x,I0)") "n_history =", res_set%get_n_history () write (u, "(A)") write (u, "(A)") "History #2:" res_history = res_set%get_history (2) call res_history%write (u, indent=1) call res_history%clear () write (u, "(A)") write (u, "(A)") "* Result in array form" call res_set%to_array (res_histories) do i = 1, size (res_histories) write (u, *) call res_histories(i)%write (u) end do write (u, "(A)") write (u, "(A)") "* Re-initialize resonance history set with filter n=2" write (u, "(A)") call res_set%init (n_filter = 2) write (u, "(A)") "* Add resonance histories, one at a time" write (u, "(A)") call res_info%init (3, -24, model, 5) call res_history%add_resonance (res_info) call res_history%write (u) call res_set%enter (res_history) call res_history%clear () write (u, *) call res_info%init (3, -24, model, 5) call res_history%add_resonance (res_info) call res_info%init (7, 23, model, 5) call res_history%add_resonance (res_info) call res_history%write (u) call res_set%enter (res_history) call res_history%clear () write (u, *) call res_info%init (7, 23, model, 5) call res_history%add_resonance (res_info) call res_history%write (u) call res_set%enter (res_history) call res_history%clear () write (u, *) call res_info%init (3, -24, model, 5) call res_history%add_resonance (res_info) call res_history%write (u) call res_set%enter (res_history) call res_history%clear () call res_set%freeze () write (u, "(A)") write (u, "(A)") "* Result" write (u, "(A)") call res_set%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: resonances_3" end subroutine resonances_3 @ %def resonances_3 @ Probe momenta for resonance histories <>= call test (resonances_4, "resonances_4", & "resonance history: distance evaluation", & u, results) <>= public :: resonances_4 <>= subroutine resonances_4 (u) integer, intent(in) :: u type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(model_data_t), target :: model type(flavor_t) :: fw, fz real(default) :: mw, mz, ww, wz type(vector4_t), dimension(3) :: p real(default), dimension(2) :: dist real(default) :: gw, factor integer :: i write (u, "(A)") "* Test output: resonances_4" write (u, "(A)") "* Purpose: test resonance history evaluation" write (u, "(A)") write (u, "(A)") "* Read model file" call model%init_sm_test () write (u, "(A)") write (u, "(A)") "* W and Z parameters" write (u, "(A)") call fw%init (24, model) call fz%init (23, model) mw = fw%get_mass () ww = fw%get_width () mz = fz%get_mass () wz = fz%get_width () write (u, "(A,1x," // FMF_12 // ")") "mW =", mw write (u, "(A,1x," // FMF_12 // ")") "wW =", ww write (u, "(A,1x," // FMF_12 // ")") "mZ =", mz write (u, "(A,1x," // FMF_12 // ")") "wZ =", wz write (u, "(A)") write (u, "(A)") "* Gaussian width parameter" write (u, "(A)") gw = 2 write (u, "(A,1x," // FMF_12 // ")") "gw =", gw write (u, "(A)") write (u, "(A)") "* Setup resonance histories" write (u, "(A)") call res_info%init (3, -24, model, 5) call res_history%add_resonance (res_info) call res_info%init (7, 23, model, 5) call res_history%add_resonance (res_info) call res_history%write (u) write (u, "(A)") write (u, "(A)") "* Setup zero momenta" write (u, "(A)") do i = 1, 3 call p(i)%write (u) end do write (u, "(A)") write (u, "(A)") "* Evaluate distances from resonances" write (u, "(A)") call res_history%evaluate_distances (p, dist) write (u, "(A,1x," // FMF_12 // ")") "distance (W) =", dist(1) write (u, "(A,1x," // FMF_12 // ")") "m/w (W) =", mw / ww write (u, "(A,1x," // FMF_12 // ")") "distance (Z) =", dist(2) write (u, "(A,1x," // FMF_12 // ")") "m/w (Z) =", mz / wz write (u, "(A)") write (u, "(A)") "* Evaluate Gaussian turnoff factor" write (u, "(A)") factor = res_history%evaluate_gaussian (p, gw) write (u, "(A,1x," // FMF_12 // ")") "gaussian fac =", factor write (u, "(A)") write (u, "(A)") "* Set momenta on W peak" write (u, "(A)") p(1) = vector4_at_rest (mw/2) p(2) = vector4_at_rest (mw/2) do i = 1, 3 call p(i)%write (u) end do write (u, "(A)") write (u, "(A)") "* Evaluate distances from resonances" write (u, "(A)") call res_history%evaluate_distances (p, dist) write (u, "(A,1x," // FMF_12 // ")") "distance (W) =", dist(1) write (u, "(A,1x," // FMF_12 // ")") "distance (Z) =", dist(2) write (u, "(A,1x," // FMF_12 // ")") "expected =", & abs (mz**2 - mw**2) / (mz*wz) write (u, "(A)") write (u, "(A)") "* Evaluate Gaussian turnoff factor" write (u, "(A)") factor = res_history%evaluate_gaussian (p, gw) write (u, "(A,1x," // FMF_12 // ")") "gaussian fac =", factor write (u, "(A,1x," // FMF_12 // ")") "expected =", & exp (- (abs (mz**2 - mw**2) / (mz*wz))**2 / (gw * wz)**2) write (u, "(A)") write (u, "(A)") "* Set momenta on both peaks" write (u, "(A)") p(3) = vector4_at_rest (mz - mw) do i = 1, 3 call p(i)%write (u) end do write (u, "(A)") write (u, "(A)") "* Evaluate distances from resonances" write (u, "(A)") call res_history%evaluate_distances (p, dist) write (u, "(A,1x," // FMF_12 // ")") "distance (W) =", dist(1) write (u, "(A,1x," // FMF_12 // ")") "distance (Z) =", dist(2) write (u, "(A)") write (u, "(A)") "* Evaluate Gaussian turnoff factor" write (u, "(A)") factor = res_history%evaluate_gaussian (p, gw) write (u, "(A,1x," // FMF_12 // ")") "gaussian fac =", factor write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: resonances_4" end subroutine resonances_4 @ %def resonances_4 @ Probe on-shell test for resonance histories <>= call test (resonances_5, "resonances_5", & "resonance history: on-shell test", & u, results) <>= public :: resonances_5 <>= subroutine resonances_5 (u) integer, intent(in) :: u type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(resonance_history_set_t) :: res_set type(model_data_t), target :: model type(flavor_t) :: fw, fz real(default) :: mw, mz, ww, wz real(default) :: on_shell_limit integer, dimension(:), allocatable :: on_shell type(vector4_t), dimension(4) :: p write (u, "(A)") "* Test output: resonances_5" write (u, "(A)") "* Purpose: resonance history on-shell test" write (u, "(A)") write (u, "(A)") "* Read model file" call model%init_sm_test () write (u, "(A)") write (u, "(A)") "* W and Z parameters" write (u, "(A)") call fw%init (24, model) call fz%init (23, model) mw = fw%get_mass () ww = fw%get_width () mz = fz%get_mass () wz = fz%get_width () write (u, "(A,1x," // FMF_12 // ")") "mW =", mw write (u, "(A,1x," // FMF_12 // ")") "wW =", ww write (u, "(A,1x," // FMF_12 // ")") "mZ =", mz write (u, "(A,1x," // FMF_12 // ")") "wZ =", wz write (u, "(A)") write (u, "(A)") "* On-shell parameter: distance as multiple of width" write (u, "(A)") on_shell_limit = 3 write (u, "(A,1x," // FMF_12 // ")") "on-shell limit =", on_shell_limit write (u, "(A)") write (u, "(A)") "* Setup resonance history set" write (u, "(A)") call res_set%init () call res_info%init (3, -24, model, 6) call res_history%add_resonance (res_info) call res_set%enter (res_history) call res_history%clear () call res_info%init (12, 24, model, 6) call res_history%add_resonance (res_info) call res_set%enter (res_history) call res_history%clear () call res_info%init (15, 23, model, 6) call res_history%add_resonance (res_info) call res_set%enter (res_history) call res_history%clear () call res_info%init (3, -24, model, 6) call res_history%add_resonance (res_info) call res_info%init (15, 23, model, 6) call res_history%add_resonance (res_info) call res_set%enter (res_history) call res_history%clear () call res_info%init (12, 24, model, 6) call res_history%add_resonance (res_info) call res_info%init (15, 23, model, 6) call res_history%add_resonance (res_info) call res_set%enter (res_history) call res_history%clear () call res_set%freeze () call res_set%write (u) write (u, "(A)") write (u, "(A)") "* Setup zero momenta" write (u, "(A)") call write_momenta (p) call res_set%determine_on_shell_histories (p, on_shell_limit, on_shell) call write_on_shell_histories (on_shell) write (u, "(A)") write (u, "(A)") "* Setup momenta near W- resonance (2 widths off)" write (u, "(A)") p(1) = vector4_at_rest (82.5_default) call write_momenta (p) call res_set%determine_on_shell_histories (p, on_shell_limit, on_shell) call write_on_shell_histories (on_shell) write (u, "(A)") write (u, "(A)") "* Setup momenta near W- resonance (4 widths off)" write (u, "(A)") p(1) = vector4_at_rest (84.5_default) call write_momenta (p) call res_set%determine_on_shell_histories (p, on_shell_limit, on_shell) call write_on_shell_histories (on_shell) write (u, "(A)") write (u, "(A)") "* Setup momenta near Z resonance" write (u, "(A)") p(1) = vector4_at_rest (45._default) p(3) = vector4_at_rest (45._default) call write_momenta (p) call res_set%determine_on_shell_histories (p, on_shell_limit, on_shell) call write_on_shell_histories (on_shell) write (u, "(A)") write (u, "(A)") "* Setup momenta near W- and W+ resonances" write (u, "(A)") p(1) = vector4_at_rest (40._default) p(2) = vector4_at_rest (40._default) p(3) = vector4_at_rest (40._default) p(4) = vector4_at_rest (40._default) call write_momenta (p) call res_set%determine_on_shell_histories (p, on_shell_limit, on_shell) call write_on_shell_histories (on_shell) write (u, "(A)") write (u, "(A)") "* Setup momenta near W- and Z resonances, & &shadowing single resonances" write (u, "(A)") p(1) = vector4_at_rest (40._default) p(2) = vector4_at_rest (40._default) p(3) = vector4_at_rest (10._default) p(4) = vector4_at_rest ( 0._default) call write_momenta (p) call res_set%determine_on_shell_histories (p, on_shell_limit, on_shell) call write_on_shell_histories (on_shell) write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: resonances_5" contains subroutine write_momenta (p) type(vector4_t), dimension(:), intent(in) :: p integer :: i do i = 1, size (p) call p(i)%write (u) end do end subroutine write_momenta subroutine write_on_shell_histories (on_shell) integer, dimension(:), intent(in) :: on_shell integer :: i write (u, *) write (u, "(A)", advance="no") "on-shell = (" do i = 1, size (on_shell) if (i > 1) write (u, "(',')", advance="no") write (u, "(I0)", advance="no") on_shell(i) end do write (u, "(')')") end subroutine write_on_shell_histories end subroutine resonances_5 @ %def resonances_5 @ Organize the resonance history as a tree structure. <>= call test (resonances_6, "resonances_6", & "check resonance history setup", & u, results) <>= public :: resonances_6 <>= subroutine resonances_6 (u) integer, intent(in) :: u type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(resonance_tree_t) :: res_tree type(model_data_t), target :: model write (u, "(A)") "* Test output: resonances_6" write (u, "(A)") "* Purpose: retrieve resonance histories as trees" write (u, "(A)") write (u, "(A)") "* Read model file" call model%init_sm_test () write (u, "(A)") write (u, "(A)") "* Empty resonance history" write (u, "(A)") call res_history%write (u) write (u, "(A)") call res_history%to_tree (res_tree) call res_tree%write (u) write (u, "(A)") write (u, "(A)") "* Single resonance" write (u, "(A)") call res_info%init (3, -24, model, 5) call res_history%add_resonance (res_info) call res_history%write (u) write (u, "(A)") call res_history%to_tree (res_tree) call res_tree%write (u) write (u, "(A)") write (u, "(A)") "* Nested resonances" write (u, "(A)") call res_info%init (7, 23, model, 5) call res_history%add_resonance (res_info) call res_history%write (u) write (u, "(A)") call res_history%to_tree (res_tree) call res_tree%write (u) write (u, "(A)") write (u, "(A)") "* Disjunct resonances" write (u, "(A)") call res_history%clear () call res_info%init (5, 24, model, 7) call res_history%add_resonance (res_info) call res_info%init (7, 6, model, 7) call res_history%add_resonance (res_info) call res_info%init (80, -24, model, 7) call res_history%add_resonance (res_info) call res_info%init (112, -6, model, 7) call res_history%add_resonance (res_info) call res_history%write (u) write (u, "(A)") call res_history%to_tree (res_tree) call res_tree%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: resonances_6" end subroutine resonances_6 @ %def resonances_6 @ Basic operations on a resonance history set. <>= call test (resonances_7, "resonances_7", & "display tree format of history set elements", & u, results) <>= public :: resonances_7 <>= subroutine resonances_7 (u) integer, intent(in) :: u type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(resonance_tree_t) :: res_tree type(resonance_history_set_t) :: res_set type(model_data_t), target :: model type(flavor_t) :: flv write (u, "(A)") "* Test output: resonances_7" write (u, "(A)") "* Purpose: test tree format" write (u, "(A)") write (u, "(A)") "* Read model file" call model%init_sm_test () write (u, "(A)") write (u, "(A)") "* Initialize, fill and freeze resonance history set" write (u, "(A)") call res_set%init (initial_size = 2) call res_info%init (3, -24, model, 5) call res_history%add_resonance (res_info) call res_history%clear () call res_info%init (3, -24, model, 5) call res_history%add_resonance (res_info) call res_info%init (7, 23, model, 5) call res_history%add_resonance (res_info) call res_set%enter (res_history) call res_history%clear () call res_info%init (7, 23, model, 5) call res_history%add_resonance (res_info) call res_set%enter (res_history) call res_history%clear () call res_info%init (3, -24, model, 5) call res_history%add_resonance (res_info) call res_set%enter (res_history) call res_history%clear () call res_info%init (3, -24, model, 5) call res_history%add_resonance (res_info) call res_info%init (7, 25, model, 5) call res_history%add_resonance (res_info) call res_set%enter (res_history) call res_history%clear () call res_set%freeze () call res_set%write (u, show_trees = .true.) write (u, "(A)") write (u, "(A)") "* Extract tree #1" write (u, "(A)") call res_set%get_tree (1, res_tree) call res_tree%write (u) write (u, *) write (u, "(1x,A,1x,I0)") "n_resonances =", res_tree%get_n_resonances () write (u, *) write (u, "(1x,A,1x)", advance="no") "flv(r1) =" flv = res_tree%get_flv (1) call flv%write (u) write (u, *) write (u, "(1x,A,1x)", advance="no") "flv(r2) =" flv = res_tree%get_flv (2) call flv%write (u) write (u, *) write (u, *) write (u, "(1x,A)") "[offset = 2, 4]" write (u, "(1x,A,9(1x,I0))") "children(r1) =", & res_tree%get_children(1, 2, 4) write (u, "(1x,A,9(1x,I0))") "children(r2) =", & res_tree%get_children(2, 2, 4) write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: resonances_7" end subroutine resonances_7 @ %def resonances_7 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \clearpage \section{Mappings} Mappings are objects that encode the transformation of the interval $(0,1)$ to a physical variable $m^2$ or $\cos\theta$ (and back), as it is used in the phase space parameterization. The mapping objects contain fixed parameters, the associated methods implement the mapping and inverse mapping operations, including the computation of the Jacobian (phase space factor). <<[[mappings.f90]]>>= <> module mappings <> use kinds, only: TC <> use io_units use constants, only: pi use format_defs, only: FMT_19 use diagnostics use md5 use model_data use flavors <> <> <> <> <> contains <> end module mappings @ %def mappings @ \subsection{Default parameters} This type holds the default parameters, needed for setting the scale in cases where no mass parameter is available. The contents are public. <>= public :: mapping_defaults_t <>= type :: mapping_defaults_t real(default) :: energy_scale = 10 real(default) :: invariant_mass_scale = 10 real(default) :: momentum_transfer_scale = 10 logical :: step_mapping = .true. logical :: step_mapping_exp = .true. logical :: enable_s_mapping = .false. contains <> end type mapping_defaults_t @ %def mapping_defaults_t @ Output. <>= procedure :: write => mapping_defaults_write <>= subroutine mapping_defaults_write (object, unit) class(mapping_defaults_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(3x,A," // FMT_19 // ")") "energy scale = ", & object%energy_scale write (u, "(3x,A," // FMT_19 // ")") "mass scale = ", & object%invariant_mass_scale write (u, "(3x,A," // FMT_19 // ")") "q scale = ", & object%momentum_transfer_scale write (u, "(3x,A,L1)") "step mapping = ", & object%step_mapping write (u, "(3x,A,L1)") "step exp. mode = ", & object%step_mapping_exp write (u, "(3x,A,L1)") "allow s mapping = ", & object%enable_s_mapping end subroutine mapping_defaults_write @ %def mapping_defaults_write @ <>= public :: mapping_defaults_md5sum <>= function mapping_defaults_md5sum (mapping_defaults) result (md5sum_map) character(32) :: md5sum_map type(mapping_defaults_t), intent(in) :: mapping_defaults integer :: u u = free_unit () open (u, status = "scratch") write (u, *) mapping_defaults%energy_scale write (u, *) mapping_defaults%invariant_mass_scale write (u, *) mapping_defaults%momentum_transfer_scale write (u, *) mapping_defaults%step_mapping write (u, *) mapping_defaults%step_mapping_exp write (u, *) mapping_defaults%enable_s_mapping rewind (u) md5sum_map = md5sum (u) close (u) end function mapping_defaults_md5sum @ %def mapping_defaults_md5sum @ \subsection{The Mapping type} Each mapping has a type (e.g., s-channel, infrared), a binary code (redundant, but useful for debugging), and a reference particle. The flavor code of this particle is stored for bookkeeping reasons, what matters are the mass and width of this particle. Furthermore, depending on the type, various mapping parameters can be set and used. The parameters [[a1]] to [[a3]] (for $m^2$ mappings) and [[b1]] to [[b3]] (for $\cos\theta$ mappings) are values that are stored once to speed up the calculation, if [[variable_limits]] is false. The exact meaning of these parameters depends on the mapping type. The limits are fixed if there is a fixed c.m. energy. <>= public :: mapping_t <>= type :: mapping_t private integer :: type = NO_MAPPING integer(TC) :: bincode type(flavor_t) :: flv real(default) :: mass = 0 real(default) :: width = 0 logical :: a_unknown = .true. real(default) :: a1 = 0 real(default) :: a2 = 0 real(default) :: a3 = 0 logical :: b_unknown = .true. real(default) :: b1 = 0 real(default) :: b2 = 0 real(default) :: b3 = 0 logical :: variable_limits = .true. contains <> end type mapping_t @ %def mapping_t @ The valid mapping types. The extra type [[STEP_MAPPING]] is used only internally. <>= <> @ \subsection{Screen output} Do not write empty mappings. <>= public :: mapping_write <>= subroutine mapping_write (map, unit, verbose) type(mapping_t), intent(in) :: map integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u character(len=9) :: str u = given_output_unit (unit); if (u < 0) return select case(map%type) case(S_CHANNEL); str = "s_channel" case(COLLINEAR); str = "collinear" case(INFRARED); str = "infrared " case(RADIATION); str = "radiation" case(T_CHANNEL); str = "t_channel" case(U_CHANNEL); str = "u_channel" case(STEP_MAPPING_E); str = "step_exp" case(STEP_MAPPING_H); str = "step_hyp" case(ON_SHELL); str = "on_shell" case default; str = "????????" end select if (map%type /= NO_MAPPING) then write (u, '(1x,A,I4,A)') & "Branch #", map%bincode, ": " // & "Mapping (" // str // ") for particle " // & '"' // char (map%flv%get_name ()) // '"' if (present (verbose)) then if (verbose) then select case (map%type) case (S_CHANNEL, RADIATION, STEP_MAPPING_E, STEP_MAPPING_H) write (u, "(1x,A,3(" // FMT_19 // "))") & " m/w = ", map%mass, map%width case default write (u, "(1x,A,3(" // FMT_19 // "))") & " m = ", map%mass end select select case (map%type) case (S_CHANNEL, T_CHANNEL, U_CHANNEL, & STEP_MAPPING_E, STEP_MAPPING_H, & COLLINEAR, INFRARED, RADIATION) write (u, "(1x,A,3(" // FMT_19 // "))") & " a1/2/3 = ", map%a1, map%a2, map%a3 end select select case (map%type) case (T_CHANNEL, U_CHANNEL, COLLINEAR) write (u, "(1x,A,3(" // FMT_19 // "))") & " b1/2/3 = ", map%b1, map%b2, map%b3 end select end if end if end if end subroutine mapping_write @ %def mapping_write @ \subsection{Define a mapping} The initialization routine sets the mapping type and the particle (binary code and flavor code) for which the mapping applies (e.g., a $Z$ resonance in branch \#3). <>= public :: mapping_init <>= subroutine mapping_init (mapping, bincode, type, f, model) type(mapping_t), intent(inout) :: mapping integer(TC), intent(in) :: bincode type(string_t), intent(in) :: type integer, intent(in), optional :: f class(model_data_t), intent(in), optional, target :: model mapping%bincode = bincode select case (char (type)) case ("s_channel"); mapping%type = S_CHANNEL case ("collinear"); mapping%type = COLLINEAR case ("infrared"); mapping%type = INFRARED case ("radiation"); mapping%type = RADIATION case ("t_channel"); mapping%type = T_CHANNEL case ("u_channel"); mapping%type = U_CHANNEL case ("step_exp"); mapping%type = STEP_MAPPING_E case ("step_hyp"); mapping%type = STEP_MAPPING_H case ("on_shell"); mapping%type = ON_SHELL case default call msg_bug ("Mappings: encountered undefined mapping key '" & // char (type) // "'") end select if (present (f) .and. present (model)) call mapping%flv%init (f, model) end subroutine mapping_init @ %def mapping_init @ This sets the actual mass and width, using a parameter set. Since the auxiliary parameters will only be determined when the mapping is first called, they are marked as unknown. <>= public :: mapping_set_parameters <>= subroutine mapping_set_parameters (map, mapping_defaults, variable_limits) type(mapping_t), intent(inout) :: map type(mapping_defaults_t), intent(in) :: mapping_defaults logical, intent(in) :: variable_limits if (map%type /= NO_MAPPING) then map%mass = map%flv%get_mass () map%width = map%flv%get_width () map%variable_limits = variable_limits map%a_unknown = .true. map%b_unknown = .true. select case (map%type) case (S_CHANNEL) if (map%mass <= 0) then call mapping_write (map) call msg_fatal & & (" S-channel resonance must have positive mass") else if (map%width <= 0) then call mapping_write (map) call msg_fatal & & (" S-channel resonance must have positive width") end if case (RADIATION) map%width = max (map%width, mapping_defaults%energy_scale) case (INFRARED, COLLINEAR) map%mass = max (map%mass, mapping_defaults%invariant_mass_scale) case (T_CHANNEL, U_CHANNEL) map%mass = max (map%mass, mapping_defaults%momentum_transfer_scale) end select end if end subroutine mapping_set_parameters @ %def mapping_set_code mapping_set_parameters @ For a step mapping the mass and width are set directly, instead of being determined from the flavor parameter (which is meaningless here). They correspond to the effective upper bound of phase space due to a resonance, as opposed to the absolute upper bound. <>= public :: mapping_set_step_mapping_parameters <>= subroutine mapping_set_step_mapping_parameters (map, & mass, width, variable_limits) type(mapping_t), intent(inout) :: map real(default), intent(in) :: mass, width logical, intent(in) :: variable_limits select case (map%type) case (STEP_MAPPING_E, STEP_MAPPING_H) map%variable_limits = variable_limits map%a_unknown = .true. map%b_unknown = .true. map%mass = mass map%width = width end select end subroutine mapping_set_step_mapping_parameters @ %def mapping_set_step_mapping_parameters @ \subsection{Retrieve contents} Return true if there is any / an s-channel mapping. <>= public :: mapping_is_set public :: mapping_is_s_channel public :: mapping_is_on_shell <>= procedure :: is_set => mapping_is_set procedure :: is_s_channel => mapping_is_s_channel procedure :: is_on_shell => mapping_is_on_shell <>= function mapping_is_set (mapping) result (flag) class(mapping_t), intent(in) :: mapping logical :: flag flag = mapping%type /= NO_MAPPING end function mapping_is_set function mapping_is_s_channel (mapping) result (flag) class(mapping_t), intent(in) :: mapping logical :: flag flag = mapping%type == S_CHANNEL end function mapping_is_s_channel function mapping_is_on_shell (mapping) result (flag) class(mapping_t), intent(in) :: mapping logical :: flag flag = mapping%type == ON_SHELL end function mapping_is_on_shell @ %def mapping_is_set @ %def mapping_is_s_channel @ %def mapping_is_on_shell @ Return the binary code for the mapped particle. <>= procedure :: get_bincode => mapping_get_bincode <>= function mapping_get_bincode (mapping) result (bincode) class(mapping_t), intent(in) :: mapping integer(TC) :: bincode bincode = mapping%bincode end function mapping_get_bincode @ %def mapping_get_bincode @ Return the flavor object for the mapped particle. <>= procedure :: get_flv => mapping_get_flv <>= function mapping_get_flv (mapping) result (flv) class(mapping_t), intent(in) :: mapping type(flavor_t) :: flv flv = mapping%flv end function mapping_get_flv @ %def mapping_get_flv @ Return stored mass and width, respectively. <>= public :: mapping_get_mass public :: mapping_get_width <>= function mapping_get_mass (mapping) result (mass) real(default) :: mass type(mapping_t), intent(in) :: mapping mass = mapping%mass end function mapping_get_mass function mapping_get_width (mapping) result (width) real(default) :: width type(mapping_t), intent(in) :: mapping width = mapping%width end function mapping_get_width @ %def mapping_get_mass @ %def mapping_get_width @ \subsection{Compare mappings} Equality for single mappings and arrays <>= public :: operator(==) <>= interface operator(==) module procedure mapping_equal end interface <>= function mapping_equal (m1, m2) result (equal) type(mapping_t), intent(in) :: m1, m2 logical :: equal if (m1%type == m2%type) then select case (m1%type) case (NO_MAPPING) equal = .true. case (S_CHANNEL, RADIATION, STEP_MAPPING_E, STEP_MAPPING_H) equal = (m1%mass == m2%mass) .and. (m1%width == m2%width) case default equal = (m1%mass == m2%mass) end select else equal = .false. end if end function mapping_equal @ %def mapping_equal @ \subsection{Mappings of the invariant mass} Inserting an $x$ value between 0 and 1, we want to compute the corresponding invariant mass $m^2(x)$ and the jacobian, aka phase space factor $f(x)$. We also need the reverse operation. In general, the phase space factor $f$ is defined by \begin{equation} \frac{1}{s}\int_{m^2_{\textrm{min}}}^{m^2_{\textrm{max}}} dm^2\,g(m^2) = \int_0^1 dx\,\frac{1}{s}\,\frac{dm^2}{dx}\,g(m^2(x)) = \int_0^1 dx\,f(x)\,g(x), \end{equation} where thus \begin{equation} f(x) = \frac{1}{s}\,\frac{dm^2}{dx}. \end{equation} With this mapping, a function of the form \begin{equation} g(m^2) = c\frac{dx(m^2)}{dm^2} \end{equation} is mapped to a constant: \begin{equation} \frac{1}{s}\int_{m^2_{\textrm{min}}}^{m^2_{\textrm{max}}} dm^2\,g(m^2) = \int_0^1 dx\,f(x)\,g(m^2(x)) = \int_0^1 dx\,\frac{c}{s}. \end{equation} Here is the mapping routine. Input are the available energy squared [[s]], the limits for $m^2$, and the $x$ value. Output are the $m^2$ value and the phase space factor $f$. <>= public :: mapping_compute_msq_from_x <>= subroutine mapping_compute_msq_from_x (map, s, msq_min, msq_max, msq, f, x) type(mapping_t), intent(inout) :: map real(default), intent(in) :: s, msq_min, msq_max real(default), intent(out) :: msq, f real(default), intent(in) :: x real(default) :: z, msq0, msq1, tmp integer :: type type = map%type if (s == 0) & call msg_fatal (" Applying msq mapping for zero energy") <> select case(type) case (NO_MAPPING) <> <> case (S_CHANNEL) <> <> case (COLLINEAR, INFRARED, RADIATION) <> <> case (T_CHANNEL, U_CHANNEL) <> <> case (STEP_MAPPING_E) <> <> case (STEP_MAPPING_H) <> <> case default call msg_fatal ( " Attempt to apply undefined msq mapping") end select end subroutine mapping_compute_msq_from_x @ %def mapping_compute_msq_from_x @ The inverse mapping <>= public :: mapping_compute_x_from_msq <>= subroutine mapping_compute_x_from_msq (map, s, msq_min, msq_max, msq, f, x) type(mapping_t), intent(inout) :: map real(default), intent(in) :: s, msq_min, msq_max real(default), intent(in) :: msq real(default), intent(out) :: f, x real(default) :: msq0, msq1, tmp, z integer :: type type = map%type if (s == 0) & call msg_fatal (" Applying inverse msq mapping for zero energy") <> select case (type) case (NO_MAPPING) <> <> case (S_CHANNEL) <> <> case (COLLINEAR, INFRARED, RADIATION) <> <> case (T_CHANNEL, U_CHANNEL) <> <> case (STEP_MAPPING_E) <> <> case (STEP_MAPPING_H) <> <> case default call msg_fatal ( " Attempt to apply undefined msq mapping") end select end subroutine mapping_compute_x_from_msq @ %def mapping_compute_x_from_msq @ \subsubsection{Trivial mapping} We simply map the boundaries of the interval $(m_{\textrm{min}}, m_{\textrm{max}})$ to $(0,1)$: \begin{equation} m^2 = (1-x) m_{\textrm{min}}^2 + x m_{\textrm{max}}^2; \end{equation} the inverse is \begin{equation} x = \frac{m^2 - m_{\textrm{min}}^2}{m_{\textrm{max}}^2- m_{\textrm{min}}^2}. \end{equation} Hence \begin{equation} f(x) = \frac{m_{\textrm{max}}^2 - m_{\textrm{min}}^2}{s}, \end{equation} and we have, as required, \begin{equation} f(x)\,\frac{dx}{dm^2} = \frac{1}{s}. \end{equation} We store the constant parameters the first time the mapping is called -- or, if limits vary, recompute them each time. <>= if (map%variable_limits .or. map%a_unknown) then map%a1 = 0 map%a2 = msq_max - msq_min map%a3 = map%a2 / s map%a_unknown = .false. end if <>= msq = (1-x) * msq_min + x * msq_max f = map%a3 <>= if (map%a2 /= 0) then x = (msq - msq_min) / map%a2 else x = 0 end if f = map%a3 @ Resonance or step mapping does not make much sense if the resonance mass is outside the kinematical bounds. If this is the case, revert to [[NO_MAPPING]]. This is possible even if the kinematical bounds vary from event to event. <>= select case (type) case (S_CHANNEL, STEP_MAPPING_E, STEP_MAPPING_H) msq0 = map%mass**2 if (msq0 < msq_min .or. msq0 > msq_max) type = NO_MAPPING end select @ \subsubsection{Breit-Wigner mapping} A Breit-Wigner resonance with mass $M$ and width $\Gamma$ is flattened by the following mapping: This mapping does not make much sense if the resonance mass is too low. If this is the case, revert to [[NO_MAPPING]]. There is a tricky point with this if the mass is too high: [[msq_max]] is not a constant if structure functions are around. However, switching the type depending on the overall energy does not change the integral, it is just another branching point. \begin{equation} m^2 = M(M+t\Gamma), \end{equation} where \begin{equation} t = \tan\left[(1-x)\arctan\frac{m^2_{\textrm{min}} - M^2}{M\Gamma} + x \arctan\frac{m^2_{\textrm{max}} - M^2}{M\Gamma}\right]. \end{equation} The inverse: \begin{equation} x = \frac{ \arctan\frac{m^2 - M^2}{M\Gamma} - \arctan\frac{m^2_{\textrm{min}} - M^2}{M\Gamma}} { \arctan\frac{m^2_{\textrm{max}} - M^2}{M\Gamma} - \arctan\frac{m^2_{\textrm{min}} - M^2}{M\Gamma}} \end{equation} The phase-space factor of this transformation is \begin{equation} f(x) = \frac{M\Gamma}{s}\left( \arctan\frac{m^2_{\textrm{max}} - M^2}{M\Gamma} - \arctan\frac{m^2_{\textrm{min}} - M^2}{M\Gamma}\right) (1 + t^2). \end{equation} This maps any function proportional to \begin{equation} g(m^2) = \frac{M\Gamma}{(m^2-M^2)^2 + M^2\Gamma^2} \end{equation} to a constant times $1/s$. <>= if (map%variable_limits .or. map%a_unknown) then msq0 = map%mass ** 2 map%a1 = atan ((msq_min - msq0) / (map%mass * map%width)) map%a2 = atan ((msq_max - msq0) / (map%mass * map%width)) map%a3 = (map%a2 - map%a1) * (map%mass * map%width) / s map%a_unknown = .false. end if <>= z = (1-x) * map%a1 + x * map%a2 if (-pi/2 < z .and. z < pi/2) then tmp = tan (z) msq = map%mass * (map%mass + map%width * tmp) f = map%a3 * (1 + tmp**2) else msq = 0 f = 0 end if <>= tmp = (msq - msq0) / (map%mass * map%width) x = (atan (tmp) - map%a1) / (map%a2 - map%a1) f = map%a3 * (1 + tmp**2) @ \subsubsection{Mapping for massless splittings} This mapping accounts for approximately scale-invariant behavior where $\ln M^2$ is evenly distributed. \begin{equation} m^2 = m_{\textrm{min}}^2 + M^2\left(\exp(xL)-1\right) \end{equation} where \begin{equation} L = \ln\left(\frac{m_{\textrm{max}}^2 - m_{\textrm{min}}^2}{M^2} + 1\right). \end{equation} The inverse: \begin{equation} x = \frac1L\ln\left(\frac{m^2-m_{\textrm{min}}^2}{M^2} + 1\right) \end{equation} The constant $M$ is a characteristic scale. Above this scale ($m^2-m_{\textrm{min}}^2 \gg M^2$), this mapping behaves like $x\propto\ln m^2$, while below the scale it reverts to a linear mapping. The phase-space factor is \begin{equation} f(x) = \frac{M^2}{s}\,\exp(xL)\,L. \end{equation} A function proportional to \begin{equation} g(m^2) = \frac{1}{(m^2-m_{\textrm{min}}^2) + M^2} \end{equation} is mapped to a constant, i.e., a simple pole near $m_{\textrm{min}}$ with a regulator mass $M$. This type of mapping is useful for massless collinear and infrared singularities, where the scale is stored as the mass parameter. In the radiation case (IR radiation off massive particle), the heavy particle width is the characteristic scale. <>= if (map%variable_limits .or. map%a_unknown) then if (type == RADIATION) then msq0 = map%width**2 else msq0 = map%mass**2 end if map%a1 = msq0 map%a2 = log ((msq_max - msq_min) / msq0 + 1) map%a3 = map%a2 / s map%a_unknown = .false. end if <>= msq1 = map%a1 * exp (x * map%a2) msq = msq1 - map%a1 + msq_min f = map%a3 * msq1 <>= msq1 = msq - msq_min + map%a1 x = log (msq1 / map%a1) / map%a2 f = map%a3 * msq1 @ \subsubsection{Mapping for t-channel poles} This is also approximately scale-invariant, and we use the same type of mapping as before. However, we map $1/x$ singularities at both ends of the interval; again, the mapping becomes linear when the distance is less than $M^2$: \begin{equation} m^2 = \begin{cases} m_{\textrm{min}}^2 + M^2\left(\exp(xL)-1\right) & \text{for $0 < x < \frac12$} \\ m_{\textrm{max}}^2 - M^2\left(\exp((1-x)L)-1\right) & \text{for $\frac12 \leq x < 1$} \end{cases} \end{equation} where \begin{equation} L = 2\ln\left(\frac{m_{\textrm{max}}^2 - m_{\textrm{min}}^2}{2M^2} + 1\right). \end{equation} The inverse: \begin{equation} x = \begin{cases} \frac1L\ln\left(\frac{m^2-m_{\textrm{min}}^2}{M^2} + 1\right) & \text{for $m^2 < (m_{\textrm{max}}^2 - m_{\textrm{min}}^2)/2$} \\ 1 - \frac1L\ln\left(\frac{m_{\textrm{max}}-m^2}{M^2} + 1\right) & \text{for $m^2 \geq (m_{\textrm{max}}^2 - m_{\textrm{min}}^2)/2$} \end{cases} \end{equation} The phase-space factor is \begin{equation} f(x) = \begin{cases} \frac{M^2}{s}\,\exp(xL)\,L. & \text{for $0 < x < \frac12$} \\ \frac{M^2}{s}\,\exp((1-x)L)\,L. & \text{for $\frac12 \leq x < 1$} \end{cases} \end{equation} A (continuous) function proportional to \begin{equation} g(m^2) = \begin{cases} 1/(m^2-m_{\textrm{min}}^2) + M^2) & \text{for $m^2 < (m_{\textrm{max}}^2 - m_{\textrm{min}}^2)/2$} \\ 1/((m_{\textrm{max}}^2 - m^2) + M^2) & \text{for $m^2 \leq (m_{\textrm{max}}^2 - m_{\textrm{min}}^2)/2$} \end{cases} \end{equation} is mapped to a constant by this mapping, i.e., poles near both ends of the interval. <>= if (map%variable_limits .or. map%a_unknown) then msq0 = map%mass**2 map%a1 = msq0 map%a2 = 2 * log ((msq_max - msq_min)/(2*msq0) + 1) map%a3 = map%a2 / s map%a_unknown = .false. end if <>= if (x < .5_default) then msq1 = map%a1 * exp (x * map%a2) msq = msq1 - map%a1 + msq_min else msq1 = map%a1 * exp ((1-x) * map%a2) msq = -(msq1 - map%a1) + msq_max end if f = map%a3 * msq1 <>= if (msq < (msq_max + msq_min)/2) then msq1 = msq - msq_min + map%a1 x = log (msq1/map%a1) / map%a2 else msq1 = msq_max - msq + map%a1 x = 1 - log (msq1/map%a1) / map%a2 end if f = map%a3 * msq1 @ \subsection{Step mapping} Step mapping is useful when the allowed range for a squared-mass variable is large, but only a fraction at the lower end is populated because the particle in question is an (off-shell) decay product of a narrow resonance. I.e., if the resonance was forced to be on-shell, the upper end of the range would be the resonance mass, minus the effective (real or resonance) mass of the particle(s) in the sibling branch of the decay. The edge of this phase space section has a width which is determined by the width of the parent, plus the width of the sibling branch. (The widths might be added in quadrature, but this precision is probably not important.) \subsubsection{Fermi function} A possible mapping is derived from the Fermi function which has precisely this behavior. The Fermi function is given by \begin{equation} f(x) = \frac{1}{1 + \exp\frac{x-\mu}{\gamma}} \end{equation} where $x$ is taken as the invariant mass squared, $\mu$ is the invariant mass squared of the edge, and $\gamma$ is the effective width which is given by the widths of the parent and the sibling branch. (Widths might be added in quadrature, but we do not require this level of precision.) \begin{align} x &= \frac{m^2 - m_{\text{min}}^2}{\Delta m^2} \\ \mu &= \frac{m_{\text{max,eff}}^2 - m_{\text{min}}^2} {\Delta m^2} \\ \gamma &= \frac{2m_{\text{max,eff}}\Gamma}{\Delta m^2} \end{align} with \begin{equation} \Delta m^2 = m_{\text{max}}^2 - m_{\text{min}}^2 \end{equation} $m^2$ is thus given by \begin{equation} m^2(x) = xm_{\text{max}}^2 + (1-x)m_{\text{min}}^2 \end{equation} For the mapping, we compute the integral $g(x)$ of the Fermi function, normalized such that $g(0)=0$ and $g(1)=1$. We introduce the abbreviations \begin{align} \alpha &= 1 - \gamma\ln\frac{1 + \beta e^{1/\gamma}}{1 + \beta} \\ \beta &= e^{- \mu/\gamma} \end{align} and obtain \begin{equation} g(x) = \frac{1}{\alpha} \left(x - \gamma\ln\frac{1 + \beta e^{x/\gamma}} {1 + \beta}\right) \end{equation} The actual mapping is the inverse function $h(y) = g^{-1}(y)$, \begin{equation} h(y) = -\gamma\ln\left(e^{-\alpha y/\gamma}(1 + \beta) - \beta\right) \end{equation} The Jacobian is \begin{equation} \frac{dh}{dy} = \alpha\left(1 - e^{\alpha y/\gamma} \frac{\beta}{1 + \beta}\right)^{-1} \end{equation} which is equal to $1/(dg/dx)$, namely \begin{equation} \frac{dg}{dx} = \frac{1}{\alpha}\,\frac{1}{1 + \beta e^{x/\gamma}} \end{equation} The final result is \begin{align} \int_{m_{\text{min}}^2}^{m_{\text{max}}^2} dm^2\,F(m^2) &= \Delta m^2\int_0^1\,dx\,F(m^2(x)) \\ &= \Delta m^2\int_0^1\,dy\,F(m^2(h(y)))\,\frac{dh}{dy} \end{align} Here is the implementation. We fill [[a1]], [[a2]], [[a3]] with $\alpha,\beta,\gamma$, respectively. <>= if (map%variable_limits .or. map%a_unknown) then map%a3 = max (2 * map%mass * map%width / (msq_max - msq_min), 0.01_default) map%a2 = exp (- (map%mass**2 - msq_min) / (msq_max - msq_min) & / map%a3) map%a1 = 1 - map%a3 * log ((1 + map%a2 * exp (1 / map%a3)) / (1 + map%a2)) end if <>= tmp = exp (- x * map%a1 / map%a3) * (1 + map%a2) z = - map%a3 * log (tmp - map%a2) msq = z * msq_max + (1 - z) * msq_min f = map%a1 / (1 - map%a2 / tmp) * (msq_max - msq_min) / s <>= z = (msq - msq_min) / (msq_max - msq_min) tmp = 1 + map%a2 * exp (z / map%a3) x = (z - map%a3 * log (tmp / (1 + map%a2))) & / map%a1 f = map%a1 * tmp * (msq_max - msq_min) / s @ \subsubsection{Hyperbolic mapping} The Fermi function has the drawback that it decreases exponentially. It might be preferable to take a function with a power-law decrease, such that the high-mass region is not completely depopulated. Here, we start with the actual mapping which we take as \begin{equation} h(y) = \frac{b}{a-y} - \frac{b}{a} + \mu y \end{equation} with the abbreviation \begin{equation} a = \frac12\left(1 + \sqrt{1 + \frac{4b}{1-\mu}}\right) \end{equation} This is a hyperbola in the $xy$ plane. The derivative is \begin{equation} \frac{dh}{dy} = \frac{b}{(a-y)^2} + \mu \end{equation} The constants correspond to \begin{align} \mu &= \frac{m_{\text{max,eff}}^2 - m_{\text{min}}^2} {\Delta m^2} \\ b &= \frac{1}{\mu}\left(\frac{2m_{\text{max,eff}}\Gamma}{\Delta m^2}\right)^2 \end{align} The inverse function is the solution of a quadratic equation, \begin{equation} g(x) = \frac{1}{2} \left[\left(a + \frac{x}{\mu} + \frac{b}{a\mu}\right) - \sqrt{\left(a-\frac{x}{\mu}\right)^2 + 2\frac{b}{a\mu}\left(a + \frac{x}{\mu}\right) + \left(\frac{b}{a\mu}\right)^2}\right] \end{equation} The constants $a_{1,2,3}$ are identified with $a,b,\mu$. <>= if (map%variable_limits .or. map%a_unknown) then map%a3 = (map%mass**2 - msq_min) / (msq_max - msq_min) map%a2 = max ((2 * map%mass * map%width / (msq_max - msq_min))**2 & / map%a3, 1e-6_default) map%a1 = (1 + sqrt (1 + 4 * map%a2 / (1 - map%a3))) / 2 end if <>= z = map%a2 / (map%a1 - x) - map%a2 / map%a1 + map%a3 * x msq = z * msq_max + (1 - z) * msq_min f = (map%a2 / (map%a1 - x)**2 + map%a3) * (msq_max - msq_min) / s <>= z = (msq - msq_min) / (msq_max - msq_min) tmp = map%a2 / (map%a1 * map%a3) x = ((map%a1 + z / map%a3 + tmp) & - sqrt ((map%a1 - z / map%a3)**2 + 2 * tmp * (map%a1 + z / map%a3) & + tmp**2)) / 2 f = (map%a2 / (map%a1 - x)**2 + map%a3) * (msq_max - msq_min) / s @ \subsection{Mappings of the polar angle} The other type of singularity, a simple pole just outside the integration region, can occur in the integration over $\cos\theta$. This applies to exchange of massless (or light) particles. Double poles (Coulomb scattering) are also possible, but only in certain cases. These are also handled by the single-pole mapping. The mapping is analogous to the previous $m^2$ pole mapping, but with a different normalization and notation of variables: \begin{equation} \frac12\int_{-1}^1 d\cos\theta\,g(\theta) = \int_0^1 dx\,\frac{d\cos\theta}{dx}\,g(\theta(x)) = \int_0^1 dx\,f(x)\,g(x), \end{equation} where thus \begin{equation} f(x) = \frac12\,\frac{d\cos\theta}{dx}. \end{equation} With this mapping, a function of the form \begin{equation} g(\theta) = c\frac{dx(\cos\theta)}{d\cos\theta} \end{equation} is mapped to a constant: \begin{equation} \int_{-1}^1 d\cos\theta\,g(\theta) = \int_0^1 dx\,f(x)\,g(\theta(x)) = \int_0^1 dx\,c. \end{equation} <>= public :: mapping_compute_ct_from_x <>= subroutine mapping_compute_ct_from_x (map, s, ct, st, f, x) type(mapping_t), intent(inout) :: map real(default), intent(in) :: s real(default), intent(out) :: ct, st, f real(default), intent(in) :: x real(default) :: tmp, ct1 select case (map%type) case (NO_MAPPING, S_CHANNEL, INFRARED, RADIATION, & STEP_MAPPING_E, STEP_MAPPING_H) <> case (T_CHANNEL, U_CHANNEL, COLLINEAR) <> <> case default call msg_fatal (" Attempt to apply undefined ct mapping") end select end subroutine mapping_compute_ct_from_x @ %def mapping_compute_ct_from_x <>= public :: mapping_compute_x_from_ct <>= subroutine mapping_compute_x_from_ct (map, s, ct, f, x) type(mapping_t), intent(inout) :: map real(default), intent(in) :: s real(default), intent(in) :: ct real(default), intent(out) :: f, x real(default) :: ct1 select case (map%type) case (NO_MAPPING, S_CHANNEL, INFRARED, RADIATION, & STEP_MAPPING_E, STEP_MAPPING_H) <> case (T_CHANNEL, U_CHANNEL, COLLINEAR) <> <> case default call msg_fatal (" Attempt to apply undefined inverse ct mapping") end select end subroutine mapping_compute_x_from_ct @ %def mapping_compute_x_from_ct @ \subsubsection{Trivial mapping} This is just the mapping of the interval $(-1,1)$ to $(0,1)$: \begin{equation} \cos\theta = -1 + 2x \end{equation} and \begin{equation} f(x) = 1 \end{equation} with the inverse \begin{equation} x = \frac{1+\cos\theta}{2} \end{equation} <>= tmp = 2 * (1-x) ct = 1 - tmp st = sqrt (tmp * (2-tmp)) f = 1 <>= x = (ct + 1) / 2 f = 1 @ \subsubsection{Pole mapping} As above for $m^2$, we simultaneously map poles at both ends of the $\cos\theta$ interval. The formulae are completely analogous: \begin{equation} \cos\theta = \begin{cases} \frac{M^2}{s}\left[\exp(xL)-1\right] - 1 & \text{for $x<\frac12$} \\ -\frac{M^2}{s}\left[\exp((1-x)L)-1\right] + 1 & \text{for $x\geq\frac12$} \end{cases} \end{equation} where \begin{equation} L = 2\ln\frac{M^2+s}{M^2}. \end{equation} Inverse: \begin{equation} x = \begin{cases} \frac{1}{2L}\ln\frac{1 + \cos\theta + M^2/s}{M^2/s} & \text{for $\cos\theta < 0$} \\ 1 - \frac{1}{2L}\ln\frac{1 - \cos\theta + M^2/s}{M^2/s} & \text{for $\cos\theta \geq 0$} \end{cases} \end{equation} The phase-space factor: \begin{equation} f(x) = \begin{cases} \frac{M^2}{s}\exp(xL)\,L & \text{for $x<\frac12$} \\ \frac{M^2}{s}\exp((1-x)L)\,L & \text{for $x\geq\frac12$} \end{cases} \end{equation} <>= if (map%variable_limits .or. map%b_unknown) then map%b1 = map%mass**2 / s map%b2 = log ((map%b1 + 1) / map%b1) map%b3 = 0 map%b_unknown = .false. end if <>= if (x < .5_default) then ct1 = map%b1 * exp (2 * x * map%b2) ct = ct1 - map%b1 - 1 else ct1 = map%b1 * exp (2 * (1-x) * map%b2) ct = -(ct1 - map%b1) + 1 end if if (ct >= -1 .and. ct <= 1) then st = sqrt (1 - ct**2) f = ct1 * map%b2 else ct = 1; st = 0; f = 0 end if <>= if (ct < 0) then ct1 = ct + map%b1 + 1 x = log (ct1 / map%b1) / (2 * map%b2) else ct1 = -ct + map%b1 + 1 x = 1 - log (ct1 / map%b1) / (2 * map%b2) end if f = ct1 * map%b2 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \clearpage \section{Phase-space trees} The phase space evaluation is organized in terms of trees, where each branch corresponds to three integrations: $m^2$, $\cos\theta$, and $\phi$. The complete tree thus makes up a specific parameterization of the multidimensional phase-space integral. For the multi-channel integration, the phase-space tree is a single channel. The trees imply mappings of formal Feynman tree graphs into arrays of integer numbers: Each branch, corresponding to a particular line in the graph, is assigned an integer code $c$ (with kind value [[TC]] = tree code). In this integer, each bit determines whether a particular external momentum flows through the line. The external branches therefore have codes $1,2,4,8,\ldots$. An internal branch has those bits ORed corresponding to the momenta flowing through it. For example, a branch with momentum $p_1+p_4$ has code $2^0+2^3=1+8=9$. There is a two-fold ambiguity: Momentum conservation implies that the branch with code \begin{equation} c_0 = \sum_{i=1}^{n(\rm{ext})} 2^{i-1} \end{equation} i.e. the branch with momentum $p_1+p_2+\ldots p_n$ has momentum zero, which is equivalent to tree code $0$ by definition. Correspondingly, \begin{equation} c \quad\textrm{and}\quad c_0 - c = c\;\textrm{XOR}\;c_0 \end{equation} are equivalent. E.g., if there are five externals with codes $c=1,2,4,8,16$, then $c=9$ and $\bar c=31-9=22$ are equivalent. This ambiguity may be used to assign a direction to the line: If all momenta are understood as outgoing, $c=9$ in the example above means $p_1+p_4$, but $c=22$ means $p_2+p_3+p_5 = -(p_1+p_4)$. Here we make use of the ambiguity in a slightly different way. First, the initial particles are singled out as those externals with the highest bits, the IN-bits. (Here: $8$ and $16$ for a $2\to 3$ scattering process, $16$ only for a $1\to 4$ decay.) Then we invert those codes where all IN-bits are set. For a decay process this maps each tree of an equivalence class onto a unique representative (that one with the smallest integer codes). For a scattering process we proceed further: The ambiguity remains in all branches where only one IN-bit is set, including the initial particles. If there are only externals with this property, we have an $s$-channel graph which we leave as it is. In all other cases, an internal with only one IN-bit is a $t$-channel line, which for phase space integration should be associated with one of the initial momenta as a reference axis. We take that one whose bit is set in the current tree code. (E.g., for branch $c=9$ we use the initial particle $c=8$ as reference axis, whereas for the same branch we would take $c=16$ if it had been assigned $\bar c=31-9=22$ as tree code.) Thus, different ways of coding the same $t$-channel graph imply different phase space parameterizations. $s$-channel graphs have a unique parameterization. The same sets of parameterizations are used for $t$-channel graphs, except for the reference frames of their angular parts. We map each $t$-channel graph onto an $s$-channel graph as follows: Working in ascending order, for each $t$-channel line (whose code has exactly one IN-bit set) the attached initial line is flipped upstream, while the outgoing line is flipped downstream. (This works only if $t$-channel graphs are always parameterized beginning at their outer vertices, which we require as a restriction.) After all possible flips have been applied, we have an $s$-channel graph. We only have to remember the initial particle a vertex was originally attached to. <<[[phs_trees.f90]]>>= <> module phs_trees <> use kinds, only: TC <> use io_units use constants, only: twopi, twopi2, twopi5 use format_defs, only: FMT_19 use numeric_utils, only: vanishes use diagnostics use lorentz use permutations, only: permutation_t, permutation_size use permutations, only: permutation_init, permutation_find use permutations, only: tc_decay_level, tc_permute use model_data use flavors use resonances, only: resonance_history_t, resonance_info_t use mappings <> <> <> contains <> end module phs_trees @ %def phs_trees @ \subsection{Particles} We define a particle type which contains only four-momentum and invariant mass squared, and a flag that tells whether the momentum is filled or not. <>= public :: phs_prt_t <>= type :: phs_prt_t private logical :: defined = .false. type(vector4_t) :: p real(default) :: p2 end type phs_prt_t @ %def phs_prt_t @ Set contents: <>= public :: phs_prt_set_defined public :: phs_prt_set_undefined public :: phs_prt_set_momentum public :: phs_prt_set_msq <>= elemental subroutine phs_prt_set_defined (prt) type(phs_prt_t), intent(inout) :: prt prt%defined = .true. end subroutine phs_prt_set_defined elemental subroutine phs_prt_set_undefined (prt) type(phs_prt_t), intent(inout) :: prt prt%defined = .false. end subroutine phs_prt_set_undefined elemental subroutine phs_prt_set_momentum (prt, p) type(phs_prt_t), intent(inout) :: prt type(vector4_t), intent(in) :: p prt%p = p end subroutine phs_prt_set_momentum elemental subroutine phs_prt_set_msq (prt, p2) type(phs_prt_t), intent(inout) :: prt real(default), intent(in) :: p2 prt%p2 = p2 end subroutine phs_prt_set_msq @ %def phs_prt_set_defined phs_prt_set_momentum phs_prt_set_msq @ Access methods: <>= public :: phs_prt_is_defined public :: phs_prt_get_momentum public :: phs_prt_get_msq <>= elemental function phs_prt_is_defined (prt) result (defined) logical :: defined type(phs_prt_t), intent(in) :: prt defined = prt%defined end function phs_prt_is_defined elemental function phs_prt_get_momentum (prt) result (p) type(vector4_t) :: p type(phs_prt_t), intent(in) :: prt p = prt%p end function phs_prt_get_momentum elemental function phs_prt_get_msq (prt) result (p2) real(default) :: p2 type(phs_prt_t), intent(in) :: prt p2 = prt%p2 end function phs_prt_get_msq @ %def phs_prt_is_defined phs_prt_get_momentum phs_prt_get_msq @ Addition of momenta (invariant mass square is computed). <>= public :: phs_prt_combine <>= elemental subroutine phs_prt_combine (prt, prt1, prt2) type(phs_prt_t), intent(inout) :: prt type(phs_prt_t), intent(in) :: prt1, prt2 prt%defined = .true. prt%p = prt1%p + prt2%p prt%p2 = prt%p ** 2 call phs_prt_check (prt) end subroutine phs_prt_combine @ %def phs_prt_combine @ Output <>= public :: phs_prt_write <>= subroutine phs_prt_write (prt, unit) type(phs_prt_t), intent(in) :: prt integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return if (prt%defined) then call vector4_write (prt%p, u) write (u, "(1x,A,1x," // FMT_19 // ")") "T = ", prt%p2 else write (u, "(3x,A)") "[undefined]" end if end subroutine phs_prt_write @ %def phs_prt_write <>= public :: phs_prt_check <>= elemental subroutine phs_prt_check (prt) type(phs_prt_t), intent(inout) :: prt if (prt%p2 < 0._default) then prt%p2 = 0._default end if end subroutine phs_prt_check @ %def phs_prt_check @ \subsection{The phase-space tree type} \subsubsection{Definition} In the concrete implementation, each branch $c$ may have two \emph{daughters} $c_1$ and $c_2$ such that $c_1+c_2=c$, a \emph{sibling} $c_s$ and a \emph{mother} $c_m$ such that $c+c_s = c_m$, and a \emph{friend} which is kept during flips, such that it can indicate a fixed reference frame. Absent entries are set $c=0$. First, declare the branch type. There is some need to have this public. Give initializations for all components, so no [[init]] routine is necessary. The branch has some information about the associated coordinates and about connections. <>= type :: phs_branch_t private logical :: set = .false. logical :: inverted_decay = .false. logical :: inverted_axis = .false. integer(TC) :: mother = 0 integer(TC) :: sibling = 0 integer(TC) :: friend = 0 integer(TC) :: origin = 0 integer(TC), dimension(2) :: daughter = 0 integer :: firstborn = 0 logical :: has_children = .false. logical :: has_friend = .false. logical :: is_real = .false. end type phs_branch_t @ %def phs_branch_t @ The tree type: No initialization, this is done by [[phs_tree_init]]. In addition to the branch array which The branches are collected in an array which holds all possible branches, of which only a few are set. After flips have been applied, the branch $c_M=\sum_{i=1}^{n({\rm fin})}2^{i-1}$ must be there, indicating the mother of all decay products. In addition, we should check for consistency at the beginning. [[n_branches]] is the number of those actually set. [[n_externals]] defines the number of significant bit, and [[mask]] is a code where all bits are set. Analogous: [[n_in]] and [[mask_in]] for the incoming particles. The [[mapping]] array contains the mappings associated to the branches (corresponding indices). The array [[mass_sum]] contains the sum of the real masses of the external final-state particles associated to the branch. During phase-space evaluation, this determines the boundaries. <>= public :: phs_tree_t <>= type :: phs_tree_t private integer :: n_branches, n_externals, n_in, n_msq, n_angles integer(TC) :: n_branches_tot, n_branches_out integer(TC) :: mask, mask_in, mask_out type(phs_branch_t), dimension(:), allocatable :: branch type(mapping_t), dimension(:), allocatable :: mapping real(default), dimension(:), allocatable :: mass_sum real(default), dimension(:), allocatable :: effective_mass real(default), dimension(:), allocatable :: effective_width logical :: real_phsp = .false. integer, dimension(:), allocatable :: momentum_link contains <> end type phs_tree_t @ %def phs_tree_t @ The maximum number of external particles that can be represented is related to the bit size of the integer that stores binary codes. With the default integer of 32 bit on common machines, this is more than enough space. If [[TC]] is actually the default integer kind, there is no need to keep it separate, but doing so marks this as a special type of integer. So, just state that the maximum number is 32: <>= integer, parameter, public :: MAX_EXTERNAL = 32 @ %def MAX_EXTERNAL @ \subsubsection{Constructor and destructor} Allocate memory for a phase-space tree with given number of externals and incoming. The number of allocated branches can easily become large, but appears manageable for realistic cases, e.g., for [[n_in=2]] and [[n_out=8]] we get $2^{10}-1=1023$. <>= public :: phs_tree_init public :: phs_tree_final @ Here we set the masks for incoming and for all externals. <>= procedure :: init => phs_tree_init procedure :: final => phs_tree_final <>= elemental subroutine phs_tree_init (tree, n_in, n_out, n_masses, n_angles) class(phs_tree_t), intent(inout) :: tree integer, intent(in) :: n_in, n_out, n_masses, n_angles integer(TC) :: i tree%n_externals = n_in + n_out tree%n_branches_tot = 2**(n_in+n_out) - 1 tree%n_branches_out = 2**n_out - 1 tree%mask = 0 do i = 0, n_in + n_out - 1 tree%mask = ibset (tree%mask, i) end do tree%n_in = n_in tree%mask_in = 0 do i = n_out, n_in + n_out - 1 tree%mask_in = ibset (tree%mask_in, i) end do tree%mask_out = ieor (tree%mask, tree%mask_in) tree%n_msq = n_masses tree%n_angles = n_angles allocate (tree%branch (tree%n_branches_tot)) tree%n_branches = 0 allocate (tree%mapping (tree%n_branches_out)) allocate (tree%mass_sum (tree%n_branches_out)) allocate (tree%effective_mass (tree%n_branches_out)) allocate (tree%effective_width (tree%n_branches_out)) end subroutine phs_tree_init elemental subroutine phs_tree_final (tree) class(phs_tree_t), intent(inout) :: tree deallocate (tree%branch) deallocate (tree%mapping) deallocate (tree%mass_sum) deallocate (tree%effective_mass) deallocate (tree%effective_width) end subroutine phs_tree_final @ %def phs_tree_init phs_tree_final @ \subsubsection{Screen output} Write only the branches that are set: <>= public :: phs_tree_write <>= procedure :: write => phs_tree_write <>= subroutine phs_tree_write (tree, unit) class(phs_tree_t), intent(in) :: tree integer, intent(in), optional :: unit integer :: u integer(TC) :: k u = given_output_unit (unit); if (u < 0) return write (u, '(3X,A,1x,I0,5X,A,I3)') & 'External:', tree%n_externals, 'Mask:', tree%mask write (u, '(3X,A,1x,I0,5X,A,I3)') & 'Incoming:', tree%n_in, 'Mask:', tree%mask_in write (u, '(3X,A,1x,I0,5X,A,I3)') & 'Branches:', tree%n_branches do k = size (tree%branch), 1, -1 if (tree%branch(k)%set) & call phs_branch_write (tree%branch(k), unit=unit, kval=k) end do do k = 1, size (tree%mapping) call mapping_write (tree%mapping (k), unit, verbose=.true.) end do write (u, "(3x,A)") "Arrays: mass_sum, effective_mass, effective_width" do k = 1, size (tree%mass_sum) if (tree%branch(k)%set) then write (u, "(5x,I0,3(2x," // FMT_19 // "))") k, tree%mass_sum(k), & tree%effective_mass(k), tree%effective_width(k) end if end do end subroutine phs_tree_write subroutine phs_branch_write (b, unit, kval) type(phs_branch_t), intent(in) :: b integer, intent(in), optional :: unit integer(TC), intent(in), optional :: kval integer :: u integer(TC) :: k character(len=6) :: tmp character(len=1) :: firstborn(2), sign_decay, sign_axis integer :: i u = given_output_unit (unit); if (u < 0) return k = 0; if (present (kval)) k = kval if (b%origin /= 0) then write(tmp, '(A,I4,A)') '(', b%origin, ')' else tmp = ' ' end if do i=1, 2 if (b%firstborn == i) then firstborn(i) = "*" else firstborn(i) = " " end if end do if (b%inverted_decay) then sign_decay = "-" else sign_decay = "+" end if if (b%inverted_axis) then sign_axis = "-" else sign_axis = "+" end if if (b%has_children) then if (b%has_friend) then write(u,'(4X,A1,I0,3x,A,1X,A,I0,A1,1x,I0,A1,1X,A1,1X,A,1x,I0)') & & '*', k, tmp, & & 'Daughters: ', & & b%daughter(1), firstborn(1), & & b%daughter(2), firstborn(2), sign_decay, & & 'Friend: ', b%friend else write(u,'(4X,A1,I0,3x,A,1X,A,I0,A1,1x,I0,A1,1X,A1,1X,A)') & & '*', k, tmp, & & 'Daughters: ', & & b%daughter(1), firstborn(1), & & b%daughter(2), firstborn(2), sign_decay, & & '(axis '//sign_axis//')' end if else write(u,'(5X,I0)') k end if end subroutine phs_branch_write @ %def phs_tree_write phs_branch_write @ \subsection{PHS tree setup} \subsubsection{Transformation into an array of branch codes and back} Assume that the tree/array has been created before with the appropriate length and is empty. <>= public :: phs_tree_from_array <>= procedure :: from_array => phs_tree_from_array <>= subroutine phs_tree_from_array (tree, a) class(phs_tree_t), intent(inout) :: tree integer(TC), dimension(:), intent(in) :: a integer :: i integer(TC) :: k <> <> <> <> contains <> end subroutine phs_tree_from_array @ %def phs_tree_from_array @ First, set all branches specified by the user. If all IN-bits are set, we invert the branch code. <>= do i=1, size(a) k = a(i) if (iand(k, tree%mask_in) == tree%mask_in) k = ieor(tree%mask, k) tree%branch(k)%set = .true. tree%n_branches = tree%n_branches+1 end do @ The external branches are understood, so set them now if not yet done. In all cases ensure that the representative with one bit set is used, except for decays where the in-particle is represented by all OUT-bits set instead. <>= do i=0, tree%n_externals-1 k = ibset(0,i) if (iand(k, tree%mask_in) == tree%mask_in) k = ieor(tree%mask, k) if (tree%branch(ieor(tree%mask, k))%set) then tree%branch(ieor(tree%mask, k))%set = .false. tree%branch(k)%set = .true. else if (.not.tree%branch(k)%set) then tree%branch(k)%set = .true. tree%n_branches = tree%n_branches+1 end if end do @ Now the number of branches set can be checked. Here we assume that the tree is binary. For three externals there are three branches in total, and for each additional external branch we get another internal one. <>= if (tree%n_branches /= tree%n_externals*2-3) then call phs_tree_write (tree) call msg_bug & & (" Wrong number of branches set in phase space tree") end if @ For all branches that are set, except for the externals, we try to find the daughter branches: <>= do k=1, size (tree%branch) if (tree%branch(k)%set .and. tc_decay_level (k) /= 1) then call branch_set_relatives(k) end if end do @ To this end, we scan all codes less than the current code, whether we can find two branches which are set and which together give the current code. After that, the tree may still not be connected, but at least we know if a branch does not have daughters: This indicates some inconsistency. The algorithm ensures that, at this stage, the first daughter has a smaller code value than the second one. <>= subroutine branch_set_relatives (k) integer(TC), intent(in) :: k integer(TC) :: m,n do m=1, k-1 if(iand(k,m)==m) then n = ieor(k,m) if ( tree%branch(m)%set .and. tree%branch(n)%set ) then tree%branch(k)%daughter(1) = m; tree%branch(k)%daughter(2) = n tree%branch(m)%mother = k; tree%branch(n)%mother = k tree%branch(m)%sibling = n; tree%branch(n)%sibling = m tree%branch(k)%has_children = .true. return end if end if end do call phs_tree_write (tree) call msg_bug & & (" Missing daughter branch(es) in phase space tree") end subroutine branch_set_relatives @ The inverse: this is trivial, fortunately. @ \subsubsection{Flip $t$-channel into $s$-channel} Flipping the tree is done upwards, beginning from the decay products. First we select a $t$-channel branch [[k]]: one which is set, which does have an IN-bit, and which is not an external particle. Next, we determine the adjacent in-particle (called the 'friend' [[f]] here, since it will provide the reference axis for the angular integration). In addition, we look for the 'mother' and 'sibling' of this particle. If the latter field is empty, we select the (unique) other out-particle which has no mother, calling the internal subroutine [[find_orphan]]. The flip is done as follows: We assume that the first daughter [[d]] is an $s$-channel line, which is true if the daughters are sorted. This will stay the first daughter. The second one is a $t$-channel line; it is exchanged with the 'sibling' [[s]]. The new line which replaces the branch [[k]] is just the sum of [[s]] and [[d]]. In addition, we have to rearrange the relatives of [[s]] and [[d]], as well of [[f]]. Finally, we flip 'sibling' and 'friend' and set the new $s$-channel branch [[n]] which replaces the $t$-channel branch [[k]]. After this is complete, we are ready to execute another flip. [Although the friend is not needed for the final flip, since it would be an initial particle anyway, we need to know whether we have $t$- or $u$-channel.] <>= public :: phs_tree_flip_t_to_s_channel <>= subroutine phs_tree_flip_t_to_s_channel (tree) type(phs_tree_t), intent(inout) :: tree integer(TC) :: k, f, m, n, d, s if (tree%n_in == 2) then FLIP: do k=3, tree%mask-1 if (.not. tree%branch(k)%set) cycle FLIP f = iand(k,tree%mask_in) if (f==0 .or. f==k) cycle FLIP m = tree%branch(k)%mother s = tree%branch(k)%sibling if (s==0) call find_orphan(s) d = tree%branch(k)%daughter(1) n = ior(d,s) tree%branch(k)%set = .false. tree%branch(n)%set = .true. tree%branch(n)%origin = k tree%branch(n)%daughter(1) = d; tree%branch(d)%mother = n tree%branch(n)%daughter(2) = s; tree%branch(s)%mother = n tree%branch(n)%has_children = .true. tree%branch(d)%sibling = s; tree%branch(s)%sibling = d tree%branch(n)%sibling = f; tree%branch(f)%sibling = n tree%branch(n)%mother = m tree%branch(f)%mother = m if (m/=0) then tree%branch(m)%daughter(1) = n tree%branch(m)%daughter(2) = f end if tree%branch(n)%friend = f tree%branch(n)%has_friend = .true. tree%branch(n)%firstborn = 2 end do FLIP end if contains subroutine find_orphan(s) integer(TC) :: s do s=1, tree%mask_out if (tree%branch(s)%set .and. tree%branch(s)%mother==0) return end do call phs_tree_write (tree) call msg_bug (" Can't flip phase space tree to channel") end subroutine find_orphan end subroutine phs_tree_flip_t_to_s_channel @ %def phs_tree_flip_t_to_s_channel @ After the tree has been flipped, one may need to determine what has become of a particular $t$-channel branch. This function gives the bincode of the flipped tree. If the original bincode does not contain IN-bits, we leave it as it is. <>= function tc_flipped (tree, kt) result (ks) type(phs_tree_t), intent(in) :: tree integer(TC), intent(in) :: kt integer(TC) :: ks if (iand (kt, tree%mask_in) == 0) then ks = kt else ks = tree%branch(iand (kt, tree%mask_out))%mother end if end function tc_flipped @ %def tc_flipped @ Scan a tree and make sure that the first daughter has always a smaller code than the second one. Furthermore, delete any [[friend]] entry in the root branch -- this branching has the incoming particle direction as axis anyway. Keep track of reordering by updating [[inverted_axis]], [[inverted_decay]] and [[firstborn]]. <>= public :: phs_tree_canonicalize <>= subroutine phs_tree_canonicalize (tree) type(phs_tree_t), intent(inout) :: tree integer :: n_out integer(TC) :: k_out call branch_canonicalize (tree%branch(tree%mask_out)) n_out = tree%n_externals - tree%n_in k_out = tree%mask_out if (tree%branch(k_out)%has_friend & & .and. tree%branch(k_out)%friend == ibset (0, n_out)) then tree%branch(k_out)%inverted_axis = .not.tree%branch(k_out)%inverted_axis end if tree%branch(k_out)%has_friend = .false. tree%branch(k_out)%friend = 0 contains recursive subroutine branch_canonicalize (b) type(phs_branch_t), intent(inout) :: b integer(TC) :: d1, d2 if (b%has_children) then d1 = b%daughter(1) d2 = b%daughter(2) if (d1 > d2) then b%daughter(1) = d2 b%daughter(2) = d1 b%inverted_decay = .not.b%inverted_decay if (b%firstborn /= 0) b%firstborn = 3 - b%firstborn end if call branch_canonicalize (tree%branch(b%daughter(1))) call branch_canonicalize (tree%branch(b%daughter(2))) end if end subroutine branch_canonicalize end subroutine phs_tree_canonicalize @ %def phs_tree_canonicalize @ \subsubsection{Mappings} Initialize a mapping for the current tree. This is done while reading from file, so the mapping parameters are read, but applied to the flipped tree. Thus, the size of the array of mappings is given by the number of outgoing particles only. <>= public :: phs_tree_init_mapping <>= procedure :: init_mapping => phs_tree_init_mapping <>= subroutine phs_tree_init_mapping (tree, k, type, pdg, model) class(phs_tree_t), intent(inout) :: tree integer(TC), intent(in) :: k type(string_t), intent(in) :: type integer, intent(in) :: pdg class(model_data_t), intent(in), target :: model integer(TC) :: kk kk = tc_flipped (tree, k) call mapping_init (tree%mapping(kk), kk, type, pdg, model) end subroutine phs_tree_init_mapping @ %def phs_tree_init_mapping @ Set the physical parameters for the mapping, using a specific parameter set. Also set the mass sum array. <>= public :: phs_tree_set_mapping_parameters <>= procedure :: set_mapping_parameters => phs_tree_set_mapping_parameters <>= subroutine phs_tree_set_mapping_parameters & (tree, mapping_defaults, variable_limits) class(phs_tree_t), intent(inout) :: tree type(mapping_defaults_t), intent(in) :: mapping_defaults logical, intent(in) :: variable_limits integer(TC) :: k do k = 1, tree%n_branches_out call mapping_set_parameters & (tree%mapping(k), mapping_defaults, variable_limits) end do end subroutine phs_tree_set_mapping_parameters @ %def phs_tree_set_mapping_parameters @ Return the mapping for the sum of all outgoing particles. This should either be no mapping or a global s-channel mapping. <>= public :: phs_tree_assign_s_mapping <>= subroutine phs_tree_assign_s_mapping (tree, mapping) type(phs_tree_t), intent(in) :: tree type(mapping_t), intent(out) :: mapping mapping = tree%mapping(tree%mask_out) end subroutine phs_tree_assign_s_mapping @ %def phs_tree_assign_s_mapping @ \subsubsection{Kinematics} Fill the mass sum array, starting from the external particles and working down to the tree root. For each bincode [[k]] we scan the bits in [[k]]; if only one is set, we take the physical mass of the corresponding external particle; if more then one is set, we sum up the two masses (which we know have already been set). <>= public :: phs_tree_set_mass_sum <>= procedure :: set_mass_sum => phs_tree_set_mass_sum <>= subroutine phs_tree_set_mass_sum (tree, flv) class(phs_tree_t), intent(inout) :: tree type(flavor_t), dimension(:), intent(in) :: flv integer(TC) :: k integer :: i tree%mass_sum = 0 do k = 1, tree%n_branches_out do i = 0, size (flv) - 1 if (btest(k,i)) then if (ibclr(k,i) == 0) then tree%mass_sum(k) = flv(i+1)%get_mass () else tree%mass_sum(k) = & tree%mass_sum(ibclr(k,i)) + tree%mass_sum(ibset(0,i)) end if exit end if end do end do end subroutine phs_tree_set_mass_sum @ %def phs_tree_set_mass_sum @ Set the effective masses and widths. For each non-resonant branch in a tree, the effective mass is equal to the sum of the effective masses of the children (and analogous for the width). External particles have their real mass and width zero. For resonant branches, we insert mass and width from the corresponding mapping. This routine has [[phs_tree_set_mass_sum]] and [[phs_tree_set_mapping_parameters]] as prerequisites. <>= public :: phs_tree_set_effective_masses <>= procedure :: set_effective_masses => phs_tree_set_effective_masses <>= subroutine phs_tree_set_effective_masses (tree) class(phs_tree_t), intent(inout) :: tree tree%effective_mass = 0 tree%effective_width = 0 call set_masses_x (tree%mask_out) contains recursive subroutine set_masses_x (k) integer(TC), intent(in) :: k integer(TC) :: k1, k2 if (tree%branch(k)%has_children) then k1 = tree%branch(k)%daughter(1) k2 = tree%branch(k)%daughter(2) call set_masses_x (k1) call set_masses_x (k2) if (mapping_is_s_channel (tree%mapping(k))) then tree%effective_mass(k) = mapping_get_mass (tree%mapping(k)) tree%effective_width(k) = mapping_get_width (tree%mapping(k)) else tree%effective_mass(k) = & tree%effective_mass(k1) + tree%effective_mass(k2) tree%effective_width(k) = & tree%effective_width(k1) + tree%effective_width(k2) end if else tree%effective_mass(k) = tree%mass_sum(k) end if end subroutine set_masses_x end subroutine phs_tree_set_effective_masses @ %def phs_tree_set_effective_masses @ Define step mappings, recursively, for the decay products of all intermediate resonances. Step mappings account for the fact that a branch may originate from a resonance, which almost replaces the upper limit on the possible invariant mass. The step mapping implements a smooth cutoff that interpolates between the resonance and the real kinematic limit. The mapping width determines the sharpness of the cutoff. Step mappings are inserted only for branches that are not mapped otherwise. At each branch, we record the mass that is effectively available for phase space, by taking the previous limit and subtracting the effective mass of the sibling branch. Widths are added, not subtracted. If we encounter a resonance decay, we discard the previous limit and replace it by the mass and width of the resonance, also subtracting the sibling branch. Initially, the limit is zero, so it becomes negative at any branch. Only if there is a resonance, the limit becomes positive. Whenever the limit is positive, and the current branch decays, we activate a step mapping for the current branch. As a result, step mappings are implemented for all internal lines that originate from an intermediate resonance decay. The flag [[variable_limits]] applies to the ultimate limit from the available energy, not to the intermediate resonances whose masses are always fixed. This routine requires [[phs_tree_set_effective_masses]] <>= public :: phs_tree_set_step_mappings <>= subroutine phs_tree_set_step_mappings (tree, exp_type, variable_limits) type(phs_tree_t), intent(inout) :: tree logical, intent(in) :: exp_type logical, intent(in) :: variable_limits type(string_t) :: map_str integer(TC) :: k if (exp_type) then map_str = "step_exp" else map_str = "step_hyp" end if k = tree%mask_out call set_step_mappings_x (k, 0._default, 0._default) contains recursive subroutine set_step_mappings_x (k, m_limit, w_limit) integer(TC), intent(in) :: k real(default), intent(in) :: m_limit, w_limit integer(TC), dimension(2) :: kk real(default), dimension(2) :: m, w if (tree%branch(k)%has_children) then if (m_limit > 0) then if (.not. mapping_is_set (tree%mapping(k))) then call mapping_init (tree%mapping(k), k, map_str) call mapping_set_step_mapping_parameters (tree%mapping(k), & m_limit, w_limit, & variable_limits) end if end if kk = tree%branch(k)%daughter m = tree%effective_mass(kk) w = tree%effective_width(kk) if (mapping_is_s_channel (tree%mapping(k))) then call set_step_mappings_x (kk(1), & mapping_get_mass (tree%mapping(k)) - m(2), & mapping_get_width (tree%mapping(k)) + w(2)) call set_step_mappings_x (kk(2), & mapping_get_mass (tree%mapping(k)) - m(1), & mapping_get_width (tree%mapping(k)) + w(1)) else if (m_limit > 0) then call set_step_mappings_x (kk(1), & m_limit - m(2), & w_limit + w(2)) call set_step_mappings_x (kk(2), & m_limit - m(1), & w_limit + w(1)) else call set_step_mappings_x (kk(1), & - m(2), & + w(2)) call set_step_mappings_x (kk(2), & - m(1), & + w(1)) end if end if end subroutine set_step_mappings_x end subroutine phs_tree_set_step_mappings @ %def phs_tree_set_step_mappings @ \subsubsection{Resonance structure} We identify the resonances within a tree as the set of s-channel mappings. The [[resonance_history_t]] type serves as the result container. <>= procedure :: extract_resonance_history => phs_tree_extract_resonance_history <>= subroutine phs_tree_extract_resonance_history (tree, res_history) class(phs_tree_t), intent(in) :: tree type(resonance_history_t), intent(out) :: res_history type(resonance_info_t) :: res_info integer :: i if (allocated (tree%mapping)) then do i = 1, size (tree%mapping) associate (mapping => tree%mapping(i)) if (mapping%is_s_channel ()) then call res_info%init (mapping%get_bincode (), mapping%get_flv (), & n_out = tree%n_externals - tree%n_in) call res_history%add_resonance (res_info) end if end associate end do end if end subroutine phs_tree_extract_resonance_history @ %def phs_tree_extract_resonance_history @ \subsubsection{Structural comparison} This function allows to check whether one tree is the permutation of another one. The permutation is applied to the second tree in the argument list. We do not make up a temporary permuted tree, but compare the two trees directly. The branches are scanned recursively, where for each daughter we check the friend and the mapping as well. Once a discrepancy is found, the recursion is exited immediately. <>= public :: phs_tree_equivalent <>= function phs_tree_equivalent (t1, t2, perm) result (is_equal) type(phs_tree_t), intent(in) :: t1, t2 type(permutation_t), intent(in) :: perm logical :: equal, is_equal integer(TC) :: k1, k2, mask_in k1 = t1%mask_out k2 = t2%mask_out mask_in = t1%mask_in equal = .true. call check (t1%branch(k1), t2%branch(k2), k1, k2) is_equal = equal contains recursive subroutine check (b1, b2, k1, k2) type(phs_branch_t), intent(in) :: b1, b2 integer(TC), intent(in) :: k1, k2 integer(TC), dimension(2) :: d1, d2, pd2 integer :: i if (.not.b1%has_friend .and. .not.b2%has_friend) then equal = .true. else if (b1%has_friend .and. b2%has_friend) then equal = (b1%friend == tc_permute (b2%friend, perm, mask_in)) end if if (equal) then if (b1%has_children .and. b2%has_children) then d1 = b1%daughter d2 = b2%daughter do i=1, 2 pd2(i) = tc_permute (d2(i), perm, mask_in) end do if (d1(1)==pd2(1) .and. d1(2)==pd2(2)) then equal = (b1%firstborn == b2%firstborn) if (equal) call check & & (t1%branch(d1(1)), t2%branch(d2(1)), d1(1), d2(1)) if (equal) call check & & (t1%branch(d1(2)), t2%branch(d2(2)), d1(2), d2(2)) else if (d1(1)==pd2(2) .and. d1(2)==pd2(1)) then equal = ( (b1%firstborn == 0 .and. b2%firstborn == 0) & & .or. (b1%firstborn == 3 - b2%firstborn) ) if (equal) call check & & (t1%branch(d1(1)), t2%branch(d2(2)), d1(1), d2(2)) if (equal) call check & & (t1%branch(d1(2)), t2%branch(d2(1)), d1(2), d2(1)) else equal = .false. end if end if end if if (equal) then equal = (t1%mapping(k1) == t2%mapping(k2)) end if end subroutine check end function phs_tree_equivalent @ %def phs_tree_equivalent @ Scan two decay trees and determine the correspondence of mass variables, i.e., the permutation that transfers the ordered list of mass variables belonging to the second tree into the first one. Mass variables are assigned beginning from branches and ending at the root. <>= public :: phs_tree_find_msq_permutation <>= subroutine phs_tree_find_msq_permutation (tree1, tree2, perm2, msq_perm) type(phs_tree_t), intent(in) :: tree1, tree2 type(permutation_t), intent(in) :: perm2 type(permutation_t), intent(out) :: msq_perm type(permutation_t) :: perm1 integer(TC) :: mask_in, root integer(TC), dimension(:), allocatable :: index1, index2 integer :: i allocate (index1 (tree1%n_msq), index2 (tree2%n_msq)) call permutation_init (perm1, permutation_size (perm2)) mask_in = tree1%mask_in root = tree1%mask_out i = 0 call tree_scan (tree1, root, perm1, index1) i = 0 call tree_scan (tree2, root, perm2, index2) call permutation_find (msq_perm, index1, index2) contains recursive subroutine tree_scan (tree, k, perm, index) type(phs_tree_t), intent(in) :: tree integer(TC), intent(in) :: k type(permutation_t), intent(in) :: perm integer, dimension(:), intent(inout) :: index if (tree%branch(k)%has_children) then call tree_scan (tree, tree%branch(k)%daughter(1), perm, index) call tree_scan (tree, tree%branch(k)%daughter(2), perm, index) i = i + 1 if (i <= size (index)) index(i) = tc_permute (k, perm, mask_in) end if end subroutine tree_scan end subroutine phs_tree_find_msq_permutation @ %def phs_tree_find_msq_permutation <>= public :: phs_tree_find_angle_permutation <>= subroutine phs_tree_find_angle_permutation & (tree1, tree2, perm2, angle_perm, sig2) type(phs_tree_t), intent(in) :: tree1, tree2 type(permutation_t), intent(in) :: perm2 type(permutation_t), intent(out) :: angle_perm logical, dimension(:), allocatable, intent(out) :: sig2 type(permutation_t) :: perm1 integer(TC) :: mask_in, root integer(TC), dimension(:), allocatable :: index1, index2 logical, dimension(:), allocatable :: sig1 integer :: i allocate (index1 (tree1%n_angles), index2 (tree2%n_angles)) allocate (sig1 (tree1%n_angles), sig2 (tree2%n_angles)) call permutation_init (perm1, permutation_size (perm2)) mask_in = tree1%mask_in root = tree1%mask_out i = 0 call tree_scan (tree1, root, perm1, index1, sig1) i = 0 call tree_scan (tree2, root, perm2, index2, sig2) call permutation_find (angle_perm, index1, index2) contains recursive subroutine tree_scan (tree, k, perm, index, sig) type(phs_tree_t), intent(in) :: tree integer(TC), intent(in) :: k type(permutation_t), intent(in) :: perm integer, dimension(:), intent(inout) :: index logical, dimension(:), intent(inout) :: sig integer(TC) :: k1, k2, kp logical :: s if (tree%branch(k)%has_children) then k1 = tree%branch(k)%daughter(1) k2 = tree%branch(k)%daughter(2) s = (tc_permute(k1, perm, mask_in) < tc_permute(k2, perm, mask_in)) kp = tc_permute (k, perm, mask_in) i = i + 1 index(i) = kp sig(i) = s i = i + 1 index(i) = - kp sig(i) = s call tree_scan (tree, k1, perm, index, sig) call tree_scan (tree, k2, perm, index, sig) end if end subroutine tree_scan end subroutine phs_tree_find_angle_permutation @ %def phs_tree_find_angle_permutation @ \subsection{Phase-space evaluation} \subsubsection{Phase-space volume} We compute the phase-space volume recursively, following the same path as for computing other kinematical variables. However, the volume depends just on $\sqrt{\hat s}$, not on the momentum configuration. Note: counting branches, we may replace this by a simple formula. <>= public :: phs_tree_compute_volume <>= subroutine phs_tree_compute_volume (tree, sqrts, volume) type(phs_tree_t), intent(in) :: tree real(default), intent(in) :: sqrts real(default), intent(out) :: volume integer(TC) :: k k = tree%mask_out if (tree%branch(k)%has_children) then call compute_volume_x (tree%branch(k), k, volume, .true.) else volume = 1 end if contains recursive subroutine compute_volume_x (b, k, volume, initial) type(phs_branch_t), intent(in) :: b integer(TC), intent(in) :: k real(default), intent(out) :: volume logical, intent(in) :: initial integer(TC) :: k1, k2 real(default) :: v1, v2 k1 = b%daughter(1); k2 = b%daughter(2) if (tree%branch(k1)%has_children) then call compute_volume_x (tree%branch(k1), k1, v1, .false.) else v1 = 1 end if if (tree%branch(k2)%has_children) then call compute_volume_x (tree%branch(k2), k2, v2, .false.) else v2 = 1 end if if (initial) then volume = v1 * v2 / (4 * twopi5) else volume = v1 * v2 * sqrts**2 / (4 * twopi2) end if end subroutine compute_volume_x end subroutine phs_tree_compute_volume @ %def phs_tree_compute_volume @ \subsubsection{Determine momenta} This is done in two steps: First the masses are determined. This step may fail, in which case [[ok]] is set to false. If successful, we generate angles and the actual momenta. The array [[decay_p]] serves for transferring the individual three-momenta of the daughter particles in their mother rest frame from the mass generation to the momentum generation step. <>= public :: phs_tree_compute_momenta_from_x <>= subroutine phs_tree_compute_momenta_from_x & (tree, prt, factor, volume, sqrts, x, ok) type(phs_tree_t), intent(inout) :: tree type(phs_prt_t), dimension(:), intent(inout) :: prt real(default), intent(out) :: factor, volume real(default), intent(in) :: sqrts real(default), dimension(:), intent(in) :: x logical, intent(out) :: ok real(default), dimension(tree%mask_out) :: decay_p integer :: n1, n2 integer :: n_out if (tree%real_phsp) then n_out = tree%n_externals - tree%n_in - 1 n1 = max (n_out-2, 0) n2 = n1 + max (2*n_out, 0) else n1 = tree%n_msq n2 = n1 + tree%n_angles end if call phs_tree_set_msq & (tree, prt, factor, volume, decay_p, sqrts, x(1:n1), ok) if (ok) call phs_tree_set_angles & (tree, prt, factor, decay_p, sqrts, x(n1+1:n2)) end subroutine phs_tree_compute_momenta_from_x @ %def phs_tree_compute_momenta_from_x @ Mass generation is done recursively. The [[ok]] flag causes the filled tree to be discarded if set to [[.false.]]. This happens if a three-momentum turns out to be imaginary, indicating impossible kinematics. The index [[ix]] tells us how far we have used up the input array [[x]]. <>= subroutine phs_tree_set_msq & (tree, prt, factor, volume, decay_p, sqrts, x, ok) type(phs_tree_t), intent(inout) :: tree type(phs_prt_t), dimension(:), intent(inout) :: prt real(default), intent(out) :: factor, volume real(default), dimension(:), intent(out) :: decay_p real(default), intent(in) :: sqrts real(default), dimension(:), intent(in) :: x logical, intent(out) :: ok integer :: ix integer(TC) :: k real(default) :: m_tot ok =.true. ix = 1 k = tree%mask_out m_tot = tree%mass_sum(k) decay_p(k) = 0. if (m_tot < sqrts .or. k == 1) then if (tree%branch(k)%has_children) then call set_msq_x (tree%branch(k), k, factor, volume, .true.) else factor = 1 volume = 1 end if else ok = .false. end if contains recursive subroutine set_msq_x (b, k, factor, volume, initial) type(phs_branch_t), intent(in) :: b integer(TC), intent(in) :: k real(default), intent(out) :: factor, volume logical, intent(in) :: initial real(default) :: msq, m, m_min, m_max, m1, m2, msq1, msq2, lda, rlda integer(TC) :: k1, k2 real(default) :: f1, f2, v1, v2 k1 = b%daughter(1); k2 = b%daughter(2) if (tree%branch(k1)%has_children) then call set_msq_x (tree%branch(k1), k1, f1, v1, .false.) if (.not.ok) return else f1 = 1; v1 = 1 end if if (tree%branch(k2)%has_children) then call set_msq_x (tree%branch(k2), k2, f2, v2, .false.) if (.not.ok) return else f2 = 1; v2 = 1 end if m_min = tree%mass_sum(k) if (initial) then msq = sqrts**2 m = sqrts m_max = sqrts factor = f1 * f2 volume = v1 * v2 / (4 * twopi5) else m_max = sqrts - m_tot + m_min call mapping_compute_msq_from_x & (tree%mapping(k), sqrts**2, m_min**2, m_max**2, msq, factor, & x(ix)); ix = ix + 1 if (msq >= 0) then m = sqrt (msq) factor = f1 * f2 * factor volume = v1 * v2 * sqrts**2 / (4 * twopi2) call phs_prt_set_msq (prt(k), msq) call phs_prt_set_defined (prt(k)) else ok = .false. end if end if if (ok) then msq1 = phs_prt_get_msq (prt(k1)); m1 = sqrt (msq1) msq2 = phs_prt_get_msq (prt(k2)); m2 = sqrt (msq2) lda = lambda (msq, msq1, msq2) if (lda > 0 .and. m > m1 + m2 .and. m <= m_max) then rlda = sqrt (lda) decay_p(k1) = rlda / (2*m) decay_p(k2) = - decay_p(k1) factor = rlda / msq * factor else ok = .false. end if end if end subroutine set_msq_x end subroutine phs_tree_set_msq @ %def phs_tree_set_msq @ The heart of phase space generation: Now we have the invariant masses, let us generate angles. At each branch, we take a Lorentz transformation and augment it by a boost to the current particle rest frame, and by rotations $\phi$ and $\theta$ around the $z$ and $y$ axis, respectively. This transformation is passed down to the daughter particles, if present. <>= subroutine phs_tree_set_angles (tree, prt, factor, decay_p, sqrts, x) type(phs_tree_t), intent(inout) :: tree type(phs_prt_t), dimension(:), intent(inout) :: prt real(default), intent(inout) :: factor real(default), dimension(:), intent(in) :: decay_p real(default), intent(in) :: sqrts real(default), dimension(:), intent(in) :: x integer :: ix integer(TC) :: k ix = 1 k = tree%mask_out call set_angles_x (tree%branch(k), k) contains recursive subroutine set_angles_x (b, k, L0) type(phs_branch_t), intent(in) :: b integer(TC), intent(in) :: k type(lorentz_transformation_t), intent(in), optional :: L0 real(default) :: m, msq, ct, st, phi, f, E, p, bg type(lorentz_transformation_t) :: L, LL integer(TC) :: k1, k2 type(vector3_t) :: axis p = decay_p(k) msq = phs_prt_get_msq (prt(k)); m = sqrt (msq) E = sqrt (msq + p**2) if (present (L0)) then call phs_prt_set_momentum (prt(k), L0 * vector4_moving (E,p,3)) else call phs_prt_set_momentum (prt(k), vector4_moving (E,p,3)) end if call phs_prt_set_defined (prt(k)) if (b%has_children) then k1 = b%daughter(1) k2 = b%daughter(2) if (m > 0) then bg = p / m else bg = 0 end if phi = x(ix) * twopi; ix = ix + 1 call mapping_compute_ct_from_x & (tree%mapping(k), sqrts**2, ct, st, f, x(ix)); ix = ix + 1 factor = factor * f if (.not. b%has_friend) then L = LT_compose_r2_r3_b3 (ct, st, cos(phi), sin(phi), bg) !!! The function above is equivalent to: ! L = boost (bg,3) * rotation (phi,3) * rotation (ct,st,2) else LL = boost (-bg,3); if (present (L0)) LL = LL * inverse(L0) axis = space_part ( & LL * phs_prt_get_momentum (prt(tree%branch(k)%friend)) ) L = boost(bg,3) * rotation_to_2nd (vector3_canonical(3), axis) & * LT_compose_r2_r3_b3 (ct, st, cos(phi), sin(phi), 0._default) end if if (present (L0)) L = L0 * L call set_angles_x (tree%branch(k1), k1, L) call set_angles_x (tree%branch(k2), k2, L) end if end subroutine set_angles_x end subroutine phs_tree_set_angles @ %def phs_tree_set_angles @ \subsubsection{Recover random numbers} For the other channels we want to compute the random numbers that would have generated the momenta that we already know. <>= public :: phs_tree_compute_x_from_momenta <>= subroutine phs_tree_compute_x_from_momenta (tree, prt, factor, sqrts, x) type(phs_tree_t), intent(inout) :: tree type(phs_prt_t), dimension(:), intent(in) :: prt real(default), intent(out) :: factor real(default), intent(in) :: sqrts real(default), dimension(:), intent(inout) :: x real(default), dimension(tree%mask_out) :: decay_p integer :: n1, n2 n1 = tree%n_msq n2 = n1 + tree%n_angles call phs_tree_get_msq & (tree, prt, factor, decay_p, sqrts, x(1:n1)) call phs_tree_get_angles & (tree, prt, factor, decay_p, sqrts, x(n1+1:n2)) end subroutine phs_tree_compute_x_from_momenta @ %def phs_tree_compute_x_from_momenta @ The inverse operation follows exactly the same steps. The tree is [[inout]] because it contains mappings whose parameters can be reset when the mapping is applied. <>= subroutine phs_tree_get_msq (tree, prt, factor, decay_p, sqrts, x) type(phs_tree_t), intent(inout) :: tree type(phs_prt_t), dimension(:), intent(in) :: prt real(default), intent(out) :: factor real(default), dimension(:), intent(out) :: decay_p real(default), intent(in) :: sqrts real(default), dimension(:), intent(inout) :: x integer :: ix integer(TC) :: k real(default) :: m_tot ix = 1 k = tree%mask_out m_tot = tree%mass_sum(k) decay_p(k) = 0. if (tree%branch(k)%has_children) then call get_msq_x (tree%branch(k), k, factor, .true.) else factor = 1 end if contains recursive subroutine get_msq_x (b, k, factor, initial) type(phs_branch_t), intent(in) :: b integer(TC), intent(in) :: k real(default), intent(out) :: factor logical, intent(in) :: initial real(default) :: msq, m, m_min, m_max, msq1, msq2, lda, rlda integer(TC) :: k1, k2 real(default) :: f1, f2 k1 = b%daughter(1); k2 = b%daughter(2) if (tree%branch(k1)%has_children) then call get_msq_x (tree%branch(k1), k1, f1, .false.) else f1 = 1 end if if (tree%branch(k2)%has_children) then call get_msq_x (tree%branch(k2), k2, f2, .false.) else f2 = 1 end if m_min = tree%mass_sum(k) m_max = sqrts - m_tot + m_min msq = phs_prt_get_msq (prt(k)); m = sqrt (msq) if (initial) then factor = f1 * f2 else call mapping_compute_x_from_msq & (tree%mapping(k), sqrts**2, m_min**2, m_max**2, msq, factor, & x(ix)); ix = ix + 1 factor = f1 * f2 * factor end if msq1 = phs_prt_get_msq (prt(k1)) msq2 = phs_prt_get_msq (prt(k2)) lda = lambda (msq, msq1, msq2) if (lda > 0) then rlda = sqrt (lda) decay_p(k1) = rlda / (2 * m) decay_p(k2) = - decay_p(k1) factor = rlda / msq * factor else decay_p(k1) = 0 decay_p(k2) = 0 factor = 0 end if end subroutine get_msq_x end subroutine phs_tree_get_msq @ %def phs_tree_get_msq @ This subroutine is the most time-critical part of the whole program. Therefore, we do not exactly parallel the angle generation routine above but make sure that things get evaluated only if they are really needed, at the expense of readability. Particularly important is to have as few multiplications of Lorentz transformations as possible. <>= subroutine phs_tree_get_angles (tree, prt, factor, decay_p, sqrts, x) type(phs_tree_t), intent(inout) :: tree type(phs_prt_t), dimension(:), intent(in) :: prt real(default), intent(inout) :: factor real(default), dimension(:), intent(in) :: decay_p real(default), intent(in) :: sqrts real(default), dimension(:), intent(out) :: x integer :: ix integer(TC) :: k ix = 1 k = tree%mask_out if (tree%branch(k)%has_children) then call get_angles_x (tree%branch(k), k) end if contains recursive subroutine get_angles_x (b, k, ct0, st0, phi0, L0) type(phs_branch_t), intent(in) :: b integer(TC), intent(in) :: k real(default), intent(in), optional :: ct0, st0, phi0 type(lorentz_transformation_t), intent(in), optional :: L0 real(default) :: cp0, sp0, m, msq, ct, st, phi, bg, f type(lorentz_transformation_t) :: L, LL type(vector4_t) :: p1, pf type(vector3_t) :: n, axis integer(TC) :: k1, k2, kf logical :: has_friend, need_L k1 = b%daughter(1) k2 = b%daughter(2) kf = b%friend has_friend = b%has_friend if (present(L0)) then p1 = L0 * phs_prt_get_momentum (prt(k1)) if (has_friend) pf = L0 * phs_prt_get_momentum (prt(kf)) else p1 = phs_prt_get_momentum (prt(k1)) if (has_friend) pf = phs_prt_get_momentum (prt(kf)) end if if (present(phi0)) then cp0 = cos (phi0) sp0 = sin (phi0) end if msq = phs_prt_get_msq (prt(k)); m = sqrt (msq) if (m > 0) then bg = decay_p(k) / m else bg = 0 end if if (has_friend) then if (present (phi0)) then axis = axis_from_p_r3_r2_b3 (pf, cp0, -sp0, ct0, -st0, -bg) LL = rotation_to_2nd (axis, vector3_canonical (3)) & * LT_compose_r3_r2_b3 (cp0, -sp0, ct0, -st0, -bg) else axis = axis_from_p_b3 (pf, -bg) LL = rotation_to_2nd (axis, vector3_canonical(3)) if (.not. vanishes (bg)) LL = LL * boost(-bg, 3) end if n = space_part (LL * p1) else if (present (phi0)) then n = axis_from_p_r3_r2_b3 (p1, cp0, -sp0, ct0, -st0, -bg) else n = axis_from_p_b3 (p1, -bg) end if phi = azimuthal_angle (n) x(ix) = phi / twopi; ix = ix + 1 ct = polar_angle_ct (n) st = sqrt (1 - ct**2) call mapping_compute_x_from_ct (tree%mapping(k), sqrts**2, ct, f, & x(ix)); ix = ix + 1 factor = factor * f if (tree%branch(k1)%has_children .or. tree%branch(k2)%has_children) then need_L = .true. if (has_friend) then if (present (L0)) then L = LL * L0 else L = LL end if else if (present (L0)) then L = LT_compose_r3_r2_b3 (cp0, -sp0, ct0, -st0, -bg) * L0 else if (present (phi0)) then L = LT_compose_r3_r2_b3 (cp0, -sp0, ct0, -st0, -bg) else if (bg /= 0) then L = boost(-bg, 3) else need_L = .false. end if if (need_L) then if (tree%branch(k1)%has_children) & call get_angles_x (tree%branch(k1), k1, ct, st, phi, L) if (tree%branch(k2)%has_children) & call get_angles_x (tree%branch(k2), k2, ct, st, phi, L) else if (tree%branch(k1)%has_children) & call get_angles_x (tree%branch(k1), k1, ct, st, phi) if (tree%branch(k2)%has_children) & call get_angles_x (tree%branch(k2), k2, ct, st, phi) end if end if end subroutine get_angles_x end subroutine phs_tree_get_angles @ %def phs_tree_get_angles @ \subsubsection{Auxiliary stuff} This calculates all momenta that are not yet known by summing up daughter particle momenta. The external particles must be known. Only composite particles not yet known are calculated. <>= public :: phs_tree_combine_particles <>= subroutine phs_tree_combine_particles (tree, prt) type(phs_tree_t), intent(in) :: tree type(phs_prt_t), dimension(:), intent(inout) :: prt call combine_particles_x (tree%mask_out) contains recursive subroutine combine_particles_x (k) integer(TC), intent(in) :: k integer :: k1, k2 if (tree%branch(k)%has_children) then k1 = tree%branch(k)%daughter(1); k2 = tree%branch(k)%daughter(2) call combine_particles_x (k1) call combine_particles_x (k2) if (.not. prt(k)%defined) then call phs_prt_combine (prt(k), prt(k1), prt(k2)) end if end if end subroutine combine_particles_x end subroutine phs_tree_combine_particles @ %def phs_tree_combine_particles @ The previous routine is to be evaluated at runtime. Instead of scanning trees, we can as well set up a multiplication table. This is generated here. Note that the table is [[intent(out)]]. <>= public :: phs_tree_setup_prt_combinations <>= subroutine phs_tree_setup_prt_combinations (tree, comb) type(phs_tree_t), intent(in) :: tree integer, dimension(:,:), intent(out) :: comb comb = 0 call setup_prt_combinations_x (tree%mask_out) contains recursive subroutine setup_prt_combinations_x (k) integer(TC), intent(in) :: k integer, dimension(2) :: kk if (tree%branch(k)%has_children) then kk = tree%branch(k)%daughter call setup_prt_combinations_x (kk(1)) call setup_prt_combinations_x (kk(2)) comb(:,k) = kk end if end subroutine setup_prt_combinations_x end subroutine phs_tree_setup_prt_combinations @ %def phs_tree_setup_prt_combinations @ <>= public :: phs_tree_reshuffle_mappings <>= subroutine phs_tree_reshuffle_mappings (tree) type(phs_tree_t), intent(inout) :: tree integer(TC) :: k0, k_old, k_new, k2 integer :: i type(mapping_t) :: mapping_tmp real(default) :: mass_tmp do i = 1, size (tree%momentum_link) if (i /= tree%momentum_link (i)) then k_old = 2**(i-tree%n_in-1) k_new = 2**(tree%momentum_link(i)-tree%n_in-1) k0 = tree%branch(k_old)%mother k2 = k_new + tree%branch(k_old)%sibling mapping_tmp = tree%mapping(k0) mass_tmp = tree%mass_sum(k0) tree%mapping(k0) = tree%mapping(k2) tree%mapping(k2) = mapping_tmp tree%mass_sum(k0) = tree%mass_sum(k2) tree%mass_sum(k2) = mass_tmp end if end do end subroutine phs_tree_reshuffle_mappings @ %def phs_tree_reshuffle_mappings @ <>= public :: phs_tree_set_momentum_links <>= subroutine phs_tree_set_momentum_links (tree, list) type(phs_tree_t), intent(inout) :: tree integer, dimension(:), allocatable :: list tree%momentum_link = list end subroutine phs_tree_set_momentum_links @ %def phs_tree_set_momentum_links @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[phs_trees_ut.f90]]>>= <> module phs_trees_ut use unit_tests use phs_trees_uti <> <> contains <> end module phs_trees_ut @ %def phs_trees_ut @ <<[[phs_trees_uti.f90]]>>= <> module phs_trees_uti !!!<> use kinds, only: TC <> use flavors, only: flavor_t use model_data, only: model_data_t use resonances, only: resonance_history_t use mappings, only: mapping_defaults_t use phs_trees <> <> contains <> end module phs_trees_uti @ %def phs_trees_ut @ API: driver for the unit tests below. <>= public :: phs_trees_test <>= subroutine phs_trees_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine phs_trees_test @ %def phs_trees_test @ Create a simple $2\to 3$ PHS tree and display it. <>= call test (phs_tree_1, "phs_tree_1", & "check phs tree setup", & u, results) <>= public :: phs_tree_1 <>= subroutine phs_tree_1 (u) integer, intent(in) :: u type(phs_tree_t) :: tree type(model_data_t), target :: model type(flavor_t), dimension(5) :: flv integer :: i write (u, "(A)") "* Test output: phs_tree_1" write (u, "(A)") "* Purpose: test PHS tree routines" write (u, "(A)") write (u, "(A)") "* Read model file" call model%init_sm_test () write (u, "(A)") write (u, "(A)") "* Set up flavors" write (u, "(A)") call flv%init ([1, -2, 24, 5, -5], model) do i = 1, 5 write (u, "(1x)", advance="no") call flv(i)%write (u) end do write (u, *) write (u, "(A)") write (u, "(A)") "* Create tree" write (u, "(A)") call tree%init (2, 3, 0, 0) call tree%from_array ([integer(TC) :: 1, 2, 3, 4, 7, 8, 16]) call tree%set_mass_sum (flv) call tree%set_effective_masses () call tree%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call tree%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_tree_1" end subroutine phs_tree_1 @ %def phs_tree_1 @ The analogous tree with resonance (s-channel) mappings. <>= call test (phs_tree_2, "phs_tree_2", & "check phs tree with resonances", & u, results) <>= public :: phs_tree_2 <>= subroutine phs_tree_2 (u) integer, intent(in) :: u type(phs_tree_t) :: tree type(model_data_t), target :: model type(mapping_defaults_t) :: mapping_defaults type(flavor_t), dimension(5) :: flv type(resonance_history_t) :: res_history integer :: i write (u, "(A)") "* Test output: phs_tree_2" write (u, "(A)") "* Purpose: test PHS tree with resonances" write (u, "(A)") write (u, "(A)") "* Read model file" call model%init_sm_test () write (u, "(A)") write (u, "(A)") "* Set up flavors" write (u, "(A)") call flv%init ([1, -2, 24, 5, -5], model) do i = 1, 5 write (u, "(1x)", advance="no") call flv(i)%write (u) end do write (u, *) write (u, "(A)") write (u, "(A)") "* Create tree with mappings" write (u, "(A)") call tree%init (2, 3, 0, 0) call tree%from_array ([integer(TC) :: 1, 2, 3, 4, 7, 8, 16]) call tree%set_mass_sum (flv) call tree%init_mapping (3_TC, var_str ("s_channel"), -24, model) call tree%init_mapping (7_TC, var_str ("s_channel"), 23, model) call tree%set_mapping_parameters (mapping_defaults, variable_limits=.false.) call tree%set_effective_masses () call tree%write (u) write (u, "(A)") write (u, "(A)") "* Extract resonances from mappings" write (u, "(A)") call tree%extract_resonance_history (res_history) call res_history%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call tree%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_tree_2" end subroutine phs_tree_2 @ %def phs_tree_2 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{The phase-space forest} Simply stated, a phase-space forest is a collection of phase-space trees. More precisely, a [[phs_forest]] object contains all parameterizations of phase space that \whizard\ will use for a single hard process, prepared in the form of [[phs_tree]] objects. This is suitable for evaluation by the \vamp\ integration package: each parameterization (tree) is a valid channel in the multi-channel adaptive integration, and each variable in a tree corresponds to an integration dimension, defined by an appropriate mapping of the $(0,1)$ interval to the allowed range of the integration variable. The trees are grouped in groves. The trees (integration channels) within a grove share a common weight, assuming that they are related by some approximate symmetry. Trees/channels that are related by an exact symmetry are connected by an array of equivalences; each equivalence object holds the data that relate one channel to another. The phase-space setup, i.e., the detailed structure of trees and forest, are read from a file. Therefore, this module also contains the syntax definition and the parser needed for interpreting this file. <<[[phs_forests.f90]]>>= <> module phs_forests <> use kinds, only: TC <> use io_units use format_defs, only: FMT_19 use diagnostics use lorentz use numeric_utils use permutations use ifiles use syntax_rules use lexers use parser use model_data use model_data use flavors use interactions use phs_base use resonances, only: resonance_history_t use resonances, only: resonance_history_set_t use mappings use phs_trees <> <> <> <> <> contains <> end module phs_forests @ %def phs_forests @ \subsection{Phase-space setup parameters} This transparent container holds the parameters that the algorithm needs for phase-space setup, with reasonable defaults. The threshold mass (for considering a particle as effectively massless) is specified separately for s- and t-channel. The default is to treat $W$ and $Z$ bosons as massive in the s-channel, but as massless in the t-channel. The $b$-quark is treated always massless, the $t$-quark always massive. <>= public :: phs_parameters_t <>= type :: phs_parameters_t real(default) :: sqrts = 0 real(default) :: m_threshold_s = 50._default real(default) :: m_threshold_t = 100._default integer :: off_shell = 1 integer :: t_channel = 2 logical :: keep_nonresonant = .true. contains <> end type phs_parameters_t @ %def phs_parameters_t @ Write phase-space parameters to file. <>= procedure :: write => phs_parameters_write <>= subroutine phs_parameters_write (phs_par, unit) class(phs_parameters_t), intent(in) :: phs_par integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(3x,A," // FMT_19 // ")") "sqrts = ", phs_par%sqrts write (u, "(3x,A," // FMT_19 // ")") "m_threshold_s = ", phs_par%m_threshold_s write (u, "(3x,A," // FMT_19 // ")") "m_threshold_t = ", phs_par%m_threshold_t write (u, "(3x,A,I0)") "off_shell = ", phs_par%off_shell write (u, "(3x,A,I0)") "t_channel = ", phs_par%t_channel write (u, "(3x,A,L1)") "keep_nonresonant = ", phs_par%keep_nonresonant end subroutine phs_parameters_write @ %def phs_parameters_write @ Read phase-space parameters from file. <>= public :: phs_parameters_read <>= subroutine phs_parameters_read (phs_par, unit) type(phs_parameters_t), intent(out) :: phs_par integer, intent(in) :: unit character(20) :: dummy character :: equals read (unit, *) dummy, equals, phs_par%sqrts read (unit, *) dummy, equals, phs_par%m_threshold_s read (unit, *) dummy, equals, phs_par%m_threshold_t read (unit, *) dummy, equals, phs_par%off_shell read (unit, *) dummy, equals, phs_par%t_channel read (unit, *) dummy, equals, phs_par%keep_nonresonant end subroutine phs_parameters_read @ %def phs_parameters_write @ Comparison. <>= interface operator(==) module procedure phs_parameters_eq end interface interface operator(/=) module procedure phs_parameters_ne end interface <>= function phs_parameters_eq (phs_par1, phs_par2) result (equal) logical :: equal type(phs_parameters_t), intent(in) :: phs_par1, phs_par2 equal = phs_par1%sqrts == phs_par2%sqrts & .and. phs_par1%m_threshold_s == phs_par2%m_threshold_s & .and. phs_par1%m_threshold_t == phs_par2%m_threshold_t & .and. phs_par1%off_shell == phs_par2%off_shell & .and. phs_par1%t_channel == phs_par2%t_channel & .and.(phs_par1%keep_nonresonant .eqv. phs_par2%keep_nonresonant) end function phs_parameters_eq function phs_parameters_ne (phs_par1, phs_par2) result (ne) logical :: ne type(phs_parameters_t), intent(in) :: phs_par1, phs_par2 ne = phs_par1%sqrts /= phs_par2%sqrts & .or. phs_par1%m_threshold_s /= phs_par2%m_threshold_s & .or. phs_par1%m_threshold_t /= phs_par2%m_threshold_t & .or. phs_par1%off_shell /= phs_par2%off_shell & .or. phs_par1%t_channel /= phs_par2%t_channel & .or.(phs_par1%keep_nonresonant .neqv. phs_par2%keep_nonresonant) end function phs_parameters_ne @ %def phs_parameters_eq phs_parameters_ne @ \subsection{Equivalences} This type holds information about equivalences between phase-space trees. We make a linked list, where each node contains the two trees which are equivalent and the corresponding permutation of external particles. Two more arrays are to be filled: The permutation of mass variables and the permutation of angular variables, where the signature indicates a necessary exchange of daughter branches. <>= type :: equivalence_t private integer :: left, right type(permutation_t) :: perm type(permutation_t) :: msq_perm, angle_perm logical, dimension(:), allocatable :: angle_sig type(equivalence_t), pointer :: next => null () end type equivalence_t @ %def equivalence_t <>= type :: equivalence_list_t private integer :: length = 0 type(equivalence_t), pointer :: first => null () type(equivalence_t), pointer :: last => null () end type equivalence_list_t @ %def equivalence_list_t @ Append an equivalence to the list <>= subroutine equivalence_list_add (eql, left, right, perm) type(equivalence_list_t), intent(inout) :: eql integer, intent(in) :: left, right type(permutation_t), intent(in) :: perm type(equivalence_t), pointer :: eq allocate (eq) eq%left = left eq%right = right eq%perm = perm if (associated (eql%last)) then eql%last%next => eq else eql%first => eq end if eql%last => eq eql%length = eql%length + 1 end subroutine equivalence_list_add @ %def equivalence_list_add @ Delete the list contents. Has to be pure because it is called from an elemental subroutine. <>= pure subroutine equivalence_list_final (eql) type(equivalence_list_t), intent(inout) :: eql type(equivalence_t), pointer :: eq do while (associated (eql%first)) eq => eql%first eql%first => eql%first%next deallocate (eq) end do eql%last => null () eql%length = 0 end subroutine equivalence_list_final @ %def equivalence_list_final @ Make a deep copy of the equivalence list. This allows for deep copies of groves and forests. <>= interface assignment(=) module procedure equivalence_list_assign end interface <>= subroutine equivalence_list_assign (eql_out, eql_in) type(equivalence_list_t), intent(out) :: eql_out type(equivalence_list_t), intent(in) :: eql_in type(equivalence_t), pointer :: eq, eq_copy eq => eql_in%first do while (associated (eq)) allocate (eq_copy) eq_copy = eq eq_copy%next => null () if (associated (eql_out%first)) then eql_out%last%next => eq_copy else eql_out%first => eq_copy end if eql_out%last => eq_copy eq => eq%next end do end subroutine equivalence_list_assign @ %def equivalence_list_assign @ The number of list entries <>= elemental function equivalence_list_length (eql) result (length) integer :: length type(equivalence_list_t), intent(in) :: eql length = eql%length end function equivalence_list_length @ %def equivalence_list_length @ Recursively write the equivalences list <>= subroutine equivalence_list_write (eql, unit) type(equivalence_list_t), intent(in) :: eql integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return if (associated (eql%first)) then call equivalence_write_rec (eql%first, u) else write (u, *) " [empty]" end if contains recursive subroutine equivalence_write_rec (eq, u) type(equivalence_t), intent(in) :: eq integer, intent(in) :: u integer :: i write (u, "(3x,A,1x,I0,1x,I0,2x,A)", advance="no") & "Equivalence:", eq%left, eq%right, "Final state permutation:" call permutation_write (eq%perm, u) write (u, "(1x,12x,1x,A,1x)", advance="no") & " msq permutation: " call permutation_write (eq%msq_perm, u) write (u, "(1x,12x,1x,A,1x)", advance="no") & " angle permutation:" call permutation_write (eq%angle_perm, u) write (u, "(1x,12x,1x,26x)", advance="no") do i = 1, size (eq%angle_sig) if (eq%angle_sig(i)) then write (u, "(1x,A)", advance="no") "+" else write (u, "(1x,A)", advance="no") "-" end if end do write (u, *) if (associated (eq%next)) call equivalence_write_rec (eq%next, u) end subroutine equivalence_write_rec end subroutine equivalence_list_write @ %def equivalence_list_write @ \subsection{Groves} A grove is a group of trees (phase-space channels) that share a common weight in the integration. Within a grove, channels can be declared equivalent, so they also share their integration grids (up to symmetries). The grove contains a list of equivalences. The [[tree_count_offset]] is the total number of trees of the preceding groves; when the trees are counted per forest (integration channels), the offset has to be added to all tree indices. <>= type :: phs_grove_t private integer :: tree_count_offset type(phs_tree_t), dimension(:), allocatable :: tree type(equivalence_list_t) :: equivalence_list end type phs_grove_t @ %def phs_grove_t @ Call [[phs_tree_init]] which is also elemental: <>= elemental subroutine phs_grove_init & (grove, n_trees, n_in, n_out, n_masses, n_angles) type(phs_grove_t), intent(inout) :: grove integer, intent(in) :: n_trees, n_in, n_out, n_masses, n_angles grove%tree_count_offset = 0 allocate (grove%tree (n_trees)) call phs_tree_init (grove%tree, n_in, n_out, n_masses, n_angles) end subroutine phs_grove_init @ %def phs_grove_init @ The trees do not have pointer components, thus no call to [[phs_tree_final]]: <>= elemental subroutine phs_grove_final (grove) type(phs_grove_t), intent(inout) :: grove deallocate (grove%tree) call equivalence_list_final (grove%equivalence_list) end subroutine phs_grove_final @ %def phs_grove_final @ Deep copy. <>= interface assignment(=) module procedure phs_grove_assign0 module procedure phs_grove_assign1 end interface <>= subroutine phs_grove_assign0 (grove_out, grove_in) type(phs_grove_t), intent(out) :: grove_out type(phs_grove_t), intent(in) :: grove_in grove_out%tree_count_offset = grove_in%tree_count_offset if (allocated (grove_in%tree)) then allocate (grove_out%tree (size (grove_in%tree))) grove_out%tree = grove_in%tree end if grove_out%equivalence_list = grove_in%equivalence_list end subroutine phs_grove_assign0 subroutine phs_grove_assign1 (grove_out, grove_in) type(phs_grove_t), dimension(:), intent(out) :: grove_out type(phs_grove_t), dimension(:), intent(in) :: grove_in integer :: i do i = 1, size (grove_in) call phs_grove_assign0 (grove_out(i), grove_in(i)) end do end subroutine phs_grove_assign1 @ %def phs_grove_assign @ Get the global (s-channel) mappings. Implemented as a subroutine which returns an array (slice). <>= subroutine phs_grove_assign_s_mappings (grove, mapping) type(phs_grove_t), intent(in) :: grove type(mapping_t), dimension(:), intent(out) :: mapping integer :: i if (size (mapping) == size (grove%tree)) then do i = 1, size (mapping) call phs_tree_assign_s_mapping (grove%tree(i), mapping(i)) end do else call msg_bug ("phs_grove_assign_s_mappings: array size mismatch") end if end subroutine phs_grove_assign_s_mappings @ %def phs_grove_assign_s_mappings @ \subsection{The forest type} This is a collection of trees and associated particles. In a given tree, each branch code corresponds to a particle in the [[prt]] array. Furthermore, we have an array of mass sums which is independent of the decay tree and of the particular event. The mappings directly correspond to the decay trees, and the decay groves collect the trees in classes. The permutation list consists of all permutations of outgoing particles that map the decay forest onto itself. The particle codes [[flv]] (one for each external particle) are needed for determining masses and such. The trees and associated information are collected in the [[grove]] array, together with a lookup table that associates tree indices to groves. Finally, the [[prt]] array serves as workspace for phase-space evaluation. The [[prt_combination]] is a list of index pairs, namely the particle momenta pairs that need to be combined in order to provide all momentum combinations that the phase-space trees need to know. <>= public :: phs_forest_t <>= type :: phs_forest_t private integer :: n_in, n_out, n_tot integer :: n_masses, n_angles, n_dimensions integer :: n_trees, n_equivalences type(flavor_t), dimension(:), allocatable :: flv type(phs_grove_t), dimension(:), allocatable :: grove integer, dimension(:), allocatable :: grove_lookup type(phs_prt_t), dimension(:), allocatable :: prt_in type(phs_prt_t), dimension(:), allocatable :: prt_out type(phs_prt_t), dimension(:), allocatable :: prt integer(TC), dimension(:,:), allocatable :: prt_combination type(mapping_t), dimension(:), allocatable :: s_mapping contains <> end type phs_forest_t @ %def phs_forest_t @ The initialization merely allocates memory. We have to know how many trees there are in each grove, so we can initialize everything. The number of groves is the size of the [[n_tree]] array. In the [[grove_lookup]] table we store the grove index that belongs to each absolute tree index. The difference between the absolute index and the relative (to the grove) index is stored, for each grove, as [[tree_count_offset]]. The particle array is allocated according to the total number of branches each tree has, but not filled. <>= public :: phs_forest_init <>= subroutine phs_forest_init (forest, n_tree, n_in, n_out) type(phs_forest_t), intent(inout) :: forest integer, dimension(:), intent(in) :: n_tree integer, intent(in) :: n_in, n_out integer :: g, count, k_root forest%n_in = n_in forest%n_out = n_out forest%n_tot = n_in + n_out forest%n_masses = max (n_out - 2, 0) forest%n_angles = max (2*n_out - 2, 0) forest%n_dimensions = forest%n_masses + forest%n_angles forest%n_trees = sum (n_tree) forest%n_equivalences = 0 allocate (forest%grove (size (n_tree))) call phs_grove_init & (forest%grove, n_tree, n_in, n_out, forest%n_masses, & forest%n_angles) allocate (forest%grove_lookup (forest%n_trees)) count = 0 do g = 1, size (forest%grove) forest%grove(g)%tree_count_offset = count forest%grove_lookup (count+1:count+n_tree(g)) = g count = count + n_tree(g) end do allocate (forest%prt_in (n_in)) allocate (forest%prt_out (forest%n_out)) k_root = 2**forest%n_tot - 1 allocate (forest%prt (k_root)) allocate (forest%prt_combination (2, k_root)) allocate (forest%s_mapping (forest%n_trees)) end subroutine phs_forest_init @ %def phs_forest_init @ Assign the global (s-channel) mappings. <>= public :: phs_forest_set_s_mappings <>= subroutine phs_forest_set_s_mappings (forest) type(phs_forest_t), intent(inout) :: forest integer :: g, i0, i1, n do g = 1, size (forest%grove) call phs_forest_get_grove_bounds (forest, g, i0, i1, n) call phs_grove_assign_s_mappings & (forest%grove(g), forest%s_mapping(i0:i1)) end do end subroutine phs_forest_set_s_mappings @ %def phs_forest_set_s_mappings @ The grove finalizer is called because it contains the equivalence list: <>= public :: phs_forest_final <>= subroutine phs_forest_final (forest) type(phs_forest_t), intent(inout) :: forest if (allocated (forest%grove)) then call phs_grove_final (forest%grove) deallocate (forest%grove) end if if (allocated (forest%grove_lookup)) deallocate (forest%grove_lookup) if (allocated (forest%prt)) deallocate (forest%prt) if (allocated (forest%s_mapping)) deallocate (forest%s_mapping) end subroutine phs_forest_final @ %def phs_forest_final @ \subsection{Screen output} Write the particles that are non-null, then the trees which point to them: <>= public :: phs_forest_write <>= procedure :: write => phs_forest_write <>= subroutine phs_forest_write (forest, unit) class(phs_forest_t), intent(in) :: forest integer, intent(in), optional :: unit integer :: u integer :: i, g, k u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "Phase space forest:" write (u, "(3x,A,I0)") "n_in = ", forest%n_in write (u, "(3x,A,I0)") "n_out = ", forest%n_out write (u, "(3x,A,I0)") "n_tot = ", forest%n_tot write (u, "(3x,A,I0)") "n_masses = ", forest%n_masses write (u, "(3x,A,I0)") "n_angles = ", forest%n_angles write (u, "(3x,A,I0)") "n_dim = ", forest%n_dimensions write (u, "(3x,A,I0)") "n_trees = ", forest%n_trees write (u, "(3x,A,I0)") "n_equiv = ", forest%n_equivalences write (u, "(3x,A)", advance="no") "flavors =" if (allocated (forest%flv)) then do i = 1, size (forest%flv) write (u, "(1x,I0)", advance="no") forest%flv(i)%get_pdg () end do write (u, "(A)") else write (u, "(1x,A)") "[empty]" end if write (u, "(1x,A)") "Particle combinations:" if (allocated (forest%prt_combination)) then do k = 1, size (forest%prt_combination, 2) if (forest%prt_combination(1, k) /= 0) then write (u, "(3x,I0,1x,'<=',1x,I0,1x,'+',1x,I0)") & k, forest%prt_combination(:,k) end if end do else write (u, "(3x,A)") " [empty]" end if write (u, "(1x,A)") "Groves and trees:" if (allocated (forest%grove)) then do g = 1, size (forest%grove) write (u, "(3x,A,1x,I0)") "Grove ", g call phs_grove_write (forest%grove(g), unit) end do else write (u, "(3x,A)") " [empty]" end if write (u, "(1x,A,I0)") "Total number of equivalences: ", & forest%n_equivalences write (u, "(A)") write (u, "(1x,A)") "Global s-channel mappings:" if (allocated (forest%s_mapping)) then do i = 1, size (forest%s_mapping) associate (mapping => forest%s_mapping(i)) if (mapping_is_s_channel (mapping) & .or. mapping_is_on_shell (mapping)) then write (u, "(1x,I0,':',1x)", advance="no") i call mapping_write (forest%s_mapping(i), unit) end if end associate end do else write (u, "(3x,A)") " [empty]" end if write (u, "(A)") write (u, "(1x,A)") "Incoming particles:" if (allocated (forest%prt_in)) then if (any (phs_prt_is_defined (forest%prt_in))) then do i = 1, size (forest%prt_in) if (phs_prt_is_defined (forest%prt_in(i))) then write (u, "(1x,A,1x,I0)") "Particle", i call phs_prt_write (forest%prt_in(i), u) end if end do else write (u, "(3x,A)") "[all undefined]" end if else write (u, "(3x,A)") " [empty]" end if write (u, "(A)") write (u, "(1x,A)") "Outgoing particles:" if (allocated (forest%prt_out)) then if (any (phs_prt_is_defined (forest%prt_out))) then do i = 1, size (forest%prt_out) if (phs_prt_is_defined (forest%prt_out(i))) then write (u, "(1x,A,1x,I0)") "Particle", i call phs_prt_write (forest%prt_out(i), u) end if end do else write (u, "(3x,A)") "[all undefined]" end if else write (u, "(1x,A)") " [empty]" end if write (u, "(A)") write (u, "(1x,A)") "Tree particles:" if (allocated (forest%prt)) then if (any (phs_prt_is_defined (forest%prt))) then do i = 1, size (forest%prt) if (phs_prt_is_defined (forest%prt(i))) then write (u, "(1x,A,1x,I0)") "Particle", i call phs_prt_write (forest%prt(i), u) end if end do else write (u, "(3x,A)") "[all undefined]" end if else write (u, "(3x,A)") " [empty]" end if end subroutine phs_forest_write subroutine phs_grove_write (grove, unit) type(phs_grove_t), intent(in) :: grove integer, intent(in), optional :: unit integer :: u integer :: t u = given_output_unit (unit); if (u < 0) return do t = 1, size (grove%tree) write (u, "(3x,A,I0)") "Tree ", t call phs_tree_write (grove%tree(t), unit) end do write (u, "(1x,A)") "Equivalence list:" call equivalence_list_write (grove%equivalence_list, unit) end subroutine phs_grove_write @ %def phs_grove_write phs_forest_write @ Deep copy. <>= public :: assignment(=) <>= interface assignment(=) module procedure phs_forest_assign end interface <>= subroutine phs_forest_assign (forest_out, forest_in) type(phs_forest_t), intent(out) :: forest_out type(phs_forest_t), intent(in) :: forest_in forest_out%n_in = forest_in%n_in forest_out%n_out = forest_in%n_out forest_out%n_tot = forest_in%n_tot forest_out%n_masses = forest_in%n_masses forest_out%n_angles = forest_in%n_angles forest_out%n_dimensions = forest_in%n_dimensions forest_out%n_trees = forest_in%n_trees forest_out%n_equivalences = forest_in%n_equivalences if (allocated (forest_in%flv)) then allocate (forest_out%flv (size (forest_in%flv))) forest_out%flv = forest_in%flv end if if (allocated (forest_in%grove)) then allocate (forest_out%grove (size (forest_in%grove))) forest_out%grove = forest_in%grove end if if (allocated (forest_in%grove_lookup)) then allocate (forest_out%grove_lookup (size (forest_in%grove_lookup))) forest_out%grove_lookup = forest_in%grove_lookup end if if (allocated (forest_in%prt_in)) then allocate (forest_out%prt_in (size (forest_in%prt_in))) forest_out%prt_in = forest_in%prt_in end if if (allocated (forest_in%prt_out)) then allocate (forest_out%prt_out (size (forest_in%prt_out))) forest_out%prt_out = forest_in%prt_out end if if (allocated (forest_in%prt)) then allocate (forest_out%prt (size (forest_in%prt))) forest_out%prt = forest_in%prt end if if (allocated (forest_in%s_mapping)) then allocate (forest_out%s_mapping (size (forest_in%s_mapping))) forest_out%s_mapping = forest_in%s_mapping end if if (allocated (forest_in%prt_combination)) then allocate (forest_out%prt_combination & (2, size (forest_in%prt_combination, 2))) forest_out%prt_combination = forest_in%prt_combination end if end subroutine phs_forest_assign @ %def phs_forest_assign @ \subsection{Accessing contents} Get the number of integration parameters <>= public :: phs_forest_get_n_parameters <>= function phs_forest_get_n_parameters (forest) result (n) integer :: n type(phs_forest_t), intent(in) :: forest n = forest%n_dimensions end function phs_forest_get_n_parameters @ %def phs_forest_get_n_parameters @ Get the number of integration channels <>= public :: phs_forest_get_n_channels <>= function phs_forest_get_n_channels (forest) result (n) integer :: n type(phs_forest_t), intent(in) :: forest n = forest%n_trees end function phs_forest_get_n_channels @ %def phs_forest_get_n_channels @ Get the number of groves <>= public :: phs_forest_get_n_groves <>= function phs_forest_get_n_groves (forest) result (n) integer :: n type(phs_forest_t), intent(in) :: forest n = size (forest%grove) end function phs_forest_get_n_groves @ %def phs_forest_get_n_groves @ Get the index bounds for a specific grove. <>= public :: phs_forest_get_grove_bounds <>= subroutine phs_forest_get_grove_bounds (forest, g, i0, i1, n) type(phs_forest_t), intent(in) :: forest integer, intent(in) :: g integer, intent(out) :: i0, i1, n n = size (forest%grove(g)%tree) i0 = forest%grove(g)%tree_count_offset + 1 i1 = forest%grove(g)%tree_count_offset + n end subroutine phs_forest_get_grove_bounds @ %def phs_forest_get_grove_bounds @ Get the number of equivalences <>= public :: phs_forest_get_n_equivalences <>= function phs_forest_get_n_equivalences (forest) result (n) integer :: n type(phs_forest_t), intent(in) :: forest n = forest%n_equivalences end function phs_forest_get_n_equivalences @ %def phs_forest_get_n_equivalences @ Return true if a particular channel has a global (s-channel) mapping; also return the resonance mass and width for this mapping. <>= public :: phs_forest_get_s_mapping public :: phs_forest_get_on_shell <>= subroutine phs_forest_get_s_mapping (forest, channel, flag, mass, width) type(phs_forest_t), intent(in) :: forest integer, intent(in) :: channel logical, intent(out) :: flag real(default), intent(out) :: mass, width flag = mapping_is_s_channel (forest%s_mapping(channel)) if (flag) then mass = mapping_get_mass (forest%s_mapping(channel)) width = mapping_get_width (forest%s_mapping(channel)) else mass = 0 width = 0 end if end subroutine phs_forest_get_s_mapping subroutine phs_forest_get_on_shell (forest, channel, flag, mass) type(phs_forest_t), intent(in) :: forest integer, intent(in) :: channel logical, intent(out) :: flag real(default), intent(out) :: mass flag = mapping_is_on_shell (forest%s_mapping(channel)) if (flag) then mass = mapping_get_mass (forest%s_mapping(channel)) else mass = 0 end if end subroutine phs_forest_get_on_shell @ %def phs_forest_get_s_mapping @ %def phs_forest_get_on_shell @ Extract the set of unique resonance histories, in form of an array. <>= procedure :: extract_resonance_history_set & => phs_forest_extract_resonance_history_set <>= subroutine phs_forest_extract_resonance_history_set & (forest, res_set, include_trivial) class(phs_forest_t), intent(in) :: forest type(resonance_history_set_t), intent(out) :: res_set logical, intent(in), optional :: include_trivial type(resonance_history_t) :: rh integer :: g, t logical :: triv triv = .false.; if (present (include_trivial)) triv = include_trivial call res_set%init () do g = 1, size (forest%grove) associate (grove => forest%grove(g)) do t = 1, size (grove%tree) call grove%tree(t)%extract_resonance_history (rh) call res_set%enter (rh, include_trivial) end do end associate end do call res_set%freeze () end subroutine phs_forest_extract_resonance_history_set @ %def phs_forest_extract_resonance_history_set @ \subsection{Read the phase space setup from file} The phase space setup is stored in a file. The file may be generated by the [[cascades]] module below, or by other means. This file has to be read and parsed to create the PHS forest as the internal phase-space representation. Create lexer and syntax: <>= subroutine define_phs_forest_syntax (ifile) type(ifile_t) :: ifile call ifile_append (ifile, "SEQ phase_space_list = process_phase_space*") call ifile_append (ifile, "SEQ process_phase_space = " & // "process_def process_header phase_space") call ifile_append (ifile, "SEQ process_def = process process_list") call ifile_append (ifile, "KEY process") call ifile_append (ifile, "LIS process_list = process_tag*") call ifile_append (ifile, "IDE process_tag") call ifile_append (ifile, "SEQ process_header = " & // "md5sum_process = md5sum " & // "md5sum_model_par = md5sum " & // "md5sum_phs_config = md5sum " & // "sqrts = real " & // "m_threshold_s = real " & // "m_threshold_t = real " & // "off_shell = integer " & // "t_channel = integer " & // "keep_nonresonant = logical") call ifile_append (ifile, "KEY '='") call ifile_append (ifile, "KEY '-'") call ifile_append (ifile, "KEY md5sum_process") call ifile_append (ifile, "KEY md5sum_model_par") call ifile_append (ifile, "KEY md5sum_phs_config") call ifile_append (ifile, "KEY sqrts") call ifile_append (ifile, "KEY m_threshold_s") call ifile_append (ifile, "KEY m_threshold_t") call ifile_append (ifile, "KEY off_shell") call ifile_append (ifile, "KEY t_channel") call ifile_append (ifile, "KEY keep_nonresonant") call ifile_append (ifile, "QUO md5sum = '""' ... '""'") call ifile_append (ifile, "REA real") call ifile_append (ifile, "INT integer") call ifile_append (ifile, "IDE logical") call ifile_append (ifile, "SEQ phase_space = grove_def+") call ifile_append (ifile, "SEQ grove_def = grove tree_def+") call ifile_append (ifile, "KEY grove") call ifile_append (ifile, "SEQ tree_def = tree bincodes mapping*") call ifile_append (ifile, "KEY tree") call ifile_append (ifile, "SEQ bincodes = bincode*") call ifile_append (ifile, "INT bincode") call ifile_append (ifile, "SEQ mapping = map bincode channel signed_pdg") call ifile_append (ifile, "KEY map") call ifile_append (ifile, "ALT channel = & &s_channel | t_channel | u_channel | & &collinear | infrared | radiation | on_shell") call ifile_append (ifile, "KEY s_channel") ! call ifile_append (ifile, "KEY t_channel") !!! Key already exists call ifile_append (ifile, "KEY u_channel") call ifile_append (ifile, "KEY collinear") call ifile_append (ifile, "KEY infrared") call ifile_append (ifile, "KEY radiation") call ifile_append (ifile, "KEY on_shell") call ifile_append (ifile, "ALT signed_pdg = & &pdg | negative_pdg") call ifile_append (ifile, "SEQ negative_pdg = '-' pdg") call ifile_append (ifile, "INT pdg") end subroutine define_phs_forest_syntax @ %def define_phs_forest_syntax @ The model-file syntax and lexer are fixed, therefore stored as module variables: <>= type(syntax_t), target, save :: syntax_phs_forest @ %def syntax_phs_forest <>= public :: syntax_phs_forest_init <>= subroutine syntax_phs_forest_init () type(ifile_t) :: ifile call define_phs_forest_syntax (ifile) call syntax_init (syntax_phs_forest, ifile) call ifile_final (ifile) end subroutine syntax_phs_forest_init @ %def syntax_phs_forest_init <>= subroutine lexer_init_phs_forest (lexer) type(lexer_t), intent(out) :: lexer call lexer_init (lexer, & comment_chars = "#!", & quote_chars = '"', & quote_match = '"', & single_chars = "-", & special_class = ["="] , & keyword_list = syntax_get_keyword_list_ptr (syntax_phs_forest)) end subroutine lexer_init_phs_forest @ %def lexer_init_phs_forest <>= public :: syntax_phs_forest_final <>= subroutine syntax_phs_forest_final () call syntax_final (syntax_phs_forest) end subroutine syntax_phs_forest_final @ %def syntax_phs_forest_final <>= public :: syntax_phs_forest_write <>= subroutine syntax_phs_forest_write (unit) integer, intent(in), optional :: unit call syntax_write (syntax_phs_forest, unit) end subroutine syntax_phs_forest_write @ %def syntax_phs_forest_write @ The concrete parser and interpreter. Generate an input stream for the external [[unit]], read the parse tree (with given [[syntax]] and [[lexer]]) from this stream, and transfer the contents of the parse tree to the PHS [[forest]]. We look for the matching [[process]] tag, count groves and trees for initializing the [[forest]], and fill the trees. If the optional parameters are set, compare the parameters stored in the file to those. Set [[match]] true if everything agrees. <>= public :: phs_forest_read <>= interface phs_forest_read module procedure phs_forest_read_file module procedure phs_forest_read_unit module procedure phs_forest_read_parse_tree end interface <>= subroutine phs_forest_read_file & (forest, filename, process_id, n_in, n_out, model, found, & md5sum_process, md5sum_model_par, & md5sum_phs_config, phs_par, match) type(phs_forest_t), intent(out) :: forest type(string_t), intent(in) :: filename type(string_t), intent(in) :: process_id integer, intent(in) :: n_in, n_out class(model_data_t), intent(in), target :: model logical, intent(out) :: found character(32), intent(in), optional :: & md5sum_process, md5sum_model_par, md5sum_phs_config type(phs_parameters_t), intent(in), optional :: phs_par logical, intent(out), optional :: match type(parse_tree_t), target :: parse_tree type(stream_t), target :: stream type(lexer_t) :: lexer call lexer_init_phs_forest (lexer) call stream_init (stream, char (filename)) call lexer_assign_stream (lexer, stream) call parse_tree_init (parse_tree, syntax_phs_forest, lexer) call phs_forest_read (forest, parse_tree, & process_id, n_in, n_out, model, found, & md5sum_process, md5sum_model_par, md5sum_phs_config, phs_par, match) call stream_final (stream) call lexer_final (lexer) call parse_tree_final (parse_tree) end subroutine phs_forest_read_file subroutine phs_forest_read_unit & (forest, unit, process_id, n_in, n_out, model, found, & md5sum_process, md5sum_model_par, md5sum_phs_config, & phs_par, match) type(phs_forest_t), intent(out) :: forest integer, intent(in) :: unit type(string_t), intent(in) :: process_id integer, intent(in) :: n_in, n_out class(model_data_t), intent(in), target :: model logical, intent(out) :: found character(32), intent(in), optional :: & md5sum_process, md5sum_model_par, md5sum_phs_config type(phs_parameters_t), intent(in), optional :: phs_par logical, intent(out), optional :: match type(parse_tree_t), target :: parse_tree type(stream_t), target :: stream type(lexer_t) :: lexer call lexer_init_phs_forest (lexer) call stream_init (stream, unit) call lexer_assign_stream (lexer, stream) call parse_tree_init (parse_tree, syntax_phs_forest, lexer) call phs_forest_read (forest, parse_tree, & process_id, n_in, n_out, model, found, & md5sum_process, md5sum_model_par, md5sum_phs_config, & phs_par, match) call stream_final (stream) call lexer_final (lexer) call parse_tree_final (parse_tree) end subroutine phs_forest_read_unit subroutine phs_forest_read_parse_tree & (forest, parse_tree, process_id, n_in, n_out, model, found, & md5sum_process, md5sum_model_par, md5sum_phs_config, & phs_par, match) type(phs_forest_t), intent(out) :: forest type(parse_tree_t), intent(in), target :: parse_tree type(string_t), intent(in) :: process_id integer, intent(in) :: n_in, n_out class(model_data_t), intent(in), target :: model logical, intent(out) :: found character(32), intent(in), optional :: & md5sum_process, md5sum_model_par, md5sum_phs_config type(phs_parameters_t), intent(in), optional :: phs_par logical, intent(out), optional :: match type(parse_node_t), pointer :: node_header, node_phs, node_grove integer :: n_grove, g integer, dimension(:), allocatable :: n_tree integer :: t node_header => parse_tree_get_process_ptr (parse_tree, process_id) found = associated (node_header); if (.not. found) return if (present (match)) then call phs_forest_check_input (node_header, & md5sum_process, md5sum_model_par, md5sum_phs_config, phs_par, match) if (.not. match) return end if node_phs => parse_node_get_next_ptr (node_header) n_grove = parse_node_get_n_sub (node_phs) allocate (n_tree (n_grove)) do g = 1, n_grove node_grove => parse_node_get_sub_ptr (node_phs, g) n_tree(g) = parse_node_get_n_sub (node_grove) - 1 end do call phs_forest_init (forest, n_tree, n_in, n_out) do g = 1, n_grove node_grove => parse_node_get_sub_ptr (node_phs, g) do t = 1, n_tree(g) call phs_tree_set (forest%grove(g)%tree(t), & parse_node_get_sub_ptr (node_grove, t+1), model) end do end do end subroutine phs_forest_read_parse_tree @ %def phs_forest @ Check the input for consistency. If any MD5 sum or phase-space parameter disagrees, the phase-space file cannot be used. The MD5 sum checks are skipped if the stored MD5 sum is empty. <>= subroutine phs_forest_check_input (pn_header, & md5sum_process, md5sum_model_par, md5sum_phs_config, phs_par, match) type(parse_node_t), intent(in), target :: pn_header character(32), intent(in) :: & md5sum_process, md5sum_model_par, md5sum_phs_config type(phs_parameters_t), intent(in), optional :: phs_par logical, intent(out) :: match type(parse_node_t), pointer :: pn_md5sum, pn_rval, pn_ival, pn_lval character(32) :: md5sum type(phs_parameters_t) :: phs_par_old character(1) :: lstr pn_md5sum => parse_node_get_sub_ptr (pn_header, 3) md5sum = parse_node_get_string (pn_md5sum) if (md5sum /= "" .and. md5sum /= md5sum_process) then call msg_message ("Phase space: discarding old configuration & &(process changed)") match = .false.; return end if pn_md5sum => parse_node_get_next_ptr (pn_md5sum, 3) md5sum = parse_node_get_string (pn_md5sum) if (md5sum /= "" .and. md5sum /= md5sum_model_par) then call msg_message ("Phase space: discarding old configuration & &(model parameters changed)") match = .false.; return end if pn_md5sum => parse_node_get_next_ptr (pn_md5sum, 3) md5sum = parse_node_get_string (pn_md5sum) if (md5sum /= "" .and. md5sum /= md5sum_phs_config) then call msg_message ("Phase space: discarding old configuration & &(configuration parameters changed)") match = .false.; return end if if (present (phs_par)) then pn_rval => parse_node_get_next_ptr (pn_md5sum, 3) phs_par_old%sqrts = parse_node_get_real (pn_rval) pn_rval => parse_node_get_next_ptr (pn_rval, 3) phs_par_old%m_threshold_s = parse_node_get_real (pn_rval) pn_rval => parse_node_get_next_ptr (pn_rval, 3) phs_par_old%m_threshold_t = parse_node_get_real (pn_rval) pn_ival => parse_node_get_next_ptr (pn_rval, 3) phs_par_old%off_shell = parse_node_get_integer (pn_ival) pn_ival => parse_node_get_next_ptr (pn_ival, 3) phs_par_old%t_channel = parse_node_get_integer (pn_ival) pn_lval => parse_node_get_next_ptr (pn_ival, 3) lstr = parse_node_get_string (pn_lval) read (lstr, "(L1)") phs_par_old%keep_nonresonant if (phs_par_old /= phs_par) then call msg_message & ("Phase space: discarding old configuration & &(configuration parameters changed)") match = .false.; return end if end if match = .true. end subroutine phs_forest_check_input @ %def phs_forest_check_input @ Initialize a specific tree in the forest, using the contents of the 'tree' node. First, count the bincodes, allocate an array and read them in, and make the tree. Each $t$-channel tree is flipped to $s$-channel. Then, find mappings and initialize them. <>= subroutine phs_tree_set (tree, node, model) type(phs_tree_t), intent(inout) :: tree type(parse_node_t), intent(in), target :: node class(model_data_t), intent(in), target :: model type(parse_node_t), pointer :: node_bincodes, node_mapping, pn_pdg integer :: n_bincodes, offset integer(TC), dimension(:), allocatable :: bincode integer :: b, n_mappings, m integer(TC) :: k type(string_t) :: type integer :: pdg node_bincodes => parse_node_get_sub_ptr (node, 2) if (associated (node_bincodes)) then select case (char (parse_node_get_rule_key (node_bincodes))) case ("bincodes") n_bincodes = parse_node_get_n_sub (node_bincodes) offset = 2 case default n_bincodes = 0 offset = 1 end select else n_bincodes = 0 offset = 2 end if allocate (bincode (n_bincodes)) do b = 1, n_bincodes bincode(b) = parse_node_get_integer & (parse_node_get_sub_ptr (node_bincodes, b)) end do call phs_tree_from_array (tree, bincode) call phs_tree_flip_t_to_s_channel (tree) call phs_tree_canonicalize (tree) n_mappings = parse_node_get_n_sub (node) - offset do m = 1, n_mappings node_mapping => parse_node_get_sub_ptr (node, m + offset) k = parse_node_get_integer & (parse_node_get_sub_ptr (node_mapping, 2)) type = parse_node_get_key & (parse_node_get_sub_ptr (node_mapping, 3)) pn_pdg => parse_node_get_sub_ptr (node_mapping, 4) select case (char (pn_pdg%get_rule_key ())) case ("pdg") pdg = pn_pdg%get_integer () case ("negative_pdg") pdg = - parse_node_get_integer (pn_pdg%get_sub_ptr (2)) end select call phs_tree_init_mapping (tree, k, type, pdg, model) end do end subroutine phs_tree_set @ %def phs_tree_set @ \subsection{Preparation} The trees that we read from file do not carry flavor information. This is set separately: The flavor list must be unique for a unique set of masses; if a given particle can have different flavor, the mass must be degenerate, so we can choose one of the possible flavor combinations. <>= public :: phs_forest_set_flavors <>= subroutine phs_forest_set_flavors (forest, flv, reshuffle, flv_extra) type(phs_forest_t), intent(inout) :: forest type(flavor_t), dimension(:), intent(in) :: flv integer, intent(in), dimension(:), allocatable, optional :: reshuffle type(flavor_t), intent(in), optional :: flv_extra integer :: i, n_flv0 if (present (reshuffle) .and. present (flv_extra)) then n_flv0 = size (flv) do i = 1, n_flv0 if (reshuffle(i) <= n_flv0) then forest%flv(i) = flv (reshuffle(i)) else forest%flv(i) = flv_extra end if end do else allocate (forest%flv (size (flv))) forest%flv = flv end if end subroutine phs_forest_set_flavors @ %def phs_forest_set_flavors @ <>= public :: phs_forest_set_momentum_links <>= subroutine phs_forest_set_momentum_links (forest, list) type(phs_forest_t), intent(inout) :: forest integer, intent(in), dimension(:), allocatable :: list integer :: g, t do g = 1, size (forest%grove) do t = 1, size (forest%grove(g)%tree) associate (tree => forest%grove(g)%tree(t)) call phs_tree_set_momentum_links (tree, list) !!! call phs_tree_reshuffle_mappings (tree) end associate end do end do end subroutine phs_forest_set_momentum_links @ %def phs_forest_set_momentum_links @ Once the parameter set is fixed, the masses and the widths of the particles are known and the [[mass_sum]] arrays as well as the mapping parameters can be computed. Note that order is important: we first compute the mass sums, then the ordinary mappings. The resonances obtained here determine the effective masses, which in turn are used to implement step mappings for resonance decay products that are not mapped otherwise. <>= public :: phs_forest_set_parameters <>= subroutine phs_forest_set_parameters & (forest, mapping_defaults, variable_limits) type(phs_forest_t), intent(inout) :: forest type(mapping_defaults_t), intent(in) :: mapping_defaults logical, intent(in) :: variable_limits integer :: g, t do g = 1, size (forest%grove) do t = 1, size (forest%grove(g)%tree) call phs_tree_set_mass_sum & (forest%grove(g)%tree(t), forest%flv(forest%n_in+1:)) call phs_tree_set_mapping_parameters (forest%grove(g)%tree(t), & mapping_defaults, variable_limits) call phs_tree_set_effective_masses (forest%grove(g)%tree(t)) if (mapping_defaults%step_mapping) then call phs_tree_set_step_mappings (forest%grove(g)%tree(t), & mapping_defaults%step_mapping_exp, variable_limits) end if end do end do end subroutine phs_forest_set_parameters @ %def phs_forest_set_parameters @ Generate the particle combination table. Scan all trees and merge their individual combination tables. At the end, valid entries are non-zero, and they indicate the indices of a pair of particles to be combined to a new particle. If a particle is accessible by more than one tree (this is usual), only keep the first possibility. <>= public :: phs_forest_setup_prt_combinations <>= subroutine phs_forest_setup_prt_combinations (forest) type(phs_forest_t), intent(inout) :: forest integer :: g, t integer, dimension(:,:), allocatable :: tree_prt_combination forest%prt_combination = 0 allocate (tree_prt_combination (2, size (forest%prt_combination, 2))) do g = 1, size (forest%grove) do t = 1, size (forest%grove(g)%tree) call phs_tree_setup_prt_combinations & (forest%grove(g)%tree(t), tree_prt_combination) where (tree_prt_combination /= 0 .and. forest%prt_combination == 0) forest%prt_combination = tree_prt_combination end where end do end do end subroutine phs_forest_setup_prt_combinations @ %def phs_forest_setup_prt_combinations @ \subsection{Accessing the particle arrays} Set the incoming particles from the contents of an interaction. <>= public :: phs_forest_set_prt_in <>= interface phs_forest_set_prt_in module procedure phs_forest_set_prt_in_int, phs_forest_set_prt_in_mom end interface phs_forest_set_prt_in <>= subroutine phs_forest_set_prt_in_int (forest, int, lt_cm_to_lab) type(phs_forest_t), intent(inout) :: forest type(interaction_t), intent(in) :: int type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab if (present (lt_cm_to_lab)) then call phs_prt_set_momentum (forest%prt_in, & inverse (lt_cm_to_lab) * & int%get_momenta (outgoing=.false.)) else call phs_prt_set_momentum (forest%prt_in, & int%get_momenta (outgoing=.false.)) end if associate (m_in => forest%flv(:forest%n_in)%get_mass ()) call phs_prt_set_msq (forest%prt_in, m_in ** 2) end associate call phs_prt_set_defined (forest%prt_in) end subroutine phs_forest_set_prt_in_int subroutine phs_forest_set_prt_in_mom (forest, mom, lt_cm_to_lab) type(phs_forest_t), intent(inout) :: forest type(vector4_t), dimension(size (forest%prt_in)), intent(in) :: mom type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab if (present (lt_cm_to_lab)) then call phs_prt_set_momentum (forest%prt_in, & inverse (lt_cm_to_lab) * mom) else call phs_prt_set_momentum (forest%prt_in, mom) end if associate (m_in => forest%flv(:forest%n_in)%get_mass ()) call phs_prt_set_msq (forest%prt_in, m_in ** 2) end associate call phs_prt_set_defined (forest%prt_in) end subroutine phs_forest_set_prt_in_mom @ %def phs_forest_set_prt_in @ Set the outgoing particles from the contents of an interaction. <>= public :: phs_forest_set_prt_out <>= interface phs_forest_set_prt_out module procedure phs_forest_set_prt_out_int, phs_forest_set_prt_out_mom end interface phs_forest_set_prt_out <>= subroutine phs_forest_set_prt_out_int (forest, int, lt_cm_to_lab) type(phs_forest_t), intent(inout) :: forest type(interaction_t), intent(in) :: int type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab if (present (lt_cm_to_lab)) then call phs_prt_set_momentum (forest%prt_out, & inverse (lt_cm_to_lab) * & int%get_momenta (outgoing=.true.)) else call phs_prt_set_momentum (forest%prt_out, & int%get_momenta (outgoing=.true.)) end if associate (m_out => forest%flv(forest%n_in+1:)%get_mass ()) call phs_prt_set_msq (forest%prt_out, m_out ** 2) end associate call phs_prt_set_defined (forest%prt_out) end subroutine phs_forest_set_prt_out_int subroutine phs_forest_set_prt_out_mom (forest, mom, lt_cm_to_lab) type(phs_forest_t), intent(inout) :: forest type(vector4_t), dimension(size (forest%prt_out)), intent(in) :: mom type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab if (present (lt_cm_to_lab)) then call phs_prt_set_momentum (forest%prt_out, & inverse (lt_cm_to_lab) * mom) else call phs_prt_set_momentum (forest%prt_out, mom) end if associate (m_out => forest%flv(forest%n_in+1:)%get_mass ()) call phs_prt_set_msq (forest%prt_out, m_out ** 2) end associate call phs_prt_set_defined (forest%prt_out) end subroutine phs_forest_set_prt_out_mom @ %def phs_forest_set_prt_out @ Combine particles as described by the particle combination table. Particle momentum sums will be calculated only if the resulting particle is contained in at least one of the trees in the current forest. The others are kept undefined. <>= public :: phs_forest_combine_particles <>= subroutine phs_forest_combine_particles (forest) type(phs_forest_t), intent(inout) :: forest integer :: k integer, dimension(2) :: kk do k = 1, size (forest%prt_combination, 2) kk = forest%prt_combination(:,k) if (kk(1) /= 0) then call phs_prt_combine (forest%prt(k), & forest%prt(kk(1)), forest%prt(kk(2))) end if end do end subroutine phs_forest_combine_particles @ %def phs_forest_combine_particles @ Extract the outgoing particles and insert into an interaction. <>= public :: phs_forest_get_prt_out <>= subroutine phs_forest_get_prt_out (forest, int, lt_cm_to_lab) type(phs_forest_t), intent(in) :: forest type(interaction_t), intent(inout) :: int type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab if (present (lt_cm_to_lab)) then call int%set_momenta (lt_cm_to_lab * & phs_prt_get_momentum (forest%prt_out), outgoing=.true.) else call int%set_momenta (phs_prt_get_momentum (forest%prt_out), & outgoing=.true.) end if end subroutine phs_forest_get_prt_out @ %def phs_forest_get_prt_out @ Extract the outgoing particle momenta <>= public :: phs_forest_get_momenta_out <>= function phs_forest_get_momenta_out (forest, lt_cm_to_lab) result (p) type(phs_forest_t), intent(in) :: forest type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab type(vector4_t), dimension(size (forest%prt_out)) :: p p = phs_prt_get_momentum (forest%prt_out) if (present (lt_cm_to_lab)) p = p * lt_cm_to_lab end function phs_forest_get_momenta_out @ %def phs_forest_get_momenta_out @ \subsection{Find equivalences among phase-space trees} Scan phase space for equivalences. We generate the complete set of unique permutations for the given list of outgoing particles, and use this for scanning equivalences within each grove. @ We scan all pairs of trees, using all permutations. This implies that trivial equivalences are included, and equivalences between different trees are recorded twice. This is intentional. <>= subroutine phs_grove_set_equivalences (grove, perm_array) type(phs_grove_t), intent(inout) :: grove type(permutation_t), dimension(:), intent(in) :: perm_array type(equivalence_t), pointer :: eq integer :: t1, t2, i do t1 = 1, size (grove%tree) do t2 = 1, size (grove%tree) SCAN_PERM: do i = 1, size (perm_array) if (phs_tree_equivalent & (grove%tree(t1), grove%tree(t2), perm_array(i))) then call equivalence_list_add & (grove%equivalence_list, t1, t2, perm_array(i)) eq => grove%equivalence_list%last call phs_tree_find_msq_permutation & (grove%tree(t1), grove%tree(t2), eq%perm, & eq%msq_perm) call phs_tree_find_angle_permutation & (grove%tree(t1), grove%tree(t2), eq%perm, & eq%angle_perm, eq%angle_sig) end if end do SCAN_PERM end do end do end subroutine phs_grove_set_equivalences @ %def phs_grove_set_equivalences <>= public :: phs_forest_set_equivalences <>= subroutine phs_forest_set_equivalences (forest) type(phs_forest_t), intent(inout) :: forest type(permutation_t), dimension(:), allocatable :: perm_array integer :: i call permutation_array_make & (perm_array, forest%flv(forest%n_in+1:)%get_pdg ()) do i = 1, size (forest%grove) call phs_grove_set_equivalences (forest%grove(i), perm_array) end do forest%n_equivalences = sum (forest%grove%equivalence_list%length) end subroutine phs_forest_set_equivalences @ %def phs_forest_set_equivalences @ \subsection{Interface for channel equivalences} Here, we store the equivalence list in the appropriate containers that the [[phs_base]] module provides. There is one separate list for each channel. <>= public :: phs_forest_get_equivalences <>= subroutine phs_forest_get_equivalences (forest, channel, azimuthal_dependence) type(phs_forest_t), intent(in) :: forest type(phs_channel_t), dimension(:), intent(out) :: channel logical, intent(in) :: azimuthal_dependence integer :: n_masses, n_angles integer :: mode_azimuthal_angle integer, dimension(:), allocatable :: n_eq type(equivalence_t), pointer :: eq integer, dimension(:), allocatable :: perm, mode integer :: g, c, j, left, right n_masses = forest%n_masses n_angles = forest%n_angles allocate (n_eq (forest%n_trees), source = 0) allocate (perm (forest%n_dimensions)) allocate (mode (forest%n_dimensions), source = EQ_IDENTITY) do g = 1, size (forest%grove) eq => forest%grove(g)%equivalence_list%first do while (associated (eq)) left = eq%left + forest%grove(g)%tree_count_offset n_eq(left) = n_eq(left) + 1 eq => eq%next end do end do do c = 1, size (channel) allocate (channel(c)%eq (n_eq(c))) do j = 1, n_eq(c) call channel(c)%eq(j)%init (forest%n_dimensions) end do end do n_eq = 0 if (azimuthal_dependence) then mode_azimuthal_angle = EQ_IDENTITY else mode_azimuthal_angle = EQ_INVARIANT end if do g = 1, size (forest%grove) eq => forest%grove(g)%equivalence_list%first do while (associated (eq)) left = eq%left + forest%grove(g)%tree_count_offset right = eq%right + forest%grove(g)%tree_count_offset do j = 1, n_masses perm(j) = permute (j, eq%msq_perm) mode(j) = EQ_IDENTITY end do do j = 1, n_angles perm(n_masses+j) = n_masses + permute (j, eq%angle_perm) if (j == 1) then mode(n_masses+j) = mode_azimuthal_angle ! first az. angle else if (mod(j,2) == 1) then mode(n_masses+j) = EQ_SYMMETRIC ! other az. angles else if (eq%angle_sig(j)) then mode(n_masses+j) = EQ_IDENTITY ! polar angle + else mode(n_masses+j) = EQ_INVERT ! polar angle - end if end do n_eq(left) = n_eq(left) + 1 associate (eq_cur => channel(left)%eq(n_eq(left))) eq_cur%c = right eq_cur%perm = perm eq_cur%mode = mode end associate eq => eq%next end do end do end subroutine phs_forest_get_equivalences @ %def phs_forest_get_equivalences @ \subsection{Phase-space evaluation} Given one row of the [[x]] parameter array and the corresponding channel index, compute first all relevant momenta and then recover the remainder of the [[x]] array, the Jacobians [[phs_factor]], and the phase-space [[volume]]. The output argument [[ok]] indicates whether this was successful. <>= public :: phs_forest_evaluate_selected_channel <>= subroutine phs_forest_evaluate_selected_channel & (forest, channel, active, sqrts, x, phs_factor, volume, ok) type(phs_forest_t), intent(inout) :: forest integer, intent(in) :: channel logical, dimension(:), intent(in) :: active real(default), intent(in) :: sqrts real(default), dimension(:,:), intent(inout) :: x real(default), dimension(:), intent(out) :: phs_factor real(default), intent(out) :: volume logical, intent(out) :: ok integer :: g, t integer(TC) :: k, k_root, k_in g = forest%grove_lookup (channel) t = channel - forest%grove(g)%tree_count_offset call phs_prt_set_undefined (forest%prt) call phs_prt_set_undefined (forest%prt_out) k_in = forest%n_tot do k = 1,forest%n_in forest%prt(ibset(0,k_in-k)) = forest%prt_in(k) end do do k = 1, forest%n_out call phs_prt_set_msq (forest%prt(ibset(0,k-1)), & forest%flv(forest%n_in+k)%get_mass () ** 2) end do k_root = 2**forest%n_out - 1 select case (forest%n_in) case (1) forest%prt(k_root) = forest%prt_in(1) case (2) call phs_prt_combine & (forest%prt(k_root), forest%prt_in(1), forest%prt_in(2)) end select call phs_tree_compute_momenta_from_x (forest%grove(g)%tree(t), & forest%prt, phs_factor(channel), volume, sqrts, x(:,channel), ok) if (ok) then do k = 1, forest%n_out forest%prt_out(k) = forest%prt(ibset(0,k-1)) end do end if end subroutine phs_forest_evaluate_selected_channel @ %def phs_forest_evaluate_selected_channel @ The remainder: recover $x$ values for all channels except for the current channel. NOTE: OpenMP not used for the first loop. [[combine_particles]] is not a channel-local operation. <>= public :: phs_forest_evaluate_other_channels <>= subroutine phs_forest_evaluate_other_channels & (forest, channel, active, sqrts, x, phs_factor, combine) type(phs_forest_t), intent(inout) :: forest integer, intent(in) :: channel logical, dimension(:), intent(in) :: active real(default), intent(in) :: sqrts real(default), dimension(:,:), intent(inout) :: x real(default), dimension(:), intent(inout) :: phs_factor logical, intent(in) :: combine integer :: g, t, ch, n_channel g = forest%grove_lookup (channel) t = channel - forest%grove(g)%tree_count_offset n_channel = forest%n_trees if (combine) then do ch = 1, n_channel if (ch == channel) cycle if (active(ch)) then g = forest%grove_lookup(ch) t = ch - forest%grove(g)%tree_count_offset call phs_tree_combine_particles & (forest%grove(g)%tree(t), forest%prt) end if end do end if !OMP PARALLEL PRIVATE (g,t,ch) SHARED(active,forest,sqrts,x,channel) !OMP DO SCHEDULE(STATIC) do ch = 1, n_channel if (ch == channel) cycle if (active(ch)) then g = forest%grove_lookup(ch) t = ch - forest%grove(g)%tree_count_offset call phs_tree_compute_x_from_momenta & (forest%grove(g)%tree(t), & forest%prt, phs_factor(ch), sqrts, x(:,ch)) end if end do !OMP END DO !OMP END PARALLEL end subroutine phs_forest_evaluate_other_channels @ %def phs_forest_evaluate_other_channels @ The complement: recover one row of the [[x]] array and the associated Jacobian entry, corresponding to [[channel]], from incoming and outgoing momenta. Also compute the phase-space volume. <>= public :: phs_forest_recover_channel <>= subroutine phs_forest_recover_channel & (forest, channel, sqrts, x, phs_factor, volume) type(phs_forest_t), intent(inout) :: forest integer, intent(in) :: channel real(default), intent(in) :: sqrts real(default), dimension(:,:), intent(inout) :: x real(default), dimension(:), intent(inout) :: phs_factor real(default), intent(out) :: volume integer :: g, t integer(TC) :: k, k_in g = forest%grove_lookup (channel) t = channel - forest%grove(g)%tree_count_offset call phs_prt_set_undefined (forest%prt) k_in = forest%n_tot forall (k = 1:forest%n_in) forest%prt(ibset(0,k_in-k)) = forest%prt_in(k) end forall forall (k = 1:forest%n_out) forest%prt(ibset(0,k-1)) = forest%prt_out(k) end forall call phs_forest_combine_particles (forest) call phs_tree_compute_volume & (forest%grove(g)%tree(t), sqrts, volume) call phs_tree_compute_x_from_momenta & (forest%grove(g)%tree(t), & forest%prt, phs_factor(channel), sqrts, x(:,channel)) end subroutine phs_forest_recover_channel @ %def phs_forest_recover_channel @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[phs_forests_ut.f90]]>>= <> module phs_forests_ut use unit_tests use phs_forests_uti <> <> contains <> end module phs_forests_ut @ %def phs_forests_ut @ <<[[phs_forests_uti.f90]]>>= <> module phs_forests_uti <> <> use io_units use format_defs, only: FMT_12 use lorentz use flavors use interactions use model_data use mappings use phs_base use resonances, only: resonance_history_set_t use phs_forests <> <> contains <> end module phs_forests_uti @ %def phs_forests_ut @ API: driver for the unit tests below. <>= public :: phs_forests_test <>= subroutine phs_forests_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine phs_forests_test @ %def phs_forests_test @ \subsubsection{Basic universal test} Write a possible phase-space file for a $2\to 3$ process and make the corresponding forest, print the forest. Choose some in-particle momenta and a random-number array and evaluate out-particles and phase-space factors. <>= call test (phs_forest_1, "phs_forest_1", & "check phs forest setup", & u, results) <>= public :: phs_forest_1 <>= subroutine phs_forest_1 (u) use os_interface integer, intent(in) :: u type(phs_forest_t) :: forest type(phs_channel_t), dimension(:), allocatable :: channel type(model_data_t), target :: model type(string_t) :: process_id type(flavor_t), dimension(5) :: flv type(string_t) :: filename type(interaction_t) :: int integer :: unit_fix type(mapping_defaults_t) :: mapping_defaults logical :: found_process, ok integer :: n_channel, ch, i logical, dimension(4) :: active = .true. real(default) :: sqrts = 1000 real(default), dimension(5,4) :: x real(default), dimension(4) :: factor real(default) :: volume write (u, "(A)") "* Test output: PHS forest" write (u, "(A)") "* Purpose: test PHS forest routines" write (u, "(A)") write (u, "(A)") "* Reading model file" call model%init_sm_test () write (u, "(A)") write (u, "(A)") "* Create phase-space file 'phs_forest_test.phs'" write (u, "(A)") call flv%init ([11, -11, 11, -11, 22], model) unit_fix = free_unit () open (file="phs_forest_test.phs", unit=unit_fix, action="write") write (unit_fix, *) "process foo" write (unit_fix, *) 'md5sum_process = "6ABA33BC2927925D0F073B1C1170780A"' write (unit_fix, *) 'md5sum_model_par = "1A0B151EE6E2DEB92D880320355A3EAB"' write (unit_fix, *) 'md5sum_phs_config = "B6A8877058809A8BDD54753CDAB83ACE"' write (unit_fix, *) "sqrts = 100.00000000000000" write (unit_fix, *) "m_threshold_s = 50.000000000000000" write (unit_fix, *) "m_threshold_t = 100.00000000000000" write (unit_fix, *) "off_shell = 2" write (unit_fix, *) "t_channel = 6" write (unit_fix, *) "keep_nonresonant = F" write (unit_fix, *) "" write (unit_fix, *) " grove" write (unit_fix, *) " tree 3 7" write (unit_fix, *) " map 3 s_channel 23" write (unit_fix, *) " tree 5 7" write (unit_fix, *) " tree 6 7" write (unit_fix, *) " grove" write (unit_fix, *) " tree 9 11" write (unit_fix, *) " map 9 t_channel 22" close (unit_fix) write (u, "(A)") write (u, "(A)") "* Read phase-space file 'phs_forest_test.phs'" call syntax_phs_forest_init () process_id = "foo" filename = "phs_forest_test.phs" call phs_forest_read & (forest, filename, process_id, 2, 3, model, found_process) write (u, "(A)") write (u, "(A)") "* Set parameters, flavors, equiv, momenta" write (u, "(A)") call phs_forest_set_flavors (forest, flv) call phs_forest_set_parameters (forest, mapping_defaults, .false.) call phs_forest_setup_prt_combinations (forest) call phs_forest_set_equivalences (forest) call int%basic_init (2, 0, 3) call int%set_momentum & (vector4_moving (500._default, 500._default, 3), 1) call int%set_momentum & (vector4_moving (500._default,-500._default, 3), 2) call phs_forest_set_prt_in (forest, int) n_channel = 2 x = 0 x(:,n_channel) = [0.3, 0.4, 0.1, 0.9, 0.6] write (u, "(A)") " Input values:" write (u, "(3x,5(1x," // FMT_12 // "))") x(:,n_channel) write (u, "(A)") write (u, "(A)") "* Evaluating phase space" call phs_forest_evaluate_selected_channel (forest, & n_channel, active, sqrts, x, factor, volume, ok) call phs_forest_evaluate_other_channels (forest, & n_channel, active, sqrts, x, factor, combine=.true.) call phs_forest_get_prt_out (forest, int) write (u, "(A)") " Output values:" do ch = 1, 4 write (u, "(3x,5(1x," // FMT_12 // "))") x(:,ch) end do call int%basic_write (u) write (u, "(A)") " Factors:" write (u, "(3x,5(1x," // FMT_12 // "))") factor write (u, "(A)") " Volume:" write (u, "(3x,5(1x," // FMT_12 // "))") volume call phs_forest_write (forest, u) write (u, "(A)") write (u, "(A)") "* Compute equivalences" n_channel = 4 allocate (channel (n_channel)) call phs_forest_get_equivalences (forest, & channel, .true.) do i = 1, n_channel write (u, "(1x,I0,':')", advance = "no") ch call channel(i)%write (u) end do write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () call phs_forest_final (forest) call syntax_phs_forest_final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_forest_1" end subroutine phs_forest_1 @ %def phs_forest_1 @ \subsubsection{Resonance histories} Read a suitably nontrivial forest from file and recover the set of resonance histories. <>= call test (phs_forest_2, "phs_forest_2", & "handle phs forest resonance content", & u, results) <>= public :: phs_forest_2 <>= subroutine phs_forest_2 (u) use os_interface integer, intent(in) :: u integer :: unit_fix type(phs_forest_t) :: forest type(model_data_t), target :: model type(string_t) :: process_id type(string_t) :: filename logical :: found_process type(resonance_history_set_t) :: res_set integer :: i write (u, "(A)") "* Test output: phs_forest_2" write (u, "(A)") "* Purpose: test PHS forest routines" write (u, "(A)") write (u, "(A)") "* Reading model file" call model%init_sm_test () write (u, "(A)") write (u, "(A)") "* Create phase-space file 'phs_forest_2.phs'" write (u, "(A)") unit_fix = free_unit () open (file="phs_forest_2.phs", unit=unit_fix, action="write") write (unit_fix, *) "process foo" write (unit_fix, *) 'md5sum_process = "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"' write (unit_fix, *) 'md5sum_model_par = "1A0B151EE6E2DEB92D880320355A3EAB"' write (unit_fix, *) 'md5sum_phs_config = "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"' write (unit_fix, *) "sqrts = 100.00000000000000" write (unit_fix, *) "m_threshold_s = 50.000000000000000" write (unit_fix, *) "m_threshold_t = 100.00000000000000" write (unit_fix, *) "off_shell = 2" write (unit_fix, *) "t_channel = 6" write (unit_fix, *) "keep_nonresonant = F" write (unit_fix, *) "" write (unit_fix, *) " grove" write (unit_fix, *) " tree 3 7" write (unit_fix, *) " tree 3 7" write (unit_fix, *) " map 3 s_channel -24" write (unit_fix, *) " tree 5 7" write (unit_fix, *) " tree 3 7" write (unit_fix, *) " map 3 s_channel -24" write (unit_fix, *) " map 7 s_channel 23" write (unit_fix, *) " tree 5 7" write (unit_fix, *) " map 7 s_channel 25" write (unit_fix, *) " tree 3 11" write (unit_fix, *) " map 3 s_channel -24" close (unit_fix) write (u, "(A)") "* Read phase-space file 'phs_forest_2.phs'" call syntax_phs_forest_init () process_id = "foo" filename = "phs_forest_2.phs" call phs_forest_read & (forest, filename, process_id, 2, 3, model, found_process) write (u, "(A)") write (u, "(A)") "* Extract resonance history set" write (u, "(A)") call forest%extract_resonance_history_set (res_set) call res_set%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () call phs_forest_final (forest) call syntax_phs_forest_final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_forest_2" end subroutine phs_forest_2 @ %def phs_forest_2 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Finding phase space parameterizations} If the phase space configuration is not found in the appropriate file, we should generate one. The idea is to construct all Feynman diagrams subject to certain constraints which eliminate everything that is probably irrelevant for the integration. These Feynman diagrams (cascades) are grouped in groves by finding equivalence classes related by symmetry and ordered with respect to their importance (resonances). Finally, the result (or part of it) is written to file and used for the integration. This module may eventually disappear and be replaced by CAML code. In particular, we need here a set of Feynman rules (vertices with particle codes, but not the factors). Thus, the module works for the Standard Model only. Note that this module is stand-alone, it communicates to the main program only via the generated ASCII phase-space configuration file. <<[[cascades.f90]]>>= <> module cascades <> use kinds, only: TC, i8, i32 <> use io_units use constants, only: one use format_defs, only: FMT_12, FMT_19 use numeric_utils use diagnostics use hashes use sorting use physics_defs, only: SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR use physics_defs, only: UNDEFINED use model_data use flavors use lorentz use resonances, only: resonance_info_t use resonances, only: resonance_history_t use resonances, only: resonance_history_set_t use phs_forests <> <> <> <> <> contains <> end module cascades @ %def cascades @ \subsection{The mapping modes} The valid mapping modes, to be used below. We will make use of the convention that mappings of internal particles have a positive value. Only for positive values, the flavor code is propagated when combining cascades. <>= integer, parameter :: & & EXTERNAL_PRT = -1, & & NO_MAPPING = 0, S_CHANNEL = 1, T_CHANNEL = 2, U_CHANNEL = 3, & & RADIATION = 4, COLLINEAR = 5, INFRARED = 6, & & STEP_MAPPING_E = 11, STEP_MAPPING_H = 12, & & ON_SHELL = 99 @ %def EXTERNAL_PRT @ %def NO_MAPPING S_CHANNEL T_CHANNEL U_CHANNEL @ %def RADIATION COLLINEAR INFRARED @ %def STEP_MAPPING_E STEP_MAPPING_H @ %def ON_SHELL <>= <> @ \subsection{The cascade type} A cascade is essentially the same as a decay tree (both definitions may be merged in a later version). It contains a linked tree of nodes, each of which representing an internal particle. In contrast to decay trees, each node has a definite particle code. These nodes need not be modified, therefore we can use pointers and do not have to copy them. Thus, physically each cascades has only a single node, the mother particle. However, to be able to compare trees quickly, we store in addition an array of binary codes which is always sorted in ascending order. This is accompanied by a corresponding list of particle codes. The index is the location of the corresponding cascade in the cascade set, this may be used to access the daughters directly. The real mass is the particle mass belonging to the particle code. The minimal mass is the sum of the real masses of all its daughters; this is the kinematical cutoff. The effective mass may be zero if the particle mass is below a certain threshold; it may be the real mass if the particle is resonant; or it may be some other value. The logical [[t_channel]] is set if this a $t$-channel line, while [[initial]] is true only for an initial particle. Note that both initial particles are also [[t_channel]] by definition, and that they are distinguished by the direction of the tree: One of them decays and is the root of the tree, while the other one is one of the leaves. The cascade is a list of nodes (particles) which are linked via the [[daughter]] entries. The node is the mother particle of the decay cascade. Much of the information in the nodes is repeated in arrays, to be accessible more easily. The arrays will be kept sorted by binary codes. The counter [[n_off_shell]] is increased for each internal line that is neither resonant nor log-enhanced. It is set to zero if the current line is resonant, since this implies on-shell particle production and subsequent decay. The counter [[n_t_channel]] is non-negative once an initial particle is included in the tree: then, it counts the number of $t$-channel lines. The [[multiplicity]] is the number of branchings to follow until all daughters are on-shell. A resonant or non-decaying particle has multiplicity one. Merging nodes, the multiplicities add unless the mother is a resonance. An initial or final node has multiplicity zero. The arrays correspond to the subnode tree [[tree]] of the current cascade. PDG codes are stored only for those positions which are resonant, with the exception of the last entry, i.e., the current node. Other positions, in particular external legs, are assigned undefined PDG code. A cascade is uniquely identified by its tree, the tree of PDG codes, and the tree of mappings. The tree of resonances is kept only to mask the PDG tree as described above. <>= type :: cascade_t private ! counters integer :: index = 0 integer :: grove = 0 ! status logical :: active = .false. logical :: complete = .false. logical :: incoming = .false. ! this node integer(TC) :: bincode = 0 type(flavor_t) :: flv integer :: pdg = UNDEFINED logical :: is_vector = .false. real(default) :: m_min = 0 real(default) :: m_rea = 0 real(default) :: m_eff = 0 integer :: mapping = NO_MAPPING logical :: on_shell = .false. logical :: resonant = .false. logical :: log_enhanced = .false. logical :: t_channel = .false. ! global tree properties integer :: multiplicity = 0 integer :: internal = 0 integer :: n_off_shell = 0 integer :: n_resonances = 0 integer :: n_log_enhanced = 0 integer :: n_t_channel = 0 integer :: res_hash = 0 ! the sub-node tree integer :: depth = 0 integer(TC), dimension(:), allocatable :: tree integer, dimension(:), allocatable :: tree_pdg integer, dimension(:), allocatable :: tree_mapping logical, dimension(:), allocatable :: tree_resonant ! branch connections logical :: has_children = .false. type(cascade_t), pointer :: daughter1 => null () type(cascade_t), pointer :: daughter2 => null () type(cascade_t), pointer :: mother => null () ! next in list type(cascade_t), pointer :: next => null () contains <> end type cascade_t @ %def cascade_t <>= subroutine cascade_init (cascade, depth) type(cascade_t), intent(out) :: cascade integer, intent(in) :: depth integer, save :: index = 0 index = cascade_index () cascade%index = index cascade%depth = depth cascade%active = .true. allocate (cascade%tree (depth)) allocate (cascade%tree_pdg (depth)) allocate (cascade%tree_mapping (depth)) allocate (cascade%tree_resonant (depth)) end subroutine cascade_init @ %def cascade_init @ Keep and increment a global index <>= function cascade_index (seed) result (index) integer :: index integer, intent(in), optional :: seed integer, save :: i = 0 if (present (seed)) i = seed i = i + 1 index = i end function cascade_index @ %def cascade_index @ We need three versions of writing cascades. This goes to the phase-space file. For t/u channel mappings, we use the absolute value of the PDG code. <>= subroutine cascade_write_file_format (cascade, model, unit) type(cascade_t), intent(in) :: cascade class(model_data_t), intent(in), target :: model integer, intent(in), optional :: unit type(flavor_t) :: flv integer :: u, i 2 format(3x,A,1x,I3,1x,A,1x,I9,1x,'!',1x,A) u = given_output_unit (unit); if (u < 0) return call write_reduced (cascade%tree, u) write (u, "(A)") do i = 1, cascade%depth call flv%init (cascade%tree_pdg(i), model) select case (cascade%tree_mapping(i)) case (NO_MAPPING, EXTERNAL_PRT) case (S_CHANNEL) write(u,2) 'map', & cascade%tree(i), 's_channel', cascade%tree_pdg(i), & char (flv%get_name ()) case (T_CHANNEL) write(u,2) 'map', & cascade%tree(i), 't_channel', abs (cascade%tree_pdg(i)), & char (flv%get_name ()) case (U_CHANNEL) write(u,2) 'map', & cascade%tree(i), 'u_channel', abs (cascade%tree_pdg(i)), & char (flv%get_name ()) case (RADIATION) write(u,2) 'map', & cascade%tree(i), 'radiation', cascade%tree_pdg(i), & char (flv%get_name ()) case (COLLINEAR) write(u,2) 'map', & cascade%tree(i), 'collinear', cascade%tree_pdg(i), & char (flv%get_name ()) case (INFRARED) write(u,2) 'map', & cascade%tree(i), 'infrared ', cascade%tree_pdg(i), & char (flv%get_name ()) case (ON_SHELL) write(u,2) 'map', & cascade%tree(i), 'on_shell ', cascade%tree_pdg(i), & char (flv%get_name ()) case default call msg_bug (" Impossible mapping mode encountered") end select end do contains subroutine write_reduced (array, unit) integer(TC), dimension(:), intent(in) :: array integer, intent(in) :: unit integer :: i write (u, "(3x,A,1x)", advance="no") "tree" do i = 1, size (array) if (decay_level (array(i)) > 1) then write (u, "(1x,I0)", advance="no") array(i) end if end do end subroutine write_reduced elemental function decay_level (k) result (l) integer(TC), intent(in) :: k integer :: l integer :: i l = 0 do i = 0, bit_size(k) - 1 if (btest(k,i)) l = l + 1 end do end function decay_level subroutine start_comment (u) integer, intent(in) :: u write(u, '(1x,A)', advance='no') '!' end subroutine start_comment end subroutine cascade_write_file_format @ %def cascade_write_file_format @ This creates metapost source for graphical display: <>= subroutine cascade_write_graph_format (cascade, count, unit) type(cascade_t), intent(in) :: cascade integer, intent(in) :: count integer, intent(in), optional :: unit integer :: u integer(TC) :: mask type(string_t) :: left_str, right_str u = given_output_unit (unit); if (u < 0) return mask = 2**((cascade%depth+3)/2) - 1 left_str = "" right_str = "" write (u, '(A)') "\begin{minipage}{105pt}" write (u, '(A)') "\vspace{30pt}" write (u, '(A)') "\begin{center}" write (u, '(A)') "\begin{fmfgraph*}(55,55)" call graph_write (cascade, mask) write (u, '(A)') "\fmfleft{" // char (extract (left_str, 2)) // "}" write (u, '(A)') "\fmfright{" // char (extract (right_str, 2)) // "}" write (u, '(A)') "\end{fmfgraph*}\\" write (u, '(A,I5,A)') "\fbox{$", count, "$}" write (u, '(A)') "\end{center}" write (u, '(A)') "\end{minipage}" write (u, '(A)') "%" contains recursive subroutine graph_write (cascade, mask, reverse) type(cascade_t), intent(in) :: cascade integer(TC), intent(in) :: mask logical, intent(in), optional :: reverse type(flavor_t) :: anti logical :: rev rev = .false.; if (present(reverse)) rev = reverse if (cascade%has_children) then if (.not.rev) then call vertex_write (cascade, cascade%daughter1, mask) call vertex_write (cascade, cascade%daughter2, mask) else call vertex_write (cascade, cascade%daughter2, mask, .true.) call vertex_write (cascade, cascade%daughter1, mask, .true.) end if if (cascade%complete) then call vertex_write (cascade, cascade%mother, mask, .true.) write (u, '(A,I0,A)') "\fmfv{d.shape=square}{v0}" end if else if (cascade%incoming) then anti = cascade%flv%anti () call external_write (cascade%bincode, anti%get_tex_name (), & left_str) else call external_write (cascade%bincode, cascade%flv%get_tex_name (), & right_str) end if end if end subroutine graph_write recursive subroutine vertex_write (cascade, daughter, mask, reverse) type(cascade_t), intent(in) :: cascade, daughter integer(TC), intent(in) :: mask logical, intent(in), optional :: reverse integer :: bincode if (cascade%complete) then bincode = 0 else bincode = cascade%bincode end if call graph_write (daughter, mask, reverse) if (daughter%has_children) then call line_write (bincode, daughter%bincode, daughter%flv, & mapping=daughter%mapping) else call line_write (bincode, daughter%bincode, daughter%flv) end if end subroutine vertex_write subroutine line_write (i1, i2, flv, mapping) integer(TC), intent(in) :: i1, i2 type(flavor_t), intent(in) :: flv integer, intent(in), optional :: mapping integer :: k1, k2 type(string_t) :: prt_type select case (flv%get_spin_type ()) case (SCALAR); prt_type = "plain" case (SPINOR); prt_type = "fermion" case (VECTOR); prt_type = "boson" case (VECTORSPINOR); prt_type = "fermion" case (TENSOR); prt_type = "dbl_wiggly" case default; prt_type = "dashes" end select if (flv%is_antiparticle ()) then k1 = i2; k2 = i1 else k1 = i1; k2 = i2 end if if (present (mapping)) then select case (mapping) case (S_CHANNEL) write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & & ",f=blue,lab=\sm\blue$" // & & char (flv%get_tex_name ()) // "$}" // & & "{v", k1, ",v", k2, "}" case (T_CHANNEL, U_CHANNEL) write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & & ",f=cyan,lab=\sm\cyan$" // & & char (flv%get_tex_name ()) // "$}" // & & "{v", k1, ",v", k2, "}" case (RADIATION) write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & & ",f=green,lab=\sm\green$" // & & char (flv%get_tex_name ()) // "$}" // & & "{v", k1, ",v", k2, "}" case (COLLINEAR) write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & & ",f=magenta,lab=\sm\magenta$" // & & char (flv%get_tex_name ()) // "$}" // & & "{v", k1, ",v", k2, "}" case (INFRARED) write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & & ",f=red,lab=\sm\red$" // & & char (flv%get_tex_name ()) // "$}" // & & "{v", k1, ",v", k2, "}" case default write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & & ",f=black}" // & & "{v", k1, ",v", k2, "}" end select else write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & & "}" // & & "{v", k1, ",v", k2, "}" end if end subroutine line_write subroutine external_write (bincode, name, ext_str) integer(TC), intent(in) :: bincode type(string_t), intent(in) :: name type(string_t), intent(inout) :: ext_str character(len=20) :: str write (str, '(A2,I0)') ",v", bincode ext_str = ext_str // trim (str) write (u, '(A,I0,A,I0,A)') "\fmflabel{\sm$" & // char (name) & // "\,(", bincode, ")" & // "$}{v", bincode, "}" end subroutine external_write end subroutine cascade_write_graph_format @ %def cascade_write_graph_format @ This is for screen/debugging output: <>= subroutine cascade_write (cascade, unit) type(cascade_t), intent(in) :: cascade integer, intent(in), optional :: unit integer :: u character(9) :: depth u = given_output_unit (unit); if (u < 0) return write (u, "(A,(1x,I7))") 'Cascade #', cascade%index write (u, "(A,(1x,I7))") ' Grove: #', cascade%grove write (u, "(A,3(1x,L1))") ' act/cmp/inc: ', & cascade%active, cascade%complete, cascade%incoming write (u, "(A,I0)") ' Bincode: ', cascade%bincode write (u, "(A)", advance="no") ' Flavor: ' call cascade%flv%write (unit) write (u, "(A,I9)") ' Active flavor:', cascade%pdg write (u, "(A,L1)") ' Is vector: ', cascade%is_vector write (u, "(A,3(1x," // FMT_19 // "))") ' Mass (m/r/e): ', & cascade%m_min, cascade%m_rea, cascade%m_eff write (u, "(A,I1)") ' Mapping: ', cascade%mapping write (u, "(A,3(1x,L1))") ' res/log/tch: ', & cascade%resonant, cascade%log_enhanced, cascade%t_channel write (u, "(A,(1x,I7))") ' Multiplicity: ', cascade%multiplicity write (u, "(A,2(1x,I7))") ' n intern/off: ', & cascade%internal, cascade%n_off_shell write (u, "(A,3(1x,I7))") ' n res/log/tch:', & cascade%n_resonances, cascade%n_log_enhanced, cascade%n_t_channel write (u, "(A,I7)") ' Depth: ', cascade%depth write (depth, "(I7)") cascade%depth write (u, "(A," // depth // "(1x,I7))") & ' Tree: ', cascade%tree write (u, "(A," // depth // "(1x,I7))") & ' Tree(PDG): ', cascade%tree_pdg write (u, "(A," // depth // "(1x,I7))") & ' Tree(mapping):', cascade%tree_mapping write (u, "(A," // depth // "(1x,L1))") & ' Tree(res): ', cascade%tree_resonant if (cascade%has_children) then write (u, "(A,I7,1x,I7)") ' Daughter1/2: ', & cascade%daughter1%index, cascade%daughter2%index end if if (associated (cascade%mother)) then write (u, "(A,I7)") ' Mother: ', cascade%mother%index end if end subroutine cascade_write @ %def cascade_write @ \subsection{Creating new cascades} This initializes a single-particle cascade (external, final state). The PDG entry in the tree is set undefined because the cascade is not resonant. However, the flavor entry is set, so the cascade flavor is identified nevertheless. <>= subroutine cascade_init_outgoing (cascade, flv, pos, m_thr) type(cascade_t), intent(out) :: cascade type(flavor_t), intent(in) :: flv integer, intent(in) :: pos real(default), intent(in) :: m_thr call cascade_init (cascade, 1) cascade%bincode = ibset (0_TC, pos-1) cascade%flv = flv cascade%pdg = cascade%flv%get_pdg () cascade%is_vector = flv%get_spin_type () == VECTOR cascade%m_min = flv%get_mass () cascade%m_rea = cascade%m_min if (cascade%m_rea >= m_thr) then cascade%m_eff = cascade%m_rea end if cascade%on_shell = .true. cascade%multiplicity = 1 cascade%tree(1) = cascade%bincode cascade%tree_pdg(1) = cascade%pdg cascade%tree_mapping(1) = EXTERNAL_PRT cascade%tree_resonant(1) = .false. end subroutine cascade_init_outgoing @ %def cascade_init_outgoing @ The same for an incoming line: <>= subroutine cascade_init_incoming (cascade, flv, pos, m_thr) type(cascade_t), intent(out) :: cascade type(flavor_t), intent(in) :: flv integer, intent(in) :: pos real(default), intent(in) :: m_thr call cascade_init (cascade, 1) cascade%incoming = .true. cascade%bincode = ibset (0_TC, pos-1) cascade%flv = flv%anti () cascade%pdg = cascade%flv%get_pdg () cascade%is_vector = flv%get_spin_type () == VECTOR cascade%m_min = flv%get_mass () cascade%m_rea = cascade%m_min if (cascade%m_rea >= m_thr) then cascade%m_eff = cascade%m_rea end if cascade%on_shell = .true. cascade%n_t_channel = 0 cascade%n_off_shell = 0 cascade%tree(1) = cascade%bincode cascade%tree_pdg(1) = cascade%pdg cascade%tree_mapping(1) = EXTERNAL_PRT cascade%tree_resonant(1) = .false. end subroutine cascade_init_incoming @ %def cascade_init_outgoing @ \subsection{Tools} This function returns true if the two cascades share no common external particle. This is a requirement for joining them. <>= interface operator(.disjunct.) module procedure cascade_disjunct end interface <>= function cascade_disjunct (cascade1, cascade2) result (flag) logical :: flag type(cascade_t), intent(in) :: cascade1, cascade2 flag = iand (cascade1%bincode, cascade2%bincode) == 0 end function cascade_disjunct @ %def cascade_disjunct @ %def .disjunct. @ Compute a hash code for the resonance pattern of a cascade. We count the number of times each particle appears as a resonance. We pack the PDG codes of the resonances in two arrays (s-channel and t-channel), sort them both, concatenate the results, transfer to [[i8]] integers, and compute the hash code from this byte stream. For t/u-channel, we remove the sign for antiparticles since this is not well-defined. <>= subroutine cascade_assign_resonance_hash (cascade) type(cascade_t), intent(inout) :: cascade integer(i8), dimension(1) :: mold cascade%res_hash = hash (transfer & ([sort (pack (cascade%tree_pdg, & cascade%tree_resonant)), & sort (pack (abs (cascade%tree_pdg), & cascade%tree_mapping == T_CHANNEL .or. & cascade%tree_mapping == U_CHANNEL))], & mold)) end subroutine cascade_assign_resonance_hash @ %def cascade_assign_resonance_hash @ \subsection{Hash entries for cascades} We will set up a hash array which contains keys of and pointers to cascades. We hold a list of cascade (pointers) within each bucket. This is not for collision resolution, but for keeping similar, but unequal cascades together. <>= type :: cascade_p type(cascade_t), pointer :: cascade => null () type(cascade_p), pointer :: next => null () end type cascade_p @ %def cascade_p @ Here is the bucket or hash entry type: <>= type :: hash_entry_t integer(i32) :: hashval = 0 integer(i8), dimension(:), allocatable :: key type(cascade_p), pointer :: first => null () type(cascade_p), pointer :: last => null () end type hash_entry_t @ %def hash_entry_t <>= public :: hash_entry_init <>= subroutine hash_entry_init (entry, entry_in) type(hash_entry_t), intent(out) :: entry type(hash_entry_t), intent(in) :: entry_in type(cascade_p), pointer :: casc_iter, casc_copy entry%hashval = entry_in%hashval entry%key = entry_in%key casc_iter => entry_in%first do while (associated (casc_iter)) allocate (casc_copy) casc_copy = casc_iter casc_copy%next => null () if (associated (entry%first)) then entry%last%next => casc_copy else entry%first => casc_copy end if entry%last => casc_copy casc_iter => casc_iter%next end do end subroutine hash_entry_init @ %def hash_entry_init @ Finalize: just deallocate the list; the contents are just pointers. <>= subroutine hash_entry_final (hash_entry) type(hash_entry_t), intent(inout) :: hash_entry type(cascade_p), pointer :: current do while (associated (hash_entry%first)) current => hash_entry%first hash_entry%first => current%next deallocate (current) end do end subroutine hash_entry_final @ %def hash_entry_final @ Output: concise format for debugging, just list cascade indices. <>= subroutine hash_entry_write (hash_entry, unit) type(hash_entry_t), intent(in) :: hash_entry integer, intent(in), optional :: unit type(cascade_p), pointer :: current integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)", advance="no") "Entry:" do i = 1, size (hash_entry%key) write (u, "(1x,I0)", advance="no") hash_entry%key(i) end do write (u, "(1x,A)", advance="no") "->" current => hash_entry%first do while (associated (current)) write (u, "(1x,I7)", advance="no") current%cascade%index current => current%next end do write (u, *) end subroutine hash_entry_write @ %def hash_entry_write @ This function adds a cascade pointer to the bucket. If [[ok]] is present, check first if it is already there and return failure if yes. If [[cascade_ptr]] is also present, set it to the current cascade if successful. If not, set it to the cascade that is already there. <>= subroutine hash_entry_add_cascade_ptr (hash_entry, cascade, ok, cascade_ptr) type(hash_entry_t), intent(inout) :: hash_entry type(cascade_t), intent(in), target :: cascade logical, intent(out), optional :: ok type(cascade_t), optional, pointer :: cascade_ptr type(cascade_p), pointer :: current if (present (ok)) then call hash_entry_check_cascade (hash_entry, cascade, ok, cascade_ptr) if (.not. ok) return end if allocate (current) current%cascade => cascade if (associated (hash_entry%last)) then hash_entry%last%next => current else hash_entry%first => current end if hash_entry%last => current end subroutine hash_entry_add_cascade_ptr @ %def hash_entry_add_cascade_ptr @ This function checks whether a cascade is already in the bucket. For incomplete cascades, we look for an exact match. It should suffice to verify the tree, the PDG codes, and the mapping modes. This is the information that is written to the phase space file. For complete cascades, we ignore the PDG code at positions with mappings infrared, collinear, or t/u-channel. Thus a cascade which is distinguished only by PDG code at such places, is flagged existent. If the convention is followed that light particles come before heavier ones (in the model definition), this ensures that the lightest particle is kept in the appropriate place, corresponding to the strongest peak. For external cascades (incoming/outgoing) we take the PDG code into account even though it is zeroed in the PDG-code tree. <>= subroutine hash_entry_check_cascade (hash_entry, cascade, ok, cascade_ptr) type(hash_entry_t), intent(in), target :: hash_entry type(cascade_t), intent(in), target :: cascade logical, intent(out) :: ok type(cascade_t), optional, pointer :: cascade_ptr type(cascade_p), pointer :: current integer, dimension(:), allocatable :: tree_pdg ok = .true. allocate (tree_pdg (size (cascade%tree_pdg))) if (cascade%complete) then where (cascade%tree_mapping == INFRARED .or. & cascade%tree_mapping == COLLINEAR .or. & cascade%tree_mapping == T_CHANNEL .or. & cascade%tree_mapping == U_CHANNEL) tree_pdg = 0 elsewhere tree_pdg = cascade%tree_pdg end where else tree_pdg = cascade%tree_pdg end if current => hash_entry%first do while (associated (current)) if (current%cascade%depth == cascade%depth) then if (all (current%cascade%tree == cascade%tree)) then if (all (current%cascade%tree_mapping == cascade%tree_mapping)) & then if (all (current%cascade%tree_pdg .match. tree_pdg)) then if (present (cascade_ptr)) cascade_ptr => current%cascade ok = .false.; return end if end if end if end if current => current%next end do if (present (cascade_ptr)) cascade_ptr => cascade end subroutine hash_entry_check_cascade @ %def hash_entry_check_cascade @ For PDG codes, we specify that the undefined code matches any code. This is already defined for flavor objects, but here we need it for the codes themselves. <>= interface operator(.match.) module procedure pdg_match end interface <>= elemental function pdg_match (pdg1, pdg2) result (flag) logical :: flag integer(TC), intent(in) :: pdg1, pdg2 select case (pdg1) case (0) flag = .true. case default select case (pdg2) case (0) flag = .true. case default flag = pdg1 == pdg2 end select end select end function pdg_match @ %def .match. @ \subsection{The cascade set} The cascade set will later be transformed into the decay forest. It is set up as a linked list. In addition to the usual [[first]] and [[last]] pointers, there is a [[first_t]] pointer which points to the first t-channel cascade (after all s-channel cascades), and a [[first_k]] pointer which points to the first final cascade (with a keystone). As an auxiliary device, the object contains a hash array with associated parameters where an additional pointer is stored for each cascade. The keys are made from the relevant cascade data. This hash is used for fast detection (and thus avoidance) of double entries in the cascade list. <>= public :: cascade_set_t <>= type :: cascade_set_t private class(model_data_t), pointer :: model integer :: n_in, n_out, n_tot type(flavor_t), dimension(:,:), allocatable :: flv integer :: depth_out, depth_tot real(default) :: sqrts = 0 real(default) :: m_threshold_s = 0 real(default) :: m_threshold_t = 0 integer :: off_shell = 0 integer :: t_channel = 0 logical :: keep_nonresonant integer :: n_groves = 0 ! The cascade list type(cascade_t), pointer :: first => null () type(cascade_t), pointer :: last => null () type(cascade_t), pointer :: first_t => null () type(cascade_t), pointer :: first_k => null () ! The hashtable integer :: n_entries = 0 real :: fill_ratio = 0 integer :: n_entries_max = 0 integer(i32) :: mask = 0 logical :: fatal_beam_decay = .true. type(hash_entry_t), dimension(:), allocatable :: entry end type cascade_set_t @ %def cascade_set_t @ <>= interface cascade_set_init module procedure cascade_set_init_base module procedure cascade_set_init_from_cascade end interface @ %def cascade_set_init @ This might be broken. Test before using. <>= subroutine cascade_set_init_from_cascade (cascade_set, cascade_set_in) type(cascade_set_t), intent(out) :: cascade_set type(cascade_set_t), intent(in), target :: cascade_set_in type(cascade_t), pointer :: casc_iter, casc_copy cascade_set%model => cascade_set_in%model cascade_set%n_in = cascade_set_in%n_in cascade_set%n_out = cascade_set_in%n_out cascade_set%n_tot = cascade_set_in%n_tot cascade_set%flv = cascade_set_in%flv cascade_set%depth_out = cascade_set_in%depth_out cascade_set%depth_tot = cascade_set_in%depth_tot cascade_set%sqrts = cascade_set_in%sqrts cascade_set%m_threshold_s = cascade_set_in%m_threshold_s cascade_set%m_threshold_t = cascade_set_in%m_threshold_t cascade_set%off_shell = cascade_set_in%off_shell cascade_set%t_channel = cascade_set_in%t_channel cascade_set%keep_nonresonant = cascade_set_in%keep_nonresonant cascade_set%n_groves = cascade_set_in%n_groves casc_iter => cascade_set_in%first do while (associated (casc_iter)) allocate (casc_copy) casc_copy = casc_iter casc_copy%next => null () if (associated (cascade_set%first)) then cascade_set%last%next => casc_copy else cascade_set%first => casc_copy end if cascade_set%last => casc_copy casc_iter => casc_iter%next end do cascade_set%n_entries = cascade_set_in%n_entries cascade_set%fill_ratio = cascade_set_in%fill_ratio cascade_set%n_entries_max = cascade_set_in%n_entries_max cascade_set%mask = cascade_set_in%mask cascade_set%fatal_beam_decay = cascade_set_in%fatal_beam_decay allocate (cascade_set%entry (0:cascade_set%mask)) cascade_set%entry = cascade_set_in%entry end subroutine cascade_set_init_from_cascade @ %def cascade_set_init_from_cascade @ Return true if there are cascades which are active and complete, so the phase space file would be nonempty. <>= public :: cascade_set_is_valid <>= function cascade_set_is_valid (cascade_set) result (flag) logical :: flag type(cascade_set_t), intent(in) :: cascade_set type(cascade_t), pointer :: cascade flag = .false. cascade => cascade_set%first_k do while (associated (cascade)) if (cascade%active .and. cascade%complete) then flag = .true. return end if cascade => cascade%next end do end function cascade_set_is_valid @ %def cascade_set_is_valid @ The initializer sets up the hash table with some initial size guessed by looking at the number of external particles. We choose 256 for 3 external particles and a factor of 4 for each additional particle, limited at $2^{30}$=1G. Note: the explicit initialization loop might be avoided (ELEMENTAL), but a bug in nagfor 5.3.2 prevents this. <>= real, parameter, public :: CASCADE_SET_FILL_RATIO = 0.1 <>= subroutine cascade_set_init_base (cascade_set, model, n_in, n_out, phs_par, & fatal_beam_decay, flv) type(cascade_set_t), intent(out) :: cascade_set class(model_data_t), intent(in), target :: model integer, intent(in) :: n_in, n_out type(phs_parameters_t), intent(in) :: phs_par logical, intent(in) :: fatal_beam_decay type(flavor_t), dimension(:,:), intent(in), optional :: flv integer :: size_guess integer :: i, j cascade_set%model => model cascade_set%n_in = n_in cascade_set%n_out = n_out cascade_set%n_tot = n_in + n_out if (present (flv)) then allocate (cascade_set%flv (size (flv, 1), size (flv, 2))) do i = 1, size (flv, 2) do j = 1, size (flv, 1) call cascade_set%flv(j,i)%init (flv(j,i)%get_pdg (), model) end do end do end if select case (n_in) case (1); cascade_set%depth_out = 2 * n_out - 3 case (2); cascade_set%depth_out = 2 * n_out - 1 end select cascade_set%depth_tot = 2 * cascade_set%n_tot - 3 cascade_set%sqrts = phs_par%sqrts cascade_set%m_threshold_s = phs_par%m_threshold_s cascade_set%m_threshold_t = phs_par%m_threshold_t cascade_set%off_shell = phs_par%off_shell cascade_set%t_channel = phs_par%t_channel cascade_set%keep_nonresonant = phs_par%keep_nonresonant cascade_set%fill_ratio = CASCADE_SET_FILL_RATIO size_guess = ishft (256, min (2 * (cascade_set%n_tot - 3), 22)) cascade_set%n_entries_max = size_guess * cascade_set%fill_ratio cascade_set%mask = size_guess - 1 allocate (cascade_set%entry (0:cascade_set%mask)) cascade_set%fatal_beam_decay = fatal_beam_decay end subroutine cascade_set_init_base @ %def cascade_set_init_base @ The finalizer has to delete both the hash and the list. <>= public :: cascade_set_final <>= subroutine cascade_set_final (cascade_set) type(cascade_set_t), intent(inout), target :: cascade_set type(cascade_t), pointer :: current integer :: i if (allocated (cascade_set%entry)) then do i = 0, cascade_set%mask call hash_entry_final (cascade_set%entry(i)) end do deallocate (cascade_set%entry) end if do while (associated (cascade_set%first)) current => cascade_set%first cascade_set%first => cascade_set%first%next deallocate (current) end do end subroutine cascade_set_final @ %def cascade_set_final @ Write the process in ASCII format, in columns that are headed by the corresponding bincode. <>= public :: cascade_set_write_process_bincode_format <>= subroutine cascade_set_write_process_bincode_format (cascade_set, unit) type(cascade_set_t), intent(in), target :: cascade_set integer, intent(in), optional :: unit integer, dimension(:), allocatable :: bincode, field_width integer :: n_in, n_out, n_tot, n_flv integer :: u, f, i, bc character(20) :: str type(string_t) :: fmt_head type(string_t), dimension(:), allocatable :: fmt_proc u = given_output_unit (unit); if (u < 0) return if (.not. allocated (cascade_set%flv)) return write (u, "('!',1x,A)") "List of subprocesses with particle bincodes:" n_in = cascade_set%n_in n_out = cascade_set%n_out n_tot = cascade_set%n_tot n_flv = size (cascade_set%flv, 2) allocate (bincode (n_tot), field_width (n_tot), fmt_proc (n_tot)) bc = 1 do i = 1, n_out bincode(n_in + i) = bc bc = 2 * bc end do do i = n_in, 1, -1 bincode(i) = bc bc = 2 * bc end do do i = 1, n_tot write (str, "(I0)") bincode(i) field_width(i) = len_trim (str) do f = 1, n_flv field_width(i) = max (field_width(i), & len (cascade_set%flv(i,f)%get_name ())) end do end do fmt_head = "('!'" do i = 1, n_tot fmt_head = fmt_head // ",1x," fmt_proc(i) = "(1x," write (str, "(I0)") field_width(i) fmt_head = fmt_head // "I" // trim(str) fmt_proc(i) = fmt_proc(i) // "A" // trim(str) if (i == n_in) then fmt_head = fmt_head // ",1x,' '" end if end do do i = 1, n_tot fmt_proc(i) = fmt_proc(i) // ")" end do fmt_head = fmt_head // ")" write (u, char (fmt_head)) bincode do f = 1, n_flv write (u, "('!')", advance="no") do i = 1, n_tot write (u, char (fmt_proc(i)), advance="no") & char (cascade_set%flv(i,f)%get_name ()) if (i == n_in) write (u, "(1x,'=>')", advance="no") end do write (u, *) end do write (u, char (fmt_head)) bincode end subroutine cascade_set_write_process_bincode_format @ %def cascade_set_write_process_tex_format @ Write the process as a \LaTeX\ expression. <>= subroutine cascade_set_write_process_tex_format (cascade_set, unit) type(cascade_set_t), intent(in), target :: cascade_set integer, intent(in), optional :: unit integer :: u, f, i u = given_output_unit (unit); if (u < 0) return if (.not. allocated (cascade_set%flv)) return write (u, "(A)") "\begin{align*}" do f = 1, size (cascade_set%flv, 2) do i = 1, cascade_set%n_in if (i > 1) write (u, "(A)", advance="no") "\quad " write (u, "(A)", advance="no") & char (cascade_set%flv(i,f)%get_tex_name ()) end do write (u, "(A)", advance="no") "\quad &\to\quad " do i = cascade_set%n_in + 1, cascade_set%n_tot if (i > cascade_set%n_in + 1) write (u, "(A)", advance="no") "\quad " write (u, "(A)", advance="no") & char (cascade_set%flv(i,f)%get_tex_name ()) end do if (f < size (cascade_set%flv, 2)) then write (u, "(A)") "\\" else write (u, "(A)") "" end if end do write (u, "(A)") "\end{align*}" end subroutine cascade_set_write_process_tex_format @ %def cascade_set_write_process_tex_format @ Three output routines: phase-space file, graph source code, and screen output. This version generates the phase space file. It deals only with complete cascades. <>= public :: cascade_set_write_file_format <>= subroutine cascade_set_write_file_format (cascade_set, unit) type(cascade_set_t), intent(in), target :: cascade_set integer, intent(in), optional :: unit type(cascade_t), pointer :: cascade integer :: u, grove, count logical :: first_in_grove u = given_output_unit (unit); if (u < 0) return count = 0 do grove = 1, cascade_set%n_groves first_in_grove = .true. cascade => cascade_set%first_k do while (associated (cascade)) if (cascade%active .and. cascade%complete) then if (cascade%grove == grove) then if (first_in_grove) then first_in_grove = .false. write (u, "(A)") write (u, "(1x,'!',1x,A,1x,I0,A)", advance='no') & 'Multiplicity =', cascade%multiplicity, "," select case (cascade%n_resonances) case (0) write (u, '(1x,A)', advance='no') 'no resonances, ' case (1) write (u, '(1x,A)', advance='no') '1 resonance, ' case default write (u, '(1x,I0,1x,A)', advance='no') & cascade%n_resonances, 'resonances, ' end select write (u, '(1x,I0,1x,A)', advance='no') & cascade%n_log_enhanced, 'logs, ' write (u, '(1x,I0,1x,A)', advance='no') & cascade%n_off_shell, 'off-shell, ' select case (cascade%n_t_channel) case (0); write (u, '(1x,A)') 's-channel graph' case (1); write (u, '(1x,A)') '1 t-channel line' case default write(u,'(1x,I0,1x,A)') & cascade%n_t_channel, 't-channel lines' end select write (u, '(1x,A,I0)') 'grove #', grove end if count = count + 1 write (u, "(1x,'!',1x,A,I0)") "Channel #", count call cascade_write_file_format (cascade, cascade_set%model, u) end if end if cascade => cascade%next end do end do end subroutine cascade_set_write_file_format @ %def cascade_set_write_file_format @ This is the graph output format, the driver-file <>= public :: cascade_set_write_graph_format <>= subroutine cascade_set_write_graph_format & (cascade_set, filename, process_id, unit) type(cascade_set_t), intent(in), target :: cascade_set type(string_t), intent(in) :: filename, process_id integer, intent(in), optional :: unit type(cascade_t), pointer :: cascade integer :: u, grove, count, pgcount logical :: first_in_grove u = given_output_unit (unit); if (u < 0) return write (u, '(A)') "\documentclass[10pt]{article}" write (u, '(A)') "\usepackage{amsmath}" write (u, '(A)') "\usepackage{feynmp}" write (u, '(A)') "\usepackage{url}" write (u, '(A)') "\usepackage{color}" write (u, *) write (u, '(A)') "\textwidth 18.5cm" write (u, '(A)') "\evensidemargin -1.5cm" write (u, '(A)') "\oddsidemargin -1.5cm" write (u, *) write (u, '(A)') "\newcommand{\blue}{\color{blue}}" write (u, '(A)') "\newcommand{\green}{\color{green}}" write (u, '(A)') "\newcommand{\red}{\color{red}}" write (u, '(A)') "\newcommand{\magenta}{\color{magenta}}" write (u, '(A)') "\newcommand{\cyan}{\color{cyan}}" write (u, '(A)') "\newcommand{\sm}{\footnotesize}" write (u, '(A)') "\setlength{\parindent}{0pt}" write (u, '(A)') "\setlength{\parsep}{20pt}" write (u, *) write (u, '(A)') "\begin{document}" write (u, '(A)') "\begin{fmffile}{" // char (filename) // "}" write (u, '(A)') "\fmfcmd{color magenta; magenta = red + blue;}" write (u, '(A)') "\fmfcmd{color cyan; cyan = green + blue;}" write (u, '(A)') "\begin{fmfshrink}{0.5}" write (u, '(A)') "\begin{flushleft}" write (u, *) write (u, '(A)') "\noindent" // & & "\textbf{\large\texttt{WHIZARD} phase space channels}" // & & "\hfill\today" write (u, *) write (u, '(A)') "\vspace{10pt}" write (u, '(A)') "\noindent" // & & "\textbf{Process:} \url{" // char (process_id) // "}" call cascade_set_write_process_tex_format (cascade_set, u) write (u, *) write (u, '(A)') "\noindent" // & & "\textbf{Note:} These are pseudo Feynman graphs that " write (u, '(A)') "visualize phase-space parameterizations " // & & "(``integration channels''). " write (u, '(A)') "They do \emph{not} indicate Feynman graphs used for the " // & & "matrix element." write (u, *) write (u, '(A)') "\textbf{Color code:} " // & & "{\blue resonance,} " // & & "{\cyan t-channel,} " // & & "{\green radiation,} " write (u, '(A)') "{\red infrared,} " // & & "{\magenta collinear,} " // & & "external/off-shell" write (u, *) write (u, '(A)') "\noindent" // & & "\textbf{Black square:} Keystone, indicates ordering of " // & & "phase space parameters." write (u, *) write (u, '(A)') "\vspace{-20pt}" count = 0 pgcount = 0 do grove = 1, cascade_set%n_groves first_in_grove = .true. cascade => cascade_set%first do while (associated (cascade)) if (cascade%active .and. cascade%complete) then if (cascade%grove == grove) then if (first_in_grove) then first_in_grove = .false. write (u, *) write (u, '(A)') "\vspace{20pt}" write (u, '(A)') "\begin{tabular}{l}" write (u, '(A,I5,A)') & & "\fbox{\bf Grove \boldmath$", grove, "$} \\[10pt]" write (u, '(A,I1,A)') "Multiplicity: ", & cascade%multiplicity, "\\" write (u, '(A,I1,A)') "Resonances: ", & cascade%n_resonances, "\\" write (u, '(A,I1,A)') "Log-enhanced: ", & cascade%n_log_enhanced, "\\" write (u, '(A,I1,A)') "Off-shell: ", & cascade%n_off_shell, "\\" write (u, '(A,I1,A)') "t-channel: ", & cascade%n_t_channel, "" write (u, '(A)') "\end{tabular}" end if count = count + 1 call cascade_write_graph_format (cascade, count, unit) if (pgcount >= 250) then write (u, '(A)') "\clearpage" pgcount = 0 end if end if end if cascade => cascade%next end do end do write (u, '(A)') "\end{flushleft}" write (u, '(A)') "\end{fmfshrink}" write (u, '(A)') "\end{fmffile}" write (u, '(A)') "\end{document}" end subroutine cascade_set_write_graph_format @ %def cascade_set_write_graph_format @ This is for screen output and debugging: <>= public :: cascade_set_write <>= subroutine cascade_set_write (cascade_set, unit, active_only, complete_only) type(cascade_set_t), intent(in), target :: cascade_set integer, intent(in), optional :: unit logical, intent(in), optional :: active_only, complete_only logical :: active, complete type(cascade_t), pointer :: cascade integer :: u, i u = given_output_unit (unit); if (u < 0) return active = .true.; if (present (active_only)) active = active_only complete = .false.; if (present (complete_only)) complete = complete_only write (u, "(A)") "Cascade set:" write (u, "(3x,A)", advance="no") "Model:" if (associated (cascade_set%model)) then write (u, "(1x,A)") char (cascade_set%model%get_name ()) else write (u, "(1x,A)") "[none]" end if write (u, "(3x,A)", advance="no") "n_in/out/tot =" write (u, "(3(1x,I7))") & cascade_set%n_in, cascade_set%n_out, cascade_set%n_tot write (u, "(3x,A)", advance="no") "depth_out/tot =" write (u, "(2(1x,I7))") cascade_set%depth_out, cascade_set%depth_tot write (u, "(3x,A)", advance="no") "mass thr(s/t) =" write (u, "(2(1x," // FMT_19 // "))") & cascade_set%m_threshold_s, cascade_set%m_threshold_t write (u, "(3x,A)", advance="no") "off shell =" write (u, "(1x,I7)") cascade_set%off_shell write (u, "(3x,A)", advance="no") "keep_nonreson =" write (u, "(1x,L1)") cascade_set%keep_nonresonant write (u, "(3x,A)", advance="no") "n_groves =" write (u, "(1x,I7)") cascade_set%n_groves write (u, "(A)") write (u, "(A)") "Cascade list:" if (associated (cascade_set%first)) then cascade => cascade_set%first do while (associated (cascade)) if (active .and. .not. cascade%active) cycle if (complete .and. .not. cascade%complete) cycle call cascade_write (cascade, unit) cascade => cascade%next end do else write (u, "(A)") "[empty]" end if write (u, "(A)") "Hash array" write (u, "(3x,A)", advance="no") "n_entries =" write (u, "(1x,I7)") cascade_set%n_entries write (u, "(3x,A)", advance="no") "fill_ratio =" write (u, "(1x," // FMT_12 // ")") cascade_set%fill_ratio write (u, "(3x,A)", advance="no") "n_entries_max =" write (u, "(1x,I7)") cascade_set%n_entries_max write (u, "(3x,A)", advance="no") "mask =" write (u, "(1x,I0)") cascade_set%mask do i = 0, ubound (cascade_set%entry, 1) if (allocated (cascade_set%entry(i)%key)) then write (u, "(1x,I7)") i call hash_entry_write (cascade_set%entry(i), u) end if end do end subroutine cascade_set_write @ %def cascade_set_write @ \subsection{Adding cascades} Add a deep copy of a cascade to the set. The copy has all content of the original, but the pointers are nullified. We do not care whether insertion was successful or not. The pointer argument, if present, is assigned to the input cascade, or to the hash entry if it is already present. The procedure is recursive: any daughter or mother entries are also deep-copied and added to the cascade set before the current copy is added. <>= recursive subroutine cascade_set_add_copy & (cascade_set, cascade_in, cascade_ptr) type(cascade_set_t), intent(inout), target :: cascade_set type(cascade_t), intent(in) :: cascade_in type(cascade_t), optional, pointer :: cascade_ptr type(cascade_t), pointer :: cascade logical :: ok allocate (cascade) cascade = cascade_in if (associated (cascade_in%daughter1)) call cascade_set_add_copy & (cascade_set, cascade_in%daughter1, cascade%daughter1) if (associated (cascade_in%daughter2)) call cascade_set_add_copy & (cascade_set, cascade_in%daughter2, cascade%daughter2) if (associated (cascade_in%mother)) call cascade_set_add_copy & (cascade_set, cascade_in%mother, cascade%mother) cascade%next => null () call cascade_set_add (cascade_set, cascade, ok, cascade_ptr) if (.not. ok) deallocate (cascade) end subroutine cascade_set_add_copy @ %def cascade_set_add_copy @ Add a cascade to the set. This does not deep-copy. We first try to insert it in the hash array. If successful, add it to the list. Failure indicates that it is already present, and we drop it. The hash key is built solely from the tree array, so neither particle codes nor resonances count, just topology. Technically, hash and list receive only pointers, so the cascade can be considered as being in either of both. We treat it as part of the list. <>= subroutine cascade_set_add (cascade_set, cascade, ok, cascade_ptr) type(cascade_set_t), intent(inout), target :: cascade_set type(cascade_t), intent(in), target :: cascade logical, intent(out) :: ok type(cascade_t), optional, pointer :: cascade_ptr integer(i8), dimension(1) :: mold call cascade_set_hash_insert & (cascade_set, transfer (cascade%tree, mold), cascade, ok, cascade_ptr) if (ok) call cascade_set_list_add (cascade_set, cascade) end subroutine cascade_set_add @ %def cascade_set_add @ Add a new cascade to the list: <>= subroutine cascade_set_list_add (cascade_set, cascade) type(cascade_set_t), intent(inout) :: cascade_set type(cascade_t), intent(in), target :: cascade if (associated (cascade_set%last)) then cascade_set%last%next => cascade else cascade_set%first => cascade end if cascade_set%last => cascade end subroutine cascade_set_list_add @ %def cascade_set_list_add @ Add a cascade entry to the hash array: <>= subroutine cascade_set_hash_insert & (cascade_set, key, cascade, ok, cascade_ptr) type(cascade_set_t), intent(inout), target :: cascade_set integer(i8), dimension(:), intent(in) :: key type(cascade_t), intent(in), target :: cascade logical, intent(out) :: ok type(cascade_t), optional, pointer :: cascade_ptr integer(i32) :: h if (cascade_set%n_entries >= cascade_set%n_entries_max) & call cascade_set_hash_expand (cascade_set) h = hash (key) call cascade_set_hash_insert_rec & (cascade_set, h, h, key, cascade, ok, cascade_ptr) end subroutine cascade_set_hash_insert @ %def cascade_set_hash_insert @ Double the hashtable size when necesssary: <>= subroutine cascade_set_hash_expand (cascade_set) type(cascade_set_t), intent(inout), target :: cascade_set type(hash_entry_t), dimension(:), allocatable, target :: table_tmp type(cascade_p), pointer :: current integer :: i, s allocate (table_tmp (0:cascade_set%mask)) table_tmp = cascade_set%entry deallocate (cascade_set%entry) s = 2 * size (table_tmp) cascade_set%n_entries = 0 cascade_set%n_entries_max = s * cascade_set%fill_ratio cascade_set%mask = s - 1 allocate (cascade_set%entry (0:cascade_set%mask)) do i = 0, ubound (table_tmp, 1) current => table_tmp(i)%first do while (associated (current)) call cascade_set_hash_insert_rec & (cascade_set, table_tmp(i)%hashval, table_tmp(i)%hashval, & table_tmp(i)%key, current%cascade) current => current%next end do end do end subroutine cascade_set_hash_expand @ %def cascade_set_hash_expand @ Insert the cascade at the bucket determined by the hash value. If the bucket is filled, check first for a collision (unequal keys). In that case, choose the following bucket and repeat. Otherwise, add the cascade to the bucket. If the bucket is empty, record the hash value, allocate and store the key, and then add the cascade to the bucket. If [[ok]] is present, before insertion we check whether the cascade is already stored, and return failure if yes. <>= recursive subroutine cascade_set_hash_insert_rec & (cascade_set, h, hashval, key, cascade, ok, cascade_ptr) type(cascade_set_t), intent(inout) :: cascade_set integer(i32), intent(in) :: h, hashval integer(i8), dimension(:), intent(in) :: key type(cascade_t), intent(in), target :: cascade logical, intent(out), optional :: ok type(cascade_t), optional, pointer :: cascade_ptr integer(i32) :: i i = iand (h, cascade_set%mask) if (allocated (cascade_set%entry(i)%key)) then if (size (cascade_set%entry(i)%key) /= size (key)) then call cascade_set_hash_insert_rec & (cascade_set, h + 1, hashval, key, cascade, ok, cascade_ptr) else if (any (cascade_set%entry(i)%key /= key)) then call cascade_set_hash_insert_rec & (cascade_set, h + 1, hashval, key, cascade, ok, cascade_ptr) else call hash_entry_add_cascade_ptr & (cascade_set%entry(i), cascade, ok, cascade_ptr) end if else cascade_set%entry(i)%hashval = hashval allocate (cascade_set%entry(i)%key (size (key))) cascade_set%entry(i)%key = key call hash_entry_add_cascade_ptr & (cascade_set%entry(i), cascade, ok, cascade_ptr) cascade_set%n_entries = cascade_set%n_entries + 1 end if end subroutine cascade_set_hash_insert_rec @ %def cascade_set_hash_insert_rec @ \subsection{External particles} We want to initialize the cascade set with the outgoing particles. In case of multiple processes, initial cascades are prepared for all of them. The hash array check ensures that no particle appears more than once at the same place. <>= interface cascade_set_add_outgoing module procedure cascade_set_add_outgoing1 module procedure cascade_set_add_outgoing2 end interface <>= subroutine cascade_set_add_outgoing2 (cascade_set, flv) type(cascade_set_t), intent(inout), target :: cascade_set type(flavor_t), dimension(:,:), intent(in) :: flv integer :: pos, prc, n_out, n_prc type(cascade_t), pointer :: cascade logical :: ok n_out = size (flv, dim=1) n_prc = size (flv, dim=2) do prc = 1, n_prc do pos = 1, n_out allocate (cascade) call cascade_init_outgoing & (cascade, flv(pos,prc), pos, cascade_set%m_threshold_s) call cascade_set_add (cascade_set, cascade, ok) if (.not. ok) then deallocate (cascade) end if end do end do end subroutine cascade_set_add_outgoing2 subroutine cascade_set_add_outgoing1 (cascade_set, flv) type(cascade_set_t), intent(inout), target :: cascade_set type(flavor_t), dimension(:), intent(in) :: flv integer :: pos, n_out type(cascade_t), pointer :: cascade logical :: ok n_out = size (flv, dim=1) do pos = 1, n_out allocate (cascade) call cascade_init_outgoing & (cascade, flv(pos), pos, cascade_set%m_threshold_s) call cascade_set_add (cascade_set, cascade, ok) if (.not. ok) then deallocate (cascade) end if end do end subroutine cascade_set_add_outgoing1 @ %def cascade_set_add_outgoing @ The incoming particles are added one at a time. Nevertheless, we may have several processes which are looped over. At the first opportunity, we set the pointer [[first_t]] in the cascade set which should point to the first t-channel cascade. Return the indices of the first and last cascade generated. <>= interface cascade_set_add_incoming module procedure cascade_set_add_incoming0 module procedure cascade_set_add_incoming1 end interface <>= subroutine cascade_set_add_incoming1 (cascade_set, n1, n2, pos, flv) type(cascade_set_t), intent(inout), target :: cascade_set integer, intent(out) :: n1, n2 integer, intent(in) :: pos type(flavor_t), dimension(:), intent(in) :: flv integer :: prc, n_prc type(cascade_t), pointer :: cascade logical :: ok n1 = 0 n2 = 0 n_prc = size (flv) do prc = 1, n_prc allocate (cascade) call cascade_init_incoming & (cascade, flv(prc), pos, cascade_set%m_threshold_t) call cascade_set_add (cascade_set, cascade, ok) if (ok) then if (n1 == 0) n1 = cascade%index n2 = cascade%index if (.not. associated (cascade_set%first_t)) then cascade_set%first_t => cascade end if else deallocate (cascade) end if end do end subroutine cascade_set_add_incoming1 subroutine cascade_set_add_incoming0 (cascade_set, n1, n2, pos, flv) type(cascade_set_t), intent(inout), target :: cascade_set integer, intent(out) :: n1, n2 integer, intent(in) :: pos type(flavor_t), intent(in) :: flv type(cascade_t), pointer :: cascade logical :: ok n1 = 0 n2 = 0 allocate (cascade) call cascade_init_incoming & (cascade, flv, pos, cascade_set%m_threshold_t) call cascade_set_add (cascade_set, cascade, ok) if (ok) then if (n1 == 0) n1 = cascade%index n2 = cascade%index if (.not. associated (cascade_set%first_t)) then cascade_set%first_t => cascade end if else deallocate (cascade) end if end subroutine cascade_set_add_incoming0 @ %def cascade_set_add_incoming @ \subsection{Cascade combination I: flavor assignment} We have two disjunct cascades, now use the vertex table to determine the possible flavors of the combination cascade. For each possibility, try to generate a new cascade. The total cascade depth has to be one less than the limit, because this is reached by setting the keystone. <>= subroutine cascade_match_pair (cascade_set, cascade1, cascade2, s_channel) type(cascade_set_t), intent(inout), target :: cascade_set type(cascade_t), intent(in), target :: cascade1, cascade2 logical, intent(in) :: s_channel integer, dimension(:), allocatable :: pdg3 integer :: i, depth_max type(flavor_t) :: flv if (s_channel) then depth_max = cascade_set%depth_out else depth_max = cascade_set%depth_tot end if if (cascade1%depth + cascade2%depth < depth_max) then call cascade_set%model%match_vertex ( & cascade1%flv%get_pdg (), & cascade2%flv%get_pdg (), & pdg3) do i = 1, size (pdg3) call flv%init (pdg3(i), cascade_set%model) if (s_channel) then call cascade_combine_s (cascade_set, cascade1, cascade2, flv) else call cascade_combine_t (cascade_set, cascade1, cascade2, flv) end if end do deallocate (pdg3) end if end subroutine cascade_match_pair @ %def cascade_match_pair @ The triplet version takes a third cascade, and we check whether this triplet has a matching vertex in the database. If yes, we make a keystone cascade. <>= subroutine cascade_match_triplet & (cascade_set, cascade1, cascade2, cascade3, s_channel) type(cascade_set_t), intent(inout), target :: cascade_set type(cascade_t), intent(in), target :: cascade1, cascade2, cascade3 logical, intent(in) :: s_channel integer :: depth_max depth_max = cascade_set%depth_tot if (cascade1%depth + cascade2%depth + cascade3%depth == depth_max) then if (cascade_set%model%check_vertex ( & cascade1%flv%get_pdg (), & cascade2%flv%get_pdg (), & cascade3%flv%get_pdg ())) then call cascade_combine_keystone & (cascade_set, cascade1, cascade2, cascade3, s_channel) end if end if end subroutine cascade_match_triplet @ %def cascade_match_triplet @ \subsection{Cascade combination II: kinematics setup and check} Having three matching flavors, we start constructing the combination cascade. We look at the mass hierarchies and determine whether the cascade is to be kept. In passing we set mapping modes, resonance properties and such. If successful, the cascade is finalized. For a resonant cascade, we prepare in addition a copy without the resonance. <>= subroutine cascade_combine_s (cascade_set, cascade1, cascade2, flv) type(cascade_set_t), intent(inout), target :: cascade_set type(cascade_t), intent(in), target :: cascade1, cascade2 type(flavor_t), intent(in) :: flv type(cascade_t), pointer :: cascade3, cascade4 logical :: keep keep = .false. allocate (cascade3) call cascade_init (cascade3, cascade1%depth + cascade2%depth + 1) cascade3%bincode = ior (cascade1%bincode, cascade2%bincode) cascade3%flv = flv%anti () cascade3%pdg = cascade3%flv%get_pdg () cascade3%is_vector = flv%get_spin_type () == VECTOR cascade3%m_min = cascade1%m_min + cascade2%m_min cascade3%m_rea = flv%get_mass () if (cascade3%m_rea > cascade_set%m_threshold_s) then cascade3%m_eff = cascade3%m_rea end if ! Potentially resonant cases [sqrts = m_rea for on-shell decay] if (cascade3%m_rea > cascade3%m_min & .and. cascade3%m_rea <= cascade_set%sqrts) then if (flv%get_width () /= 0) then if (cascade1%on_shell .or. cascade2%on_shell) then keep = .true. cascade3%mapping = S_CHANNEL cascade3%resonant = .true. end if else call warn_decay (flv) end if ! Collinear and IR singular cases else if (cascade3%m_rea < cascade_set%sqrts) then ! Massless splitting if (cascade1%m_eff == 0 .and. cascade2%m_eff == 0 & .and. cascade3%depth <= 3) then keep = .true. cascade3%log_enhanced = .true. if (cascade3%is_vector) then if (cascade1%is_vector .and. cascade2%is_vector) then cascade3%mapping = COLLINEAR ! three-vector-vertex else cascade3%mapping = INFRARED ! vector splitting into matter end if else if (cascade1%is_vector .or. cascade2%is_vector) then cascade3%mapping = COLLINEAR ! vector radiation off matter else cascade3%mapping = INFRARED ! scalar radiation/splitting end if end if ! IR radiation off massive particle else if (cascade3%m_eff > 0 .and. cascade1%m_eff > 0 & .and. cascade2%m_eff == 0 & .and. (cascade1%on_shell .or. cascade1%mapping == RADIATION) & .and. abs (cascade3%m_eff - cascade1%m_eff) & < cascade_set%m_threshold_s) & then keep = .true. cascade3%log_enhanced = .true. cascade3%mapping = RADIATION else if (cascade3%m_eff > 0 .and. cascade2%m_eff > 0 & .and. cascade1%m_eff == 0 & .and. (cascade2%on_shell .or. cascade2%mapping == RADIATION) & .and. abs (cascade3%m_eff - cascade2%m_eff) & < cascade_set%m_threshold_s) & then keep = .true. cascade3%log_enhanced = .true. cascade3%mapping = RADIATION end if end if ! Non-singular cases, including failed resonances if (.not. keep) then ! Two on-shell particles from a virtual mother if (cascade1%on_shell .or. cascade2%on_shell) then keep = .true. cascade3%m_eff = max (cascade3%m_min, & cascade1%m_eff + cascade2%m_eff) if (cascade3%m_eff < cascade_set%m_threshold_s) then cascade3%m_eff = 0 end if end if end if ! Complete and register the cascade (two in case of resonance) if (keep) then cascade3%on_shell = cascade3%resonant .or. cascade3%log_enhanced if (cascade3%resonant) then cascade3%pdg = cascade3%flv%get_pdg () if (cascade_set%keep_nonresonant) then allocate (cascade4) cascade4 = cascade3 cascade4%index = cascade_index () cascade4%pdg = UNDEFINED cascade4%mapping = NO_MAPPING cascade4%resonant = .false. cascade4%on_shell = .false. end if cascade3%m_min = cascade3%m_rea call cascade_fusion (cascade_set, cascade1, cascade2, cascade3) if (cascade_set%keep_nonresonant) then call cascade_fusion (cascade_set, cascade1, cascade2, cascade4) end if else call cascade_fusion (cascade_set, cascade1, cascade2, cascade3) end if else deallocate (cascade3) end if contains subroutine warn_decay (flv) type(flavor_t), intent(in) :: flv integer :: i integer, dimension(MAX_WARN_RESONANCE), save :: warned_code = 0 LOOP_WARNED: do i = 1, MAX_WARN_RESONANCE if (warned_code(i) == 0) then warned_code(i) = flv%get_pdg () write (msg_buffer, "(A)") & & " Intermediate decay of zero-width particle " & & // char (flv%get_name ()) & & // " may be possible." call msg_warning exit LOOP_WARNED else if (warned_code(i) == flv%get_pdg ()) then exit LOOP_WARNED end if end do LOOP_WARNED end subroutine warn_decay end subroutine cascade_combine_s @ %def cascade_combine_s <>= integer, parameter, public :: MAX_WARN_RESONANCE = 50 @ %def MAX_WARN_RESONANCE @ This is the t-channel version. [[cascade1]] is t-channel and contains the seed, [[cascade2]] is s-channel. We check for kinematically allowed beam decay (which is a fatal error), or massless splitting / soft radiation. The cascade is kept in all remaining cases and submitted for registration. <>= subroutine cascade_combine_t (cascade_set, cascade1, cascade2, flv) type(cascade_set_t), intent(inout), target :: cascade_set type(cascade_t), intent(in), target :: cascade1, cascade2 type(flavor_t), intent(in) :: flv type(cascade_t), pointer :: cascade3 allocate (cascade3) call cascade_init (cascade3, cascade1%depth + cascade2%depth + 1) cascade3%bincode = ior (cascade1%bincode, cascade2%bincode) cascade3%flv = flv%anti () cascade3%pdg = abs (cascade3%flv%get_pdg ()) cascade3%is_vector = flv%get_spin_type () == VECTOR if (cascade1%incoming) then cascade3%m_min = cascade2%m_min else cascade3%m_min = cascade1%m_min + cascade2%m_min end if cascade3%m_rea = flv%get_mass () if (cascade3%m_rea > cascade_set%m_threshold_t) then cascade3%m_eff = max (cascade3%m_rea, cascade2%m_eff) else if (cascade2%m_eff > cascade_set%m_threshold_t) then cascade3%m_eff = cascade2%m_eff else cascade3%m_eff = 0 end if ! Allowed decay of beam particle if (cascade1%incoming & .and. cascade1%m_rea > cascade2%m_rea + cascade3%m_rea) then call beam_decay (cascade_set%fatal_beam_decay) ! Massless splitting else if (cascade1%m_eff == 0 & .and. cascade2%m_eff < cascade_set%m_threshold_t & .and. cascade3%m_eff == 0) then cascade3%mapping = U_CHANNEL cascade3%log_enhanced = .true. ! IR radiation off massive particle else if (cascade1%m_eff /= 0 .and. cascade2%m_eff == 0 & .and. cascade3%m_eff /= 0 & .and. (cascade1%on_shell .or. cascade1%mapping == RADIATION) & .and. abs (cascade1%m_eff - cascade3%m_eff) & < cascade_set%m_threshold_t) & then cascade3%pdg = flv%get_pdg () cascade3%log_enhanced = .true. cascade3%mapping = RADIATION end if cascade3%t_channel = .true. call cascade_fusion (cascade_set, cascade1, cascade2, cascade3) contains subroutine beam_decay (fatal_beam_decay) logical, intent(in) :: fatal_beam_decay write (msg_buffer, "(1x,A,1x,'->',1x,A,1x,A)") & char (cascade1%flv%get_name ()), & char (cascade3%flv%get_name ()), & char (cascade2%flv%get_name ()) call msg_message write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") & char (cascade1%flv%get_name ()), cascade1%m_rea call msg_message write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") & char (cascade3%flv%get_name ()), cascade3%m_rea call msg_message write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") & char (cascade2%flv%get_name ()), cascade2%m_rea call msg_message if (fatal_beam_decay) then call msg_fatal (" Phase space: Initial beam particle can decay") else call msg_warning (" Phase space: Initial beam particle can decay") end if end subroutine beam_decay end subroutine cascade_combine_t @ %def cascade_combine_t @ Here we complete a decay cascade. The third input is the single-particle cascade for the initial particle. There is no resonance or mapping assignment. The only condition for keeping the cascade is the mass sum of the final state, which must be less than the available energy. Two modifications are necessary for scattering cascades: a pure s-channel diagram (cascade1 is the incoming particle) do not have a logarithmic mapping at top-level. And in a t-channel diagram, the last line exchanged is mapped t-channel, not u-channel. Finally, we can encounter the case of a $2\to 1$ process, where cascade1 is incoming, and cascade2 is the outgoing particle. In all three cases we register a new cascade with the modified mapping. <>= subroutine cascade_combine_keystone & (cascade_set, cascade1, cascade2, cascade3, s_channel) type(cascade_set_t), intent(inout), target :: cascade_set type(cascade_t), intent(in), target :: cascade1, cascade2, cascade3 logical, intent(in) :: s_channel type(cascade_t), pointer :: cascade4, cascade0 logical :: keep, ok keep = .false. allocate (cascade4) call cascade_init & (cascade4, cascade1%depth + cascade2%depth + cascade3%depth) cascade4%complete = .true. if (s_channel) then cascade4%bincode = ior (cascade1%bincode, cascade2%bincode) else cascade4%bincode = cascade3%bincode end if cascade4%flv = cascade3%flv cascade4%pdg = cascade3%pdg cascade4%mapping = EXTERNAL_PRT cascade4%is_vector = cascade3%is_vector cascade4%m_min = cascade1%m_min + cascade2%m_min cascade4%m_rea = cascade3%m_rea cascade4%m_eff = cascade3%m_rea if (cascade4%m_min < cascade_set%sqrts) then keep = .true. end if if (keep) then if (cascade1%incoming .and. cascade2%log_enhanced) then allocate (cascade0) cascade0 = cascade2 cascade0%next => null () cascade0%index = cascade_index () cascade0%mapping = NO_MAPPING cascade0%log_enhanced = .false. cascade0%n_log_enhanced = cascade0%n_log_enhanced - 1 cascade0%tree_mapping(cascade0%depth) = NO_MAPPING call cascade_keystone & (cascade_set, cascade1, cascade0, cascade3, cascade4, ok) if (ok) then call cascade_set_add (cascade_set, cascade0, ok) else deallocate (cascade0) end if else if (cascade1%t_channel .and. cascade1%mapping == U_CHANNEL) then allocate (cascade0) cascade0 = cascade1 cascade0%next => null () cascade0%index = cascade_index () cascade0%mapping = T_CHANNEL cascade0%tree_mapping(cascade0%depth) = T_CHANNEL call cascade_keystone & (cascade_set, cascade0, cascade2, cascade3, cascade4, ok) if (ok) then call cascade_set_add (cascade_set, cascade0, ok) else deallocate (cascade0) end if else if (cascade1%incoming .and. cascade2%depth == 1) then allocate (cascade0) cascade0 = cascade2 cascade0%next => null () cascade0%index = cascade_index () cascade0%mapping = ON_SHELL cascade0%tree_mapping(cascade0%depth) = ON_SHELL call cascade_keystone & (cascade_set, cascade1, cascade0, cascade3, cascade4, ok) if (ok) then call cascade_set_add (cascade_set, cascade0, ok) else deallocate (cascade0) end if else call cascade_keystone & (cascade_set, cascade1, cascade2, cascade3, cascade4, ok) end if else deallocate (cascade4) end if end subroutine cascade_combine_keystone @ %def cascade_combine_keystone @ \subsection{Cascade combination III: node connections and tree fusion} Here we assign global tree properties. If the allowed number of off-shell lines is exceeded, discard the new cascade. Otherwise, assign the trees, sort them, and assign connections. Finally, append the cascade to the list. This may fail (because in the hash array there is already an equivalent cascade). On failure, discard the cascade. <>= subroutine cascade_fusion (cascade_set, cascade1, cascade2, cascade3) type(cascade_set_t), intent(inout), target :: cascade_set type(cascade_t), intent(in), target :: cascade1, cascade2 type(cascade_t), pointer :: cascade3 integer :: i1, i2, i3, i4 logical :: ok cascade3%internal = (cascade3%depth - 3) / 2 if (cascade3%resonant) then cascade3%multiplicity = 1 cascade3%n_resonances = & cascade1%n_resonances + cascade2%n_resonances + 1 else cascade3%multiplicity = cascade1%multiplicity + cascade2%multiplicity cascade3%n_resonances = cascade1%n_resonances + cascade2%n_resonances end if if (cascade3%log_enhanced) then cascade3%n_log_enhanced = & cascade1%n_log_enhanced + cascade2%n_log_enhanced + 1 else cascade3%n_log_enhanced = & cascade1%n_log_enhanced + cascade2%n_log_enhanced end if if (cascade3%resonant) then cascade3%n_off_shell = 0 else if (cascade3%log_enhanced) then cascade3%n_off_shell = cascade1%n_off_shell + cascade2%n_off_shell else cascade3%n_off_shell = cascade1%n_off_shell + cascade2%n_off_shell + 1 end if if (cascade3%t_channel) then cascade3%n_t_channel = cascade1%n_t_channel + 1 end if if (cascade3%n_off_shell > cascade_set%off_shell) then deallocate (cascade3) else if (cascade3%n_t_channel > cascade_set%t_channel) then deallocate (cascade3) else i1 = cascade1%depth i2 = i1 + 1 i3 = i1 + cascade2%depth i4 = cascade3%depth cascade3%tree(:i1) = cascade1%tree where (cascade1%tree_mapping > NO_MAPPING) cascade3%tree_pdg(:i1) = cascade1%tree_pdg elsewhere cascade3%tree_pdg(:i1) = UNDEFINED end where cascade3%tree_mapping(:i1) = cascade1%tree_mapping cascade3%tree_resonant(:i1) = cascade1%tree_resonant cascade3%tree(i2:i3) = cascade2%tree where (cascade2%tree_mapping > NO_MAPPING) cascade3%tree_pdg(i2:i3) = cascade2%tree_pdg elsewhere cascade3%tree_pdg(i2:i3) = UNDEFINED end where cascade3%tree_mapping(i2:i3) = cascade2%tree_mapping cascade3%tree_resonant(i2:i3) = cascade2%tree_resonant cascade3%tree(i4) = cascade3%bincode cascade3%tree_pdg(i4) = cascade3%pdg cascade3%tree_mapping(i4) = cascade3%mapping cascade3%tree_resonant(i4) = cascade3%resonant call tree_sort (cascade3%tree, & cascade3%tree_pdg, cascade3%tree_mapping, cascade3%tree_resonant) cascade3%has_children = .true. cascade3%daughter1 => cascade1 cascade3%daughter2 => cascade2 call cascade_set_add (cascade_set, cascade3, ok) if (.not. ok) deallocate (cascade3) end if end subroutine cascade_fusion @ %def cascade_fusion @ Here we combine a cascade pair with an incoming particle, i.e., we set a keystone. Otherwise, this is similar. On the first opportunity, we set the [[first_k]] pointer in the cascade set. <>= subroutine cascade_keystone & (cascade_set, cascade1, cascade2, cascade3, cascade4, ok) type(cascade_set_t), intent(inout), target :: cascade_set type(cascade_t), intent(in), target :: cascade1, cascade2, cascade3 type(cascade_t), pointer :: cascade4 logical, intent(out) :: ok integer :: i1, i2, i3, i4 cascade4%internal = (cascade4%depth - 3) / 2 cascade4%multiplicity = cascade1%multiplicity + cascade2%multiplicity cascade4%n_resonances = cascade1%n_resonances + cascade2%n_resonances cascade4%n_off_shell = cascade1%n_off_shell + cascade2%n_off_shell cascade4%n_log_enhanced = & cascade1%n_log_enhanced + cascade2%n_log_enhanced cascade4%n_t_channel = cascade1%n_t_channel + cascade2%n_t_channel if (cascade4%n_off_shell > cascade_set%off_shell) then deallocate (cascade4) ok = .false. else if (cascade4%n_t_channel > cascade_set%t_channel) then deallocate (cascade4) ok = .false. else i1 = cascade1%depth i2 = i1 + 1 i3 = i1 + cascade2%depth i4 = cascade4%depth cascade4%tree(:i1) = cascade1%tree where (cascade1%tree_mapping > NO_MAPPING) cascade4%tree_pdg(:i1) = cascade1%tree_pdg elsewhere cascade4%tree_pdg(:i1) = UNDEFINED end where cascade4%tree_mapping(:i1) = cascade1%tree_mapping cascade4%tree_resonant(:i1) = cascade1%tree_resonant cascade4%tree(i2:i3) = cascade2%tree where (cascade2%tree_mapping > NO_MAPPING) cascade4%tree_pdg(i2:i3) = cascade2%tree_pdg elsewhere cascade4%tree_pdg(i2:i3) = UNDEFINED end where cascade4%tree_mapping(i2:i3) = cascade2%tree_mapping cascade4%tree_resonant(i2:i3) = cascade2%tree_resonant cascade4%tree(i4) = cascade4%bincode cascade4%tree_pdg(i4) = UNDEFINED cascade4%tree_mapping(i4) = cascade4%mapping cascade4%tree_resonant(i4) = .false. call tree_sort (cascade4%tree, & cascade4%tree_pdg, cascade4%tree_mapping, cascade4%tree_resonant) cascade4%has_children = .true. cascade4%daughter1 => cascade1 cascade4%daughter2 => cascade2 cascade4%mother => cascade3 call cascade_set_add (cascade_set, cascade4, ok) if (ok) then if (.not. associated (cascade_set%first_k)) then cascade_set%first_k => cascade4 end if else deallocate (cascade4) end if end if end subroutine cascade_keystone @ %def cascade_keystone @ Sort a tree (array of binary codes) and particle code array simultaneously, by ascending binary codes. A convenient method is to use the [[maxloc]] function iteratively, to find and remove the largest entry in the tree array one by one. <>= subroutine tree_sort (tree, pdg, mapping, resonant) integer(TC), dimension(:), intent(inout) :: tree integer, dimension(:), intent(inout) :: pdg, mapping logical, dimension(:), intent(inout) :: resonant integer(TC), dimension(size(tree)) :: tree_tmp integer, dimension(size(pdg)) :: pdg_tmp, mapping_tmp logical, dimension(size(resonant)) :: resonant_tmp integer, dimension(1) :: pos integer :: i tree_tmp = tree pdg_tmp = pdg mapping_tmp = mapping resonant_tmp = resonant do i = size(tree),1,-1 pos = maxloc (tree_tmp) tree(i) = tree_tmp (pos(1)) pdg(i) = pdg_tmp (pos(1)) mapping(i) = mapping_tmp (pos(1)) resonant(i) = resonant_tmp (pos(1)) tree_tmp(pos(1)) = 0 end do end subroutine tree_sort @ %def tree_sort @ \subsection{Cascade set generation} These procedures loop over cascades and build up the cascade set. After each iteration of the innermost loop, we set a breakpoint. s-channel: We use a nested scan to combine all cascades with all other cascades. <>= subroutine cascade_set_generate_s (cascade_set) type(cascade_set_t), intent(inout), target :: cascade_set type(cascade_t), pointer :: cascade1, cascade2 cascade1 => cascade_set%first LOOP1: do while (associated (cascade1)) cascade2 => cascade_set%first LOOP2: do while (associated (cascade2)) if (cascade2%index >= cascade1%index) exit LOOP2 if (cascade1 .disjunct. cascade2) then call cascade_match_pair (cascade_set, cascade1, cascade2, .true.) end if call terminate_now_if_signal () cascade2 => cascade2%next end do LOOP2 cascade1 => cascade1%next end do LOOP1 end subroutine cascade_set_generate_s @ %def cascade_set_generate_s @ The t-channel cascades are directed and have a seed (one of the incoming particles) and a target (the other one). We loop over all possible seeds and targets. Inside this, we loop over all t-channel cascades ([[cascade1]]) and s-channel cascades ([[cascade2]]) and try to combine them. <>= subroutine cascade_set_generate_t (cascade_set, pos_seed, pos_target) type(cascade_set_t), intent(inout), target :: cascade_set integer, intent(in) :: pos_seed, pos_target type(cascade_t), pointer :: cascade_seed, cascade_target type(cascade_t), pointer :: cascade1, cascade2 integer(TC) :: bc_seed, bc_target bc_seed = ibset (0_TC, pos_seed-1) bc_target = ibset (0_TC, pos_target-1) cascade_seed => cascade_set%first_t LOOP_SEED: do while (associated (cascade_seed)) if (cascade_seed%bincode == bc_seed) then cascade_target => cascade_set%first_t LOOP_TARGET: do while (associated (cascade_target)) if (cascade_target%bincode == bc_target) then cascade1 => cascade_set%first_t LOOP_T: do while (associated (cascade1)) if ((cascade1 .disjunct. cascade_target) & .and. .not. (cascade1 .disjunct. cascade_seed)) then cascade2 => cascade_set%first LOOP_S: do while (associated (cascade2)) if ((cascade2 .disjunct. cascade_target) & .and. (cascade2 .disjunct. cascade1)) then call cascade_match_pair & (cascade_set, cascade1, cascade2, .false.) end if call terminate_now_if_signal () cascade2 => cascade2%next end do LOOP_S end if call terminate_now_if_signal () cascade1 => cascade1%next end do LOOP_T end if call terminate_now_if_signal () cascade_target => cascade_target%next end do LOOP_TARGET end if call terminate_now_if_signal () cascade_seed => cascade_seed%next end do LOOP_SEED end subroutine cascade_set_generate_t @ %def cascade_set_generate_t @ This part completes the phase space for decay processes. It is similar to s-channel cascade generation, but combines two cascade with the particular cascade of the incoming particle. This particular cascade is expected to be pointed at by [[first_t]]. <>= subroutine cascade_set_generate_decay (cascade_set) type(cascade_set_t), intent(inout), target :: cascade_set type(cascade_t), pointer :: cascade1, cascade2 type(cascade_t), pointer :: cascade_in cascade_in => cascade_set%first_t cascade1 => cascade_set%first do while (associated (cascade1)) if (cascade1 .disjunct. cascade_in) then cascade2 => cascade1%next do while (associated (cascade2)) if ((cascade2 .disjunct. cascade1) & .and. (cascade2 .disjunct. cascade_in)) then call cascade_match_triplet (cascade_set, & cascade1, cascade2, cascade_in, .true.) end if call terminate_now_if_signal () cascade2 => cascade2%next end do end if call terminate_now_if_signal () cascade1 => cascade1%next end do end subroutine cascade_set_generate_decay @ %def cascade_set_generate_decay @ This part completes the phase space for scattering processes. We combine a t-channel cascade (containing the seed) with a s-channel cascade and the target. <>= subroutine cascade_set_generate_scattering & (cascade_set, ns1, ns2, nt1, nt2, pos_seed, pos_target) type(cascade_set_t), intent(inout), target :: cascade_set integer, intent(in) :: pos_seed, pos_target integer, intent(in) :: ns1, ns2, nt1, nt2 type(cascade_t), pointer :: cascade_seed, cascade_target type(cascade_t), pointer :: cascade1, cascade2 integer(TC) :: bc_seed, bc_target bc_seed = ibset (0_TC, pos_seed-1) bc_target = ibset (0_TC, pos_target-1) cascade_seed => cascade_set%first_t LOOP_SEED: do while (associated (cascade_seed)) if (cascade_seed%index < ns1) then cascade_seed => cascade_seed%next cycle LOOP_SEED else if (cascade_seed%index > ns2) then exit LOOP_SEED else if (cascade_seed%bincode == bc_seed) then cascade_target => cascade_set%first_t LOOP_TARGET: do while (associated (cascade_target)) if (cascade_target%index < nt1) then cascade_target => cascade_target%next cycle LOOP_TARGET else if (cascade_target%index > nt2) then exit LOOP_TARGET else if (cascade_target%bincode == bc_target) then cascade1 => cascade_set%first_t LOOP_T: do while (associated (cascade1)) if ((cascade1 .disjunct. cascade_target) & .and. .not. (cascade1 .disjunct. cascade_seed)) then cascade2 => cascade_set%first LOOP_S: do while (associated (cascade2)) if ((cascade2 .disjunct. cascade_target) & .and. (cascade2 .disjunct. cascade1)) then call cascade_match_triplet (cascade_set, & cascade1, cascade2, cascade_target, .false.) end if call terminate_now_if_signal () cascade2 => cascade2%next end do LOOP_S end if call terminate_now_if_signal () cascade1 => cascade1%next end do LOOP_T end if call terminate_now_if_signal () cascade_target => cascade_target%next end do LOOP_TARGET end if call terminate_now_if_signal () cascade_seed => cascade_seed%next end do LOOP_SEED end subroutine cascade_set_generate_scattering @ %def cascade_set_generate_scattering @ \subsection{Groves} Before assigning groves, assign hashcodes to the resonance patterns, so they can easily be compared. <>= subroutine cascade_set_assign_resonance_hash (cascade_set) type(cascade_set_t), intent(inout) :: cascade_set type(cascade_t), pointer :: cascade cascade => cascade_set%first_k do while (associated (cascade)) call cascade_assign_resonance_hash (cascade) cascade => cascade%next end do end subroutine cascade_set_assign_resonance_hash @ %def cascade_assign_resonance_hash @ After all cascades are recorded, we group the complete cascades in groves. A grove consists of cascades with identical multiplicity, number of resonances, log-enhanced, t-channel lines, and resonance flavors. <>= subroutine cascade_set_assign_groves (cascade_set) type(cascade_set_t), intent(inout), target :: cascade_set type(cascade_t), pointer :: cascade1, cascade2 integer :: multiplicity integer :: n_resonances, n_log_enhanced, n_t_channel, n_off_shell integer :: res_hash integer :: grove grove = 0 cascade1 => cascade_set%first_k do while (associated (cascade1)) if (cascade1%active .and. cascade1%complete & .and. cascade1%grove == 0) then grove = grove + 1 cascade1%grove = grove multiplicity = cascade1%multiplicity n_resonances = cascade1%n_resonances n_log_enhanced = cascade1%n_log_enhanced n_off_shell = cascade1%n_off_shell n_t_channel = cascade1%n_t_channel res_hash = cascade1%res_hash cascade2 => cascade1%next do while (associated (cascade2)) if (cascade2%grove == 0) then if (cascade2%multiplicity == multiplicity & .and. cascade2%n_resonances == n_resonances & .and. cascade2%n_log_enhanced == n_log_enhanced & .and. cascade2%n_off_shell == n_off_shell & .and. cascade2%n_t_channel == n_t_channel & .and. cascade2%res_hash == res_hash) then cascade2%grove = grove end if end if call terminate_now_if_signal () cascade2 => cascade2%next end do end if call terminate_now_if_signal () cascade1 => cascade1%next end do cascade_set%n_groves = grove end subroutine cascade_set_assign_groves @ %def cascade_set_assign_groves @ \subsection{Generate the phase space file} Generate a complete phase space configuration. For each flavor assignment: First, all s-channel graphs that can be built up from the outgoing particles. Then we distinguish (1) decay, where we complete the s-channel graphs by connecting to the input line, and (2) scattering, where we now generate t-channel graphs by introducing an incoming particle, and complete this by connecting to the other incoming particle. After all cascade sets have been generated, merge them into a common set. This eliminates redunancies between flavor assignments. <>= public :: cascade_set_generate <>= subroutine cascade_set_generate & (cascade_set, model, n_in, n_out, flv, phs_par, fatal_beam_decay) type(cascade_set_t), intent(out) :: cascade_set class(model_data_t), intent(in), target :: model integer, intent(in) :: n_in, n_out type(flavor_t), dimension(:,:), intent(in) :: flv type(phs_parameters_t), intent(in) :: phs_par logical, intent(in) :: fatal_beam_decay type(cascade_set_t), dimension(:), allocatable :: cset type(cascade_t), pointer :: cascade integer :: i if (phase_space_vanishes (phs_par%sqrts, n_in, flv)) return call cascade_set_init (cascade_set, model, n_in, n_out, phs_par, & fatal_beam_decay, flv) allocate (cset (size (flv, 2))) do i = 1, size (cset) call cascade_set_generate_single (cset(i), & model, n_in, n_out, flv(:,i), phs_par, fatal_beam_decay) cascade => cset(i)%first_k do while (associated (cascade)) if (cascade%active .and. cascade%complete) then call cascade_set_add_copy (cascade_set, cascade) end if cascade => cascade%next end do call cascade_set_final (cset(i)) end do cascade_set%first_k => cascade_set%first call cascade_set_assign_resonance_hash (cascade_set) call cascade_set_assign_groves (cascade_set) end subroutine cascade_set_generate @ %def cascade_set_generate @ This generates phase space for a single channel, without assigning groves. <>= subroutine cascade_set_generate_single (cascade_set, & model, n_in, n_out, flv, phs_par, fatal_beam_decay) type(cascade_set_t), intent(out) :: cascade_set class(model_data_t), intent(in), target :: model integer, intent(in) :: n_in, n_out type(flavor_t), dimension(:), intent(in) :: flv type(phs_parameters_t), intent(in) :: phs_par logical, intent(in) :: fatal_beam_decay integer :: n11, n12, n21, n22 call cascade_set_init (cascade_set, model, n_in, n_out, phs_par, & fatal_beam_decay) call cascade_set_add_outgoing (cascade_set, flv(n_in+1:)) call cascade_set_generate_s (cascade_set) select case (n_in) case(1) call cascade_set_add_incoming & (cascade_set, n11, n12, n_out + 1, flv(1)) call cascade_set_generate_decay (cascade_set) case(2) call cascade_set_add_incoming & (cascade_set, n11, n12, n_out + 1, flv(2)) call cascade_set_add_incoming & (cascade_set, n21, n22, n_out + 2, flv(1)) call cascade_set_generate_t (cascade_set, n_out + 1, n_out + 2) call cascade_set_generate_t (cascade_set, n_out + 2, n_out + 1) call cascade_set_generate_scattering & (cascade_set, n11, n12, n21, n22, n_out + 1, n_out + 2) call cascade_set_generate_scattering & (cascade_set, n21, n22, n11, n12, n_out + 2, n_out + 1) end select end subroutine cascade_set_generate_single @ %def cascade_set_generate_single @ Sanity check: Before anything else is done, check if there could possibly be any phase space. <>= public :: phase_space_vanishes <>= function phase_space_vanishes (sqrts, n_in, flv) result (flag) logical :: flag real(default), intent(in) :: sqrts integer, intent(in) :: n_in type(flavor_t), dimension(:,:), intent(in) :: flv real(default), dimension(:,:), allocatable :: mass real(default), dimension(:), allocatable :: mass_in, mass_out integer :: n_prt, n_flv, i, j flag = .false. if (sqrts <= 0) then call msg_error ("Phase space vanishes (sqrts must be positive)") flag = .true.; return end if n_prt = size (flv, 1) n_flv = size (flv, 2) allocate (mass (n_prt, n_flv), mass_in (n_flv), mass_out (n_flv)) mass = flv%get_mass () mass_in = sum (mass(:n_in,:), 1) mass_out = sum (mass(n_in+1:,:), 1) if (any (mass_in > sqrts)) then call msg_error ("Mass sum of incoming particles " & // "is more than available energy") flag = .true.; return end if if (any (mass_out > sqrts)) then call msg_error ("Mass sum of outgoing particles " & // "is more than available energy") flag = .true.; return end if end function phase_space_vanishes @ %def phase_space_vanishes @ \subsection{Return the resonance histories for subtraction} This appears to be essential (re-export of some imported assignment?)! <>= public :: assignment(=) @ Extract the resonance set from a complete cascade. <>= procedure :: extract_resonance_history => cascade_extract_resonance_history <>= subroutine cascade_extract_resonance_history & (cascade, res_hist, model, n_out) class(cascade_t), intent(in), target :: cascade type(resonance_history_t), intent(out) :: res_hist class(model_data_t), intent(in), target :: model integer, intent(in) :: n_out type(resonance_info_t) :: resonance integer :: i, mom_id, pdg call msg_debug2 (D_PHASESPACE, "cascade_extract_resonance_history") if (cascade%n_resonances > 0) then if (cascade%has_children) then call msg_debug2 (D_PHASESPACE, "cascade has resonances and children") do i = 1, size(cascade%tree_resonant) if (cascade%tree_resonant (i)) then mom_id = cascade%tree (i) pdg = cascade%tree_pdg (i) call resonance%init (mom_id, pdg, model, n_out) if (debug2_active (D_PHASESPACE)) then print *, 'D: Adding resonance' call resonance%write () end if call res_hist%add_resonance (resonance) end if end do end if end if end subroutine cascade_extract_resonance_history @ %def cascade_extract_resonance_history @ <>= public :: cascade_set_get_n_trees <>= function cascade_set_get_n_trees (cascade_set) result (n) type(cascade_set_t), intent(in), target :: cascade_set integer :: n type(cascade_t), pointer :: cascade integer :: grove call msg_debug (D_PHASESPACE, "cascade_set_get_n_trees") n = 0 do grove = 1, cascade_set%n_groves cascade => cascade_set%first_k do while (associated (cascade)) if (cascade%active .and. cascade%complete) then if (cascade%grove == grove) then n = n + 1 end if end if cascade => cascade%next end do end do call msg_debug (D_PHASESPACE, "n", n) end function cascade_set_get_n_trees @ %def cascade_set_get_n_trees @ Distill the set of resonance histories from the cascade set. The result is an array which contains each valid history exactly once. <>= public :: cascade_set_get_resonance_histories <>= subroutine cascade_set_get_resonance_histories (cascade_set, n_filter, res_hists) type(cascade_set_t), intent(in), target :: cascade_set integer, intent(in), optional :: n_filter type(resonance_history_t), dimension(:), allocatable, intent(out) :: res_hists type(resonance_history_t), dimension(:), allocatable :: tmp type(cascade_t), pointer :: cascade type(resonance_history_t) :: res_hist type(resonance_history_set_t) :: res_hist_set integer :: grove, i, n_hists logical :: included, add_to_list call msg_debug (D_PHASESPACE, "cascade_set_get_resonance_histories") call res_hist_set%init (n_filter = n_filter) do grove = 1, cascade_set%n_groves cascade => cascade_set%first_k do while (associated (cascade)) if (cascade%active .and. cascade%complete) then if (cascade%grove == grove) then call msg_debug2 (D_PHASESPACE, "grove", grove) call cascade%extract_resonance_history & (res_hist, cascade_set%model, cascade_set%n_out) call res_hist_set%enter (res_hist) end if end if cascade => cascade%next end do end do call res_hist_set%freeze () call res_hist_set%to_array (res_hists) end subroutine cascade_set_get_resonance_histories @ %def cascade_set_get_resonance_histories @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[cascades_ut.f90]]>>= <> module cascades_ut use unit_tests use cascades_uti <> <> contains <> end module cascades_ut @ %def cascades_ut @ <<[[cascades_uti.f90]]>>= <> module cascades_uti <> <> use numeric_utils use flavors use model_data use phs_forests, only: phs_parameters_t use resonances, only: resonance_history_t use cascades <> <> contains <> end module cascades_uti @ %def cascades_ut @ API: driver for the unit tests below. <>= public :: cascades_test <>= subroutine cascades_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine cascades_test @ %def cascades_test \subsubsection{Check cascade setup} @ Checking the basic setup up of the phase space cascade parameterizations. <>= call test (cascades_1, "cascades_1", & "check cascade setup", & u, results) <>= public :: cascades_1 <>= subroutine cascades_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t), dimension(5,2) :: flv type(cascade_set_t) :: cascade_set type(phs_parameters_t) :: phs_par write (u, "(A)") "* Test output: cascades_1" write (u, "(A)") "* Purpose: test cascade phase space functions" write (u, "(A)") write (u, "(A)") "* Initializing" write (u, "(A)") call model%init_sm_test () call flv(1,1)%init ( 2, model) call flv(2,1)%init (-2, model) call flv(3,1)%init ( 1, model) call flv(4,1)%init (-1, model) call flv(5,1)%init (21, model) call flv(1,2)%init ( 2, model) call flv(2,2)%init (-2, model) call flv(3,2)%init ( 2, model) call flv(4,2)%init (-2, model) call flv(5,2)%init (21, model) phs_par%sqrts = 1000._default phs_par%off_shell = 2 write (u, "(A)") write (u, "(A)") "* Generating the cascades" write (u, "(A)") call cascade_set_generate (cascade_set, model, 2, 3, flv, phs_par,.true.) call cascade_set_write (cascade_set, u) call cascade_set_write_file_format (cascade_set, u) write (u, "(A)") "* Cleanup" write (u, "(A)") call cascade_set_final (cascade_set) call model%final () write (u, *) write (u, "(A)") "* Test output end: cascades_1" end subroutine cascades_1 @ %def cascades_1 @ \subsubsection{Check resonance history} <>= call test(cascades_2, "cascades_2", & "Check resonance history", u, results) <>= public :: cascades_2 <>= subroutine cascades_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t), dimension(5,1) :: flv type(cascade_set_t) :: cascade_set type(phs_parameters_t) :: phs_par type(resonance_history_t), dimension(:), allocatable :: res_hists integer :: n, i write (u, "(A)") "* Test output: cascades_2" write (u, "(A)") "* Purpose: Check resonance history" write (u, "(A)") write (u, "(A)") "* Initializing" write (u, "(A)") call model%init_sm_test () call flv(1,1)%init ( 2, model) call flv(2,1)%init (-2, model) call flv(3,1)%init ( 1, model) call flv(4,1)%init (-1, model) call flv(5,1)%init (22, model) phs_par%sqrts = 1000._default phs_par%off_shell = 2 write (u, "(A)") write (u, "(A)") "* Generating the cascades" write (u, "(A)") call cascade_set_generate (cascade_set, model, 2, 3, flv, phs_par,.true.) call cascade_set_get_resonance_histories (cascade_set, res_hists = res_hists) n = cascade_set_get_n_trees (cascade_set) call assert_equal (u, n, 24, "Number of trees") do i = 1, size(res_hists) call res_hists(i)%write (u) write (u, "(A)") end do write (u, "(A)") "* Cleanup" write (u, "(A)") call cascade_set_final (cascade_set) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: cascades_2" end subroutine cascades_2 @ %def cascades_2 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{WOOD phase space} This is the module that interfaces the [[phs_forests]] phase-space treatment and the [[cascades]] module for generating phase-space channels. As an extension of the [[phs_base]] abstract type, the phase-space configuration and instance implement the standard API. (Currently, this is the only generic phase-space implementation of \whizard. For trivial two-particle phase space, there is [[phs_wood]] as an alternative.) <<[[phs_wood.f90]]>>= <> module phs_wood <> <> use io_units use constants use numeric_utils use diagnostics use os_interface use md5 use physics_defs use lorentz use model_data use flavors use process_constants use sf_mappings use sf_base use phs_base use mappings use resonances, only: resonance_history_set_t use phs_forests use cascades use cascades2 <> <> <> <> contains <> end module phs_wood @ %def phs_wood @ \subsection{Configuration} <>= integer, parameter, public :: EXTENSION_NONE = 0 integer, parameter, public :: EXTENSION_DEFAULT = 1 integer, parameter, public :: EXTENSION_DGLAP = 2 <>= public :: phs_wood_config_t <>= type, extends (phs_config_t) :: phs_wood_config_t character(32) :: md5sum_forest = "" type(string_t) :: phs_path integer :: io_unit = 0 logical :: io_unit_keep_open = .false. logical :: use_equivalences = .false. logical :: fatal_beam_decay = .true. type(mapping_defaults_t) :: mapping_defaults type(phs_parameters_t) :: par type(string_t) :: run_id type(cascade_set_t), allocatable :: cascade_set logical :: use_cascades2 = .false. type(feyngraph_set_t), allocatable :: feyngraph_set type(phs_forest_t) :: forest type(os_data_t) :: os_data integer :: extension_mode = EXTENSION_NONE contains <> end type phs_wood_config_t @ %def phs_wood_config_t @ Finalizer. We should delete the cascade set and the forest subobject. Also close the I/O unit, just in case. (We assume that [[io_unit]] is not standard input/output.) <>= procedure :: final => phs_wood_config_final <>= subroutine phs_wood_config_final (object) class(phs_wood_config_t), intent(inout) :: object logical :: opened if (object%io_unit /= 0) then inquire (unit = object%io_unit, opened = opened) if (opened) close (object%io_unit) end if call object%clear_phase_space () call phs_forest_final (object%forest) end subroutine phs_wood_config_final @ %def phs_wood_config_final @ <>= procedure :: increase_n_par => phs_wood_config_increase_n_par <>= subroutine phs_wood_config_increase_n_par (phs_config) class(phs_wood_config_t), intent(inout) :: phs_config select case (phs_config%extension_mode) case (EXTENSION_DEFAULT) phs_config%n_par = phs_config%n_par + 3 case (EXTENSION_DGLAP) phs_config%n_par = phs_config%n_par + 4 end select end subroutine phs_wood_config_increase_n_par @ %def phs_wood_config_increase_n_par @ <>= procedure :: set_extension_mode => phs_wood_config_set_extension_mode <>= subroutine phs_wood_config_set_extension_mode (phs_config, mode) class(phs_wood_config_t), intent(inout) :: phs_config integer, intent(in) :: mode phs_config%extension_mode = mode end subroutine phs_wood_config_set_extension_mode @ %def phs_wood_config_set_extension_mode @ Output. The contents of the PHS forest are not printed explicitly. <>= procedure :: write => phs_wood_config_write <>= subroutine phs_wood_config_write (object, unit, include_id) class(phs_wood_config_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: include_id integer :: u u = given_output_unit (unit) write (u, "(1x,A)") & "Partonic phase-space configuration (phase-space forest):" call object%base_write (unit) write (u, "(1x,A)") "Phase-space configuration parameters:" call object%par%write (u) call object%mapping_defaults%write (u) write (u, "(3x,A,A,A)") "Run ID: '", char (object%run_id), "'" end subroutine phs_wood_config_write @ %def phs_wood_config_write @ Print the PHS forest contents. <>= procedure :: write_forest => phs_wood_config_write_forest <>= subroutine phs_wood_config_write_forest (object, unit) class(phs_wood_config_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) call phs_forest_write (object%forest, u) end subroutine phs_wood_config_write_forest @ %def phs_wood_config_write_forest @ Set the phase-space parameters that the configuration generator requests. <>= procedure :: set_parameters => phs_wood_config_set_parameters <>= subroutine phs_wood_config_set_parameters (phs_config, par) class(phs_wood_config_t), intent(inout) :: phs_config type(phs_parameters_t), intent(in) :: par phs_config%par = par end subroutine phs_wood_config_set_parameters @ %def phs_wood_config_set_parameters @ Enable the generation of channel equivalences (when calling [[configure]]). <>= procedure :: enable_equivalences => phs_wood_config_enable_equivalences <>= subroutine phs_wood_config_enable_equivalences (phs_config) class(phs_wood_config_t), intent(inout) :: phs_config phs_config%use_equivalences = .true. end subroutine phs_wood_config_enable_equivalences @ %def phs_wood_config_enable_equivalences @ Set the phase-space mapping parameters that the configuration generator requests.g <>= procedure :: set_mapping_defaults => phs_wood_config_set_mapping_defaults <>= subroutine phs_wood_config_set_mapping_defaults (phs_config, mapping_defaults) class(phs_wood_config_t), intent(inout) :: phs_config type(mapping_defaults_t), intent(in) :: mapping_defaults phs_config%mapping_defaults = mapping_defaults end subroutine phs_wood_config_set_mapping_defaults @ %def phs_wood_config_set_mapping_defaults @ Define the input stream for the phase-space file as an open logical unit. The unit must be connected. <>= procedure :: set_input => phs_wood_config_set_input <>= subroutine phs_wood_config_set_input (phs_config, unit) class(phs_wood_config_t), intent(inout) :: phs_config integer, intent(in) :: unit phs_config%io_unit = unit rewind (unit) end subroutine phs_wood_config_set_input @ %def phs_wood_config_set_input @ \subsection{Phase-space generation} This subroutine generates a phase space configuration using the [[cascades]] module. Note that this may take time, and the [[cascade_set]] subobject may consume a large amount of memory. <>= procedure :: generate_phase_space => phs_wood_config_generate_phase_space <>= subroutine phs_wood_config_generate_phase_space (phs_config) class(phs_wood_config_t), intent(inout) :: phs_config integer :: off_shell, extra_off_shell logical :: valid integer :: unit_fds type(string_t) :: file_name logical :: file_exists call msg_message ("Phase space: generating configuration ...") off_shell = phs_config%par%off_shell if (phs_config%use_cascades2) then file_name = char (phs_config%id) // ".fds" inquire (file=char (file_name), exist=file_exists) if (.not. file_exists) call msg_fatal & ("The O'Mega input file " // char (file_name) // & " does not exist. " // "Please make sure that the " // & "variable ?omega_write_phs_output has been set correctly.") unit_fds = free_unit () open (unit=unit_fds, file=char(file_name), status='old', action='read') do extra_off_shell = 0, max (phs_config%n_tot - 3, 0) phs_config%par%off_shell = off_shell + extra_off_shell allocate (phs_config%feyngraph_set) call feyngraph_set_generate (phs_config%feyngraph_set, & phs_config%model, phs_config%n_in, phs_config%n_out, & phs_config%flv, & phs_config%par, phs_config%fatal_beam_decay, unit_fds, & phs_config%vis_channels) if (feyngraph_set_is_valid (phs_config%feyngraph_set)) then exit else call msg_message ("Phase space: ... failed. & &Increasing phs_off_shell ...") call phs_config%feyngraph_set%final () deallocate (phs_config%feyngraph_set) end if end do close (unit_fds) else allocate (phs_config%cascade_set) do extra_off_shell = 0, max (phs_config%n_tot - 3, 0) phs_config%par%off_shell = off_shell + extra_off_shell call cascade_set_generate (phs_config%cascade_set, & phs_config%model, phs_config%n_in, phs_config%n_out, & phs_config%flv, & phs_config%par, phs_config%fatal_beam_decay) if (cascade_set_is_valid (phs_config%cascade_set)) then exit else call msg_message ("Phase space: ... failed. & &Increasing phs_off_shell ...") end if end do end if if (phs_config%use_cascades2) then valid = feyngraph_set_is_valid (phs_config%feyngraph_set) else valid = cascade_set_is_valid (phs_config%cascade_set) end if if (valid) then call msg_message ("Phase space: ... success.") else call msg_fatal ("Phase-space: generation failed") end if end subroutine phs_wood_config_generate_phase_space @ %def phs_wood_config_generate_phase_space @ Using the generated phase-space configuration, write an appropriate phase-space file to the stored (or explicitly specified) I/O unit. <>= procedure :: write_phase_space => phs_wood_config_write_phase_space <>= subroutine phs_wood_config_write_phase_space (phs_config, & filename_vis, unit) class(phs_wood_config_t), intent(in) :: phs_config integer, intent(in), optional :: unit type(string_t), intent(in), optional :: filename_vis type(string_t) :: setenv_tex, setenv_mp, pipe, pipe_dvi integer :: u, unit_tex, unit_dev, status if (allocated (phs_config%cascade_set) .or. allocated (phs_config%feyngraph_set)) then if (present (unit)) then u = unit else u = phs_config%io_unit end if write (u, "(1x,A,A)") "process ", char (phs_config%id) write (u, "(A)") if (phs_config%use_cascades2) then call feyngraph_set_write_process_bincode_format (phs_config%feyngraph_set, u) else call cascade_set_write_process_bincode_format (phs_config%cascade_set, u) end if write (u, "(A)") write (u, "(3x,A,A,A32,A)") "md5sum_process = ", & '"', phs_config%md5sum_process, '"' write (u, "(3x,A,A,A32,A)") "md5sum_model_par = ", & '"', phs_config%md5sum_model_par, '"' write (u, "(3x,A,A,A32,A)") "md5sum_phs_config = ", & '"', phs_config%md5sum_phs_config, '"' call phs_config%par%write (u) if (phs_config%use_cascades2) then call feyngraph_set_write_file_format (phs_config%feyngraph_set, u) else call cascade_set_write_file_format (phs_config%cascade_set, u) end if if (phs_config%vis_channels) then unit_tex = free_unit () open (unit=unit_tex, file=char(filename_vis // ".tex"), & action="write", status="replace") if (phs_config%use_cascades2) then call feyngraph_set_write_graph_format (phs_config%feyngraph_set, & filename_vis // "-graphs", phs_config%id, unit_tex) else call cascade_set_write_graph_format (phs_config%cascade_set, & filename_vis // "-graphs", phs_config%id, unit_tex) end if close (unit_tex) call msg_message ("Phase space: visualizing channels in file " & // char(trim(filename_vis)) // "...") if (phs_config%os_data%event_analysis_ps) then BLOCK: do unit_dev = free_unit () open (file = "/dev/null", unit = unit_dev, & action = "write", iostat = status) if (status /= 0) then pipe = "" pipe_dvi = "" else pipe = " > /dev/null" pipe_dvi = " 2>/dev/null 1>/dev/null" end if close (unit_dev) if (phs_config%os_data%whizard_texpath /= "") then setenv_tex = "TEXINPUTS=" // & phs_config%os_data%whizard_texpath // ":$TEXINPUTS " setenv_mp = "MPINPUTS=" // & phs_config%os_data%whizard_texpath // ":$MPINPUTS " else setenv_tex = "" setenv_mp = "" end if call os_system_call (setenv_tex // & phs_config%os_data%latex // " " // & filename_vis // ".tex " // pipe, status) if (status /= 0) exit BLOCK if (phs_config%os_data%mpost /= "") then call os_system_call (setenv_mp // & phs_config%os_data%mpost // " " // & filename_vis // "-graphs.mp" // pipe, status) else call msg_fatal ("Could not use MetaPOST.") end if if (status /= 0) exit BLOCK call os_system_call (setenv_tex // & phs_config%os_data%latex // " " // & filename_vis // ".tex" // pipe, status) if (status /= 0) exit BLOCK call os_system_call & (phs_config%os_data%dvips // " -o " // filename_vis & // ".ps " // filename_vis // ".dvi" // pipe_dvi, status) if (status /= 0) exit BLOCK if (phs_config%os_data%event_analysis_pdf) then call os_system_call (phs_config%os_data%ps2pdf // " " // & filename_vis // ".ps", status) if (status /= 0) exit BLOCK end if exit BLOCK end do BLOCK if (status /= 0) then call msg_error ("Unable to compile analysis output file") end if end if end if else call msg_fatal ("Phase-space configuration: & &no phase space object generated") end if end subroutine phs_wood_config_write_phase_space @ %def phs_config_write_phase_space @ Clear the phase-space configuration. This is useful since the object may become \emph{really} large. <>= procedure :: clear_phase_space => phs_wood_config_clear_phase_space <>= subroutine phs_wood_config_clear_phase_space (phs_config) class(phs_wood_config_t), intent(inout) :: phs_config if (allocated (phs_config%cascade_set)) then call cascade_set_final (phs_config%cascade_set) deallocate (phs_config%cascade_set) end if if (allocated (phs_config%feyngraph_set)) then call phs_config%feyngraph_set%final () deallocate (phs_config%feyngraph_set) end if end subroutine phs_wood_config_clear_phase_space @ %def phs_wood_config_clear_phase_space @ Extract the set of resonance histories <>= procedure :: extract_resonance_history_set & => phs_wood_config_extract_resonance_history_set <>= subroutine phs_wood_config_extract_resonance_history_set & (phs_config, res_set, include_trivial) class(phs_wood_config_t), intent(in) :: phs_config type(resonance_history_set_t), intent(out) :: res_set logical, intent(in), optional :: include_trivial call phs_config%forest%extract_resonance_history_set & (res_set, include_trivial) end subroutine phs_wood_config_extract_resonance_history_set @ %def phs_wood_config_extract_resonance_history_set @ \subsection{Phase-space configuration} We read the phase-space configuration from the stored I/O unit. If this is not set, we assume that we have to generate a phase space configuration. When done, we open a scratch file and write the configuration. If [[rebuild]] is set, we should trash any existing phase space file and build a new one. Otherwise, we try to use an old one, which we check for existence and integrity. If [[ignore_mismatch]] is set, we reuse an existing file even if it does not match the current setup. <>= procedure :: configure => phs_wood_config_configure <>= subroutine phs_wood_config_configure (phs_config, sqrts, & sqrts_fixed, cm_frame, azimuthal_dependence, rebuild, ignore_mismatch, & nlo_type, subdir) class(phs_wood_config_t), intent(inout) :: phs_config real(default), intent(in) :: sqrts logical, intent(in), optional :: sqrts_fixed logical, intent(in), optional :: cm_frame logical, intent(in), optional :: azimuthal_dependence logical, intent(in), optional :: rebuild logical, intent(in), optional :: ignore_mismatch integer, intent(in), optional :: nlo_type type(string_t), intent(in), optional :: subdir type(string_t) :: filename, filename_vis logical :: variable_limits logical :: ok, exist, found, check, match, rebuild_phs integer :: g, c0, c1, n if (present (nlo_type)) then phs_config%nlo_type = nlo_type else phs_config%nlo_type = BORN end if phs_config%sqrts = sqrts phs_config%par%sqrts = sqrts if (present (sqrts_fixed)) & phs_config%sqrts_fixed = sqrts_fixed if (present (cm_frame)) & phs_config%cm_frame = cm_frame if (present (azimuthal_dependence)) & phs_config%azimuthal_dependence = azimuthal_dependence if (present (rebuild)) then rebuild_phs = rebuild else rebuild_phs = .true. end if if (present (ignore_mismatch)) then check = .not. ignore_mismatch if (ignore_mismatch) & call msg_warning ("Reading phs file: MD5 sum check disabled") else check = .true. end if phs_config%md5sum_forest = "" call phs_config%compute_md5sum (include_id = .false.) if (phs_config%io_unit == 0) then filename = phs_config%make_phs_filename (subdir) filename_vis = phs_config%make_phs_filename (subdir) // "-vis" if (.not. rebuild_phs) then if (check) then call phs_config%read_phs_file (exist, found, match, subdir=subdir) rebuild_phs = .not. (exist .and. found .and. match) else call phs_config%read_phs_file (exist, found, subdir=subdir) rebuild_phs = .not. (exist .and. found) end if end if if (.not. mpi_is_comm_master ()) then rebuild_phs = .false. call msg_message ("MPI: Workers do not build phase space configuration.") end if if (rebuild_phs) then call phs_config%generate_phase_space () phs_config%io_unit = free_unit () if (phs_config%id /= "") then call msg_message ("Phase space: writing configuration file '" & // char (filename) // "'") open (phs_config%io_unit, file = char (filename), & status = "replace", action = "readwrite") else open (phs_config%io_unit, status = "scratch", action = "readwrite") end if call phs_config%write_phase_space (filename_vis) rewind (phs_config%io_unit) else call msg_message ("Phase space: keeping configuration file '" & // char (filename) // "'") end if end if if (phs_config%io_unit == 0) then ok = .true. else call phs_forest_read (phs_config%forest, phs_config%io_unit, & phs_config%id, phs_config%n_in, phs_config%n_out, & phs_config%model, ok) if (.not. phs_config%io_unit_keep_open) then close (phs_config%io_unit) phs_config%io_unit = 0 end if end if if (ok) then call phs_forest_set_flavors (phs_config%forest, phs_config%flv(:,1)) variable_limits = .not. phs_config%cm_frame call phs_forest_set_parameters & (phs_config%forest, phs_config%mapping_defaults, variable_limits) call phs_forest_setup_prt_combinations (phs_config%forest) phs_config%n_channel = phs_forest_get_n_channels (phs_config%forest) phs_config%n_par = phs_forest_get_n_parameters (phs_config%forest) allocate (phs_config%channel (phs_config%n_channel)) if (phs_config%use_equivalences) then call phs_forest_set_equivalences (phs_config%forest) call phs_forest_get_equivalences (phs_config%forest, & phs_config%channel, phs_config%azimuthal_dependence) phs_config%provides_equivalences = .true. end if call phs_forest_set_s_mappings (phs_config%forest) call phs_config%record_on_shell () if (phs_config%mapping_defaults%enable_s_mapping) then call phs_config%record_s_mappings () end if allocate (phs_config%chain (phs_config%n_channel), source = 0) do g = 1, phs_forest_get_n_groves (phs_config%forest) call phs_forest_get_grove_bounds (phs_config%forest, g, c0, c1, n) phs_config%chain (c0:c1) = g end do phs_config%provides_chains = .true. call phs_config%compute_md5sum_forest () else write (msg_buffer, "(A,A,A)") & "Phase space: process '", & char (phs_config%id), "' not found in configuration file" call msg_fatal () end if end subroutine phs_wood_config_configure @ %def phs_wood_config_configure @ The MD5 sum of the forest is computed in addition to the MD5 sum of the configuration. The reason is that the forest may depend on a user-provided external file. On the other hand, this MD5 sum encodes all information that is relevant for further processing. Therefore, the [[get_md5sum]] method returns this result, once it is available. <>= procedure :: compute_md5sum_forest => phs_wood_config_compute_md5sum_forest <>= subroutine phs_wood_config_compute_md5sum_forest (phs_config) class(phs_wood_config_t), intent(inout) :: phs_config integer :: u u = free_unit () open (u, status = "scratch", action = "readwrite") call phs_config%write_forest (u) rewind (u) phs_config%md5sum_forest = md5sum (u) close (u) end subroutine phs_wood_config_compute_md5sum_forest @ %def phs_wood_config_compute_md5sum_forest @ Create filenames according to standard conventions. The [[id]] is the process name including the suffix [[_iX]] where [[X]] stands for the component identifier (an integer). The [[run_id]] may be set or unset. The convention for file names that include the run ID is to separate prefix, run ID, and any extensions by dots. We construct the file name by concatenating the individual elements accordingly. If there is no run ID, we nevertheless replace [[_iX]] by [[.iX]]. <>= procedure :: make_phs_filename => phs_wood_make_phs_filename <>= function phs_wood_make_phs_filename (phs_config, subdir) result (filename) class(phs_wood_config_t), intent(in) :: phs_config type(string_t), intent(in), optional :: subdir type(string_t) :: filename type(string_t) :: basename, suffix, comp_code, comp_index basename = phs_config%id call split (basename, suffix, "_", back=.true.) comp_code = extract (suffix, 1, 1) comp_index = extract (suffix, 2) if (comp_code == "i" .and. verify (comp_index, "1234567890") == 0) then suffix = "." // comp_code // comp_index else basename = phs_config%id suffix = "" end if if (phs_config%run_id /= "") then filename = basename // "." // phs_config%run_id // suffix // ".phs" else filename = basename // suffix // ".phs" end if if (present (subdir)) then filename = subdir // "/" // filename end if end function phs_wood_make_phs_filename @ %def phs_wood_make_phs_filename @ <>= procedure :: reshuffle_flavors => phs_wood_config_reshuffle_flavors <>= subroutine phs_wood_config_reshuffle_flavors (phs_config, reshuffle, flv_extra) class(phs_wood_config_t), intent(inout) :: phs_config integer, intent(in), dimension(:), allocatable :: reshuffle type(flavor_t), intent(in) :: flv_extra call phs_forest_set_flavors (phs_config%forest, phs_config%flv(:,1), reshuffle, flv_extra) end subroutine phs_wood_config_reshuffle_flavors @ %def phs_wood_config_reshuffle_flavors @ <>= procedure :: set_momentum_links => phs_wood_config_set_momentum_links <>= subroutine phs_wood_config_set_momentum_links (phs_config, reshuffle) class(phs_wood_config_t), intent(inout) :: phs_config integer, intent(in), dimension(:), allocatable :: reshuffle call phs_forest_set_momentum_links (phs_config%forest, reshuffle) end subroutine phs_wood_config_set_momentum_links @ %def phs_wood_config_set_momentum_links @ Identify resonances which are marked by s-channel mappings for the whole phase space and report them to the channel array. <>= procedure :: record_s_mappings => phs_wood_config_record_s_mappings <>= subroutine phs_wood_config_record_s_mappings (phs_config) class(phs_wood_config_t), intent(inout) :: phs_config logical :: flag real(default) :: mass, width integer :: c do c = 1, phs_config%n_channel call phs_forest_get_s_mapping (phs_config%forest, c, flag, mass, width) if (flag) then if (mass == 0) then call msg_fatal ("Phase space: s-channel resonance " & // " has zero mass") end if if (width == 0) then call msg_fatal ("Phase space: s-channel resonance " & // " has zero width") end if call phs_config%channel(c)%set_resonant (mass, width) end if end do end subroutine phs_wood_config_record_s_mappings @ %def phs_wood_config_record_s_mappings @ Identify on-shell mappings for the whole phase space and report them to the channel array. <>= procedure :: record_on_shell => phs_wood_config_record_on_shell <>= subroutine phs_wood_config_record_on_shell (phs_config) class(phs_wood_config_t), intent(inout) :: phs_config logical :: flag real(default) :: mass integer :: c do c = 1, phs_config%n_channel call phs_forest_get_on_shell (phs_config%forest, c, flag, mass) if (flag) then call phs_config%channel(c)%set_on_shell (mass) end if end do end subroutine phs_wood_config_record_on_shell @ %def phs_wood_config_record_on_shell @ Return the most relevant MD5 sum. This overrides the method of the base type. <>= procedure :: get_md5sum => phs_wood_config_get_md5sum <>= function phs_wood_config_get_md5sum (phs_config) result (md5sum) class(phs_wood_config_t), intent(in) :: phs_config character(32) :: md5sum if (phs_config%md5sum_forest /= "") then md5sum = phs_config%md5sum_forest else md5sum = phs_config%md5sum_phs_config end if end function phs_wood_config_get_md5sum @ %def phs_wood_config_get_md5sum @ Check whether a phase-space configuration for the current process exists. We look for the phase-space file that should correspond to the current process. If we find it, we check the MD5 sums stored in the file against the MD5 sums in the current configuration (if required). If successful, read the PHS file. <>= procedure :: read_phs_file => phs_wood_read_phs_file <>= subroutine phs_wood_read_phs_file (phs_config, exist, found, match, subdir) class(phs_wood_config_t), intent(inout) :: phs_config logical, intent(out) :: exist logical, intent(out) :: found logical, intent(out), optional :: match type(string_t), intent(in), optional :: subdir type(string_t) :: filename integer :: u filename = phs_config%make_phs_filename (subdir) inquire (file = char (filename), exist = exist) if (exist) then u = free_unit () open (u, file = char (filename), action = "read", status = "old") call phs_forest_read (phs_config%forest, u, & phs_config%id, phs_config%n_in, phs_config%n_out, & phs_config%model, found, & phs_config%md5sum_process, & phs_config%md5sum_model_par, & phs_config%md5sum_phs_config, & match = match) close (u) else found = .false. if (present (match)) match = .false. end if end subroutine phs_wood_read_phs_file @ %def phs_wood_read_phs_file @ Startup message, after configuration is complete. <>= procedure :: startup_message => phs_wood_config_startup_message <>= subroutine phs_wood_config_startup_message (phs_config, unit) class(phs_wood_config_t), intent(in) :: phs_config integer, intent(in), optional :: unit integer :: n_groves, n_eq n_groves = phs_forest_get_n_groves (phs_config%forest) n_eq = phs_forest_get_n_equivalences (phs_config%forest) call phs_config%base_startup_message (unit) if (phs_config%n_channel == 1) then write (msg_buffer, "(A,2(I0,A))") & "Phase space: found ", phs_config%n_channel, & " channel, collected in ", n_groves, & " grove." else if (n_groves == 1) then write (msg_buffer, "(A,2(I0,A))") & "Phase space: found ", phs_config%n_channel, & " channels, collected in ", n_groves, & " grove." else write (msg_buffer, "(A,2(I0,A))") & "Phase space: found ", phs_config%n_channel, & " channels, collected in ", & phs_forest_get_n_groves (phs_config%forest), & " groves." end if call msg_message (unit = unit) if (phs_config%use_equivalences) then if (n_eq == 1) then write (msg_buffer, "(A,I0,A)") & "Phase space: Using ", n_eq, & " equivalence between channels." else write (msg_buffer, "(A,I0,A)") & "Phase space: Using ", n_eq, & " equivalences between channels." end if else write (msg_buffer, "(A)") & "Phase space: no equivalences between channels used." end if call msg_message (unit = unit) write (msg_buffer, "(A,2(1x,I0,1x,A))") & "Phase space: wood" call msg_message (unit = unit) end subroutine phs_wood_config_startup_message @ %def phs_wood_config_startup_message @ Allocate an instance: the actual phase-space object. <>= procedure, nopass :: allocate_instance => phs_wood_config_allocate_instance <>= subroutine phs_wood_config_allocate_instance (phs) class(phs_t), intent(inout), pointer :: phs allocate (phs_wood_t :: phs) end subroutine phs_wood_config_allocate_instance @ %def phs_wood_config_allocate_instance @ \subsection{Kinematics implementation} We generate $\cos\theta$ and $\phi$ uniformly, covering the solid angle. <>= public :: phs_wood_t <>= type, extends (phs_t) :: phs_wood_t real(default) :: sqrts = 0 type(phs_forest_t) :: forest real(default), dimension(3) :: r_real integer :: n_r_born = 0 contains <> end type phs_wood_t @ %def phs_wood_t @ Output. The [[verbose]] setting is irrelevant, we just display the contents of the base object. <>= procedure :: write => phs_wood_write <>= subroutine phs_wood_write (object, unit, verbose) class(phs_wood_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit) call object%base_write (u) end subroutine phs_wood_write @ %def phs_wood_write @ Write the forest separately. <>= procedure :: write_forest => phs_wood_write_forest <>= subroutine phs_wood_write_forest (object, unit) class(phs_wood_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) call phs_forest_write (object%forest, u) end subroutine phs_wood_write_forest @ %def phs_wood_write_forest @ Finalizer. <>= procedure :: final => phs_wood_final <>= subroutine phs_wood_final (object) class(phs_wood_t), intent(inout) :: object call phs_forest_final (object%forest) end subroutine phs_wood_final @ %def phs_wood_final @ Initialization. We allocate arrays ([[base_init]]) and adjust the phase-space volume. The two-particle phase space volume is \begin{equation} \Phi_2 = \frac{1}{4(2\pi)^5} = 2.55294034614 \times 10^{-5} \end{equation} independent of the particle masses. <>= procedure :: init => phs_wood_init <>= subroutine phs_wood_init (phs, phs_config) class(phs_wood_t), intent(out) :: phs class(phs_config_t), intent(in), target :: phs_config call phs%base_init (phs_config) select type (phs_config) type is (phs_wood_config_t) phs%forest = phs_config%forest select case (phs_config%extension_mode) case (EXTENSION_DEFAULT) phs%n_r_born = phs_config%n_par - 3 case (EXTENSION_DGLAP) phs%n_r_born = phs_config%n_par - 4 end select end select end subroutine phs_wood_init @ %def phs_wood_init @ \subsection{Evaluation} We compute the outgoing momenta from the incoming momenta and the input parameter set [[r_in]] in channel [[r_in]]. We also compute the [[r]] parameters and Jacobians [[f]] for all other channels. We do \emph{not} need to a apply a transformation from/to the c.m.\ frame, because in [[phs_base]] the momenta are already boosted to the c.m.\ frame before assigning them in the [[phs]] object, and inversely boosted when extracting them. <>= procedure :: evaluate_selected_channel => phs_wood_evaluate_selected_channel procedure :: evaluate_other_channels => phs_wood_evaluate_other_channels <>= subroutine phs_wood_evaluate_selected_channel (phs, c_in, r_in) class(phs_wood_t), intent(inout) :: phs integer, intent(in) :: c_in real(default), intent(in), dimension(:) :: r_in logical :: ok phs%q_defined = .false. if (phs%p_defined) then call phs_forest_set_prt_in (phs%forest, phs%p) phs%r(:,c_in) = r_in call phs_forest_evaluate_selected_channel (phs%forest, & c_in, phs%active_channel, & phs%sqrts_hat, phs%r, phs%f, phs%volume, ok) select type (config => phs%config) type is (phs_wood_config_t) if (config%extension_mode > EXTENSION_NONE) then if (phs%n_r_born > 0) then phs%r_real = r_in (phs%n_r_born + 1 : phs%n_r_born + 3) else call msg_fatal ("n_r_born should be larger than 0!") end if end if end select if (ok) then phs%q = phs_forest_get_momenta_out (phs%forest) phs%q_defined = .true. end if end if end subroutine phs_wood_evaluate_selected_channel subroutine phs_wood_evaluate_other_channels (phs, c_in) class(phs_wood_t), intent(inout) :: phs integer, intent(in) :: c_in integer :: c if (phs%q_defined) then call phs_forest_evaluate_other_channels (phs%forest, & c_in, phs%active_channel, & phs%sqrts_hat, phs%r, phs%f, combine=.true.) select type (config => phs%config) type is (phs_wood_config_t) if (config%extension_mode > EXTENSION_NONE) then if (phs%n_r_born > 0) then do c = 1, size (phs%r, 2) phs%r(phs%n_r_born + 1 : phs%n_r_born + 3, c) = phs%r_real end do else phs%r_defined = .false. end if end if end select phs%r_defined = .true. end if end subroutine phs_wood_evaluate_other_channels @ %def phs_wood_evaluate_selected_channel @ %def phs_wood_evaluate_other_channels @ Inverse evaluation. <>= procedure :: inverse => phs_wood_inverse <>= subroutine phs_wood_inverse (phs) class(phs_wood_t), intent(inout) :: phs if (phs%p_defined .and. phs%q_defined) then call phs_forest_set_prt_in (phs%forest, phs%p) call phs_forest_set_prt_out (phs%forest, phs%q) call phs_forest_recover_channel (phs%forest, & 1, & phs%sqrts_hat, phs%r, phs%f, phs%volume) call phs_forest_evaluate_other_channels (phs%forest, & 1, phs%active_channel, & phs%sqrts_hat, phs%r, phs%f, combine=.false.) phs%r_defined = .true. end if end subroutine phs_wood_inverse @ %def phs_wood_inverse @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[phs_wood_ut.f90]]>>= <> module phs_wood_ut use unit_tests use phs_wood_uti <> <> <> contains <> end module phs_wood_ut @ %def phs_wood_ut @ <<[[phs_wood_uti.f90]]>>= <> module phs_wood_uti <> <> use io_units use os_interface use lorentz use flavors use model_data use process_constants use mappings use phs_base use phs_forests use phs_wood use phs_base_ut, only: init_test_process_data, init_test_decay_data <> <> <> contains <> <> end module phs_wood_uti @ %def phs_wood_ut @ API: driver for the unit tests below. <>= public :: phs_wood_test <>= subroutine phs_wood_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine phs_wood_test @ %def phs_wood_test <>= public :: phs_wood_vis_test <>= subroutine phs_wood_vis_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine phs_wood_vis_test @ %def phs_wood_vis_test @ \subsubsection{Phase-space configuration data} Construct and display a test phase-space configuration object. Also check the [[azimuthal_dependence]] flag. This auxiliary routine writes a phase-space configuration file to unit [[u_phs]]. <>= public :: write_test_phs_file <>= subroutine write_test_phs_file (u_phs, procname) integer, intent(in) :: u_phs type(string_t), intent(in), optional :: procname if (present (procname)) then write (u_phs, "(A,A)") "process ", char (procname) else write (u_phs, "(A)") "process testproc" end if write (u_phs, "(A,A)") " md5sum_process = ", '""' write (u_phs, "(A,A)") " md5sum_model_par = ", '""' write (u_phs, "(A,A)") " md5sum_phs_config = ", '""' write (u_phs, "(A)") " sqrts = 1000" write (u_phs, "(A)") " m_threshold_s = 50" write (u_phs, "(A)") " m_threshold_t = 100" write (u_phs, "(A)") " off_shell = 2" write (u_phs, "(A)") " t_channel = 6" write (u_phs, "(A)") " keep_nonresonant = T" write (u_phs, "(A)") " grove #1" write (u_phs, "(A)") " tree 3" end subroutine write_test_phs_file @ %def write_test_phs_file @ <>= call test (phs_wood_1, "phs_wood_1", & "phase-space configuration", & u, results) <>= public :: phs_wood_1 <>= subroutine phs_wood_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(process_constants_t) :: process_data class(phs_config_t), allocatable :: phs_data type(mapping_defaults_t) :: mapping_defaults real(default) :: sqrts integer :: u_phs, iostat character(32) :: buffer write (u, "(A)") "* Test output: phs_wood_1" write (u, "(A)") "* Purpose: initialize and display & &phase-space configuration data" write (u, "(A)") call model%init_test () call syntax_phs_forest_init () write (u, "(A)") "* Initialize a process" write (u, "(A)") call init_test_process_data (var_str ("phs_wood_1"), process_data) write (u, "(A)") "* Create a scratch phase-space file" write (u, "(A)") u_phs = free_unit () open (u_phs, status = "scratch", action = "readwrite") call write_test_phs_file (u_phs, var_str ("phs_wood_1")) rewind (u_phs) do read (u_phs, "(A)", iostat = iostat) buffer if (iostat /= 0) exit write (u, "(A)") trim (buffer) end do write (u, "(A)") write (u, "(A)") "* Setup phase-space configuration object" write (u, "(A)") mapping_defaults%step_mapping = .false. allocate (phs_wood_config_t :: phs_data) call phs_data%init (process_data, model) select type (phs_data) type is (phs_wood_config_t) call phs_data%set_input (u_phs) call phs_data%set_mapping_defaults (mapping_defaults) end select sqrts = 1000._default call phs_data%configure (sqrts) call phs_data%write (u) write (u, "(A)") select type (phs_data) type is (phs_wood_config_t) call phs_data%write_forest (u) end select write (u, "(A)") write (u, "(A)") "* Cleanup" close (u_phs) call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_wood_1" end subroutine phs_wood_1 @ %def phs_wood_1 @ \subsubsection{Phase space evaluation} Compute kinematics for given parameters, also invert the calculation. <>= call test (phs_wood_2, "phs_wood_2", & "phase-space evaluation", & u, results) <>= public :: phs_wood_2 <>= subroutine phs_wood_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(process_constants_t) :: process_data real(default) :: sqrts, E class(phs_config_t), allocatable, target :: phs_data class(phs_t), pointer :: phs => null () type(vector4_t), dimension(2) :: p, q integer :: u_phs write (u, "(A)") "* Test output: phs_wood_2" write (u, "(A)") "* Purpose: test simple single-channel phase space" write (u, "(A)") call model%init_test () call flv%init (25, model) write (u, "(A)") "* Initialize a process and a matching & &phase-space configuration" write (u, "(A)") call init_test_process_data (var_str ("phs_wood_2"), process_data) u_phs = free_unit () open (u_phs, status = "scratch", action = "readwrite") call write_test_phs_file (u_phs, var_str ("phs_wood_2")) rewind (u_phs) allocate (phs_wood_config_t :: phs_data) call phs_data%init (process_data, model) select type (phs_data) type is (phs_wood_config_t) call phs_data%set_input (u_phs) end select sqrts = 1000._default call phs_data%configure (sqrts) call phs_data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize the phase-space instance" write (u, "(A)") call phs_data%allocate_instance (phs) call phs%init (phs_data) call phs%write (u, verbose=.true.) write (u, "(A)") write (u, "(A)") "* Set incoming momenta" write (u, "(A)") E = sqrts / 2 p(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) p(2) = vector4_moving (E,-sqrt (E**2 - flv%get_mass ()**2), 3) call phs%set_incoming_momenta (p) call phs%compute_flux () call phs%write (u) write (u, "(A)") write (u, "(A)") "* Compute phase-space point & &for x = 0.125, 0.5" write (u, "(A)") call phs%evaluate_selected_channel (1, [0.125_default, 0.5_default]) call phs%evaluate_other_channels (1) call phs%write (u) write (u, "(A)") select type (phs) type is (phs_wood_t) call phs%write_forest (u) end select write (u, "(A)") write (u, "(A)") "* Inverse kinematics" write (u, "(A)") call phs%get_outgoing_momenta (q) call phs%final () deallocate (phs) call phs_data%allocate_instance (phs) call phs%init (phs_data) call phs%set_incoming_momenta (p) call phs%compute_flux () call phs%set_outgoing_momenta (q) call phs%inverse () call phs%write (u) write (u, "(A)") select type (phs) type is (phs_wood_t) call phs%write_forest (u) end select call phs%final () deallocate (phs) close (u_phs) call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_wood_2" end subroutine phs_wood_2 @ %def phs_wood_2 @ \subsubsection{Phase-space generation} Generate phase space for a simple process. <>= call test (phs_wood_3, "phs_wood_3", & "phase-space generation", & u, results) <>= public :: phs_wood_3 <>= subroutine phs_wood_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(process_constants_t) :: process_data type(phs_parameters_t) :: phs_par class(phs_config_t), allocatable :: phs_data integer :: iostat character(80) :: buffer write (u, "(A)") "* Test output: phs_wood_3" write (u, "(A)") "* Purpose: generate a phase-space configuration" write (u, "(A)") call model%init_test () call syntax_phs_forest_init () write (u, "(A)") "* Initialize a process and phase-space parameters" write (u, "(A)") call init_test_process_data (var_str ("phs_wood_3"), process_data) allocate (phs_wood_config_t :: phs_data) call phs_data%init (process_data, model) phs_par%sqrts = 1000 select type (phs_data) type is (phs_wood_config_t) call phs_data%set_parameters (phs_par) phs_data%io_unit_keep_open = .true. end select write (u, "(A)") write (u, "(A)") "* Generate a scratch phase-space file" write (u, "(A)") call phs_data%configure (phs_par%sqrts) select type (phs_data) type is (phs_wood_config_t) rewind (phs_data%io_unit) do read (phs_data%io_unit, "(A)", iostat = iostat) buffer if (iostat /= 0) exit write (u, "(A)") trim (buffer) end do end select write (u, "(A)") write (u, "(A)") "* Cleanup" call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_wood_3" end subroutine phs_wood_3 @ %def phs_wood_3 @ \subsubsection{Nontrivial process} Generate phase space for a $2\to 3$ process. <>= call test (phs_wood_4, "phs_wood_4", & "nontrivial process", & u, results) <>= public :: phs_wood_4 <>= subroutine phs_wood_4 (u) integer, intent(in) :: u type(model_data_t), target :: model type(process_constants_t) :: process_data type(phs_parameters_t) :: phs_par class(phs_config_t), allocatable, target :: phs_data integer :: iostat character(80) :: buffer class(phs_t), pointer :: phs => null () real(default) :: E, pL type(vector4_t), dimension(2) :: p type(vector4_t), dimension(3) :: q write (u, "(A)") "* Test output: phs_wood_4" write (u, "(A)") "* Purpose: generate a phase-space configuration" write (u, "(A)") call model%init_test () call syntax_phs_forest_init () write (u, "(A)") "* Initialize a process and phase-space parameters" write (u, "(A)") process_data%id = "phs_wood_4" process_data%model_name = "Test" process_data%n_in = 2 process_data%n_out = 3 process_data%n_flv = 1 allocate (process_data%flv_state (process_data%n_in + process_data%n_out, & process_data%n_flv)) process_data%flv_state(:,1) = [25, 25, 25, 6, -6] allocate (phs_wood_config_t :: phs_data) call phs_data%init (process_data, model) phs_par%sqrts = 1000 select type (phs_data) type is (phs_wood_config_t) call phs_data%set_parameters (phs_par) phs_data%io_unit_keep_open = .true. end select write (u, "(A)") write (u, "(A)") "* Generate a scratch phase-space file" write (u, "(A)") call phs_data%configure (phs_par%sqrts) select type (phs_data) type is (phs_wood_config_t) rewind (phs_data%io_unit) do read (phs_data%io_unit, "(A)", iostat = iostat) buffer if (iostat /= 0) exit write (u, "(A)") trim (buffer) end do end select write (u, "(A)") write (u, "(A)") "* Initialize the phase-space instance" write (u, "(A)") call phs_data%allocate_instance (phs) call phs%init (phs_data) write (u, "(A)") "* Set incoming momenta" write (u, "(A)") select type (phs_data) type is (phs_wood_config_t) E = phs_data%sqrts / 2 pL = sqrt (E**2 - phs_data%flv(1,1)%get_mass ()**2) end select p(1) = vector4_moving (E, pL, 3) p(2) = vector4_moving (E, -pL, 3) call phs%set_incoming_momenta (p) call phs%compute_flux () write (u, "(A)") "* Compute phase-space point & &for x = 0.1, 0.2, 0.3, 0.4, 0.5" write (u, "(A)") call phs%evaluate_selected_channel (1, & [0.1_default, 0.2_default, 0.3_default, 0.4_default, 0.5_default]) call phs%evaluate_other_channels (1) call phs%write (u) write (u, "(A)") write (u, "(A)") "* Inverse kinematics" write (u, "(A)") call phs%get_outgoing_momenta (q) call phs%final () deallocate (phs) call phs_data%allocate_instance (phs) call phs%init (phs_data) call phs%set_incoming_momenta (p) call phs%compute_flux () call phs%set_outgoing_momenta (q) call phs%inverse () call phs%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call phs%final () deallocate (phs) call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_wood_4" end subroutine phs_wood_4 @ %def phs_wood_4 @ \subsubsection{Equivalences} Generate phase space for a simple process, including channel equivalences. <>= call test (phs_wood_5, "phs_wood_5", & "equivalences", & u, results) <>= public :: phs_wood_5 <>= subroutine phs_wood_5 (u) integer, intent(in) :: u type(model_data_t), target :: model type(process_constants_t) :: process_data type(phs_parameters_t) :: phs_par class(phs_config_t), allocatable :: phs_data write (u, "(A)") "* Test output: phs_wood_5" write (u, "(A)") "* Purpose: generate a phase-space configuration" write (u, "(A)") call model%init_test () call syntax_phs_forest_init () write (u, "(A)") "* Initialize a process and phase-space parameters" write (u, "(A)") call init_test_process_data (var_str ("phs_wood_5"), process_data) allocate (phs_wood_config_t :: phs_data) call phs_data%init (process_data, model) phs_par%sqrts = 1000 select type (phs_data) type is (phs_wood_config_t) call phs_data%set_parameters (phs_par) call phs_data%enable_equivalences () end select write (u, "(A)") write (u, "(A)") "* Generate a scratch phase-space file" write (u, "(A)") call phs_data%configure (phs_par%sqrts) call phs_data%write (u) write (u, "(A)") select type (phs_data) type is (phs_wood_config_t) call phs_data%write_forest (u) end select write (u, "(A)") write (u, "(A)") "* Cleanup" call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_wood_5" end subroutine phs_wood_5 @ %def phs_wood_5 @ \subsubsection{MD5 sum checks} Generate phase space for a simple process. Repeat this with and without parameter change. <>= call test (phs_wood_6, "phs_wood_6", & "phase-space generation", & u, results) <>= public :: phs_wood_6 <>= subroutine phs_wood_6 (u) integer, intent(in) :: u type(model_data_t), target :: model type(process_constants_t) :: process_data type(phs_parameters_t) :: phs_par class(phs_config_t), allocatable :: phs_data logical :: exist, found, match integer :: u_phs character(*), parameter :: filename = "phs_wood_6_p.phs" write (u, "(A)") "* Test output: phs_wood_6" write (u, "(A)") "* Purpose: generate and check phase-space file" write (u, "(A)") call model%init_test () call syntax_phs_forest_init () write (u, "(A)") "* Initialize a process and phase-space parameters" write (u, "(A)") call init_test_process_data (var_str ("phs_wood_6"), process_data) process_data%id = "phs_wood_6_p" process_data%md5sum = "1234567890abcdef1234567890abcdef" allocate (phs_wood_config_t :: phs_data) call phs_data%init (process_data, model) phs_par%sqrts = 1000 select type (phs_data) type is (phs_wood_config_t) call phs_data%set_parameters (phs_par) end select write (u, "(A)") "* Remove previous phs file, if any" write (u, "(A)") inquire (file = filename, exist = exist) if (exist) then u_phs = free_unit () open (u_phs, file = filename, action = "write") close (u_phs, status = "delete") end if write (u, "(A)") "* Check phase-space file (should fail)" write (u, "(A)") select type (phs_data) type is (phs_wood_config_t) call phs_data%read_phs_file (exist, found, match) write (u, "(1x,A,L1)") "exist = ", exist write (u, "(1x,A,L1)") "found = ", found write (u, "(1x,A,L1)") "match = ", match end select write (u, "(A)") write (u, "(A)") "* Generate a phase-space file" write (u, "(A)") call phs_data%configure (phs_par%sqrts) write (u, "(1x,A,A,A)") "MD5 sum (process) = '", & phs_data%md5sum_process, "'" write (u, "(1x,A,A,A)") "MD5 sum (model par) = '", & phs_data%md5sum_model_par, "'" write (u, "(1x,A,A,A)") "MD5 sum (phs config) = '", & phs_data%md5sum_phs_config, "'" write (u, "(A)") write (u, "(A)") "* Check MD5 sum" write (u, "(A)") call phs_data%final () deallocate (phs_data) allocate (phs_wood_config_t :: phs_data) call phs_data%init (process_data, model) phs_par%sqrts = 1000 select type (phs_data) type is (phs_wood_config_t) call phs_data%set_parameters (phs_par) phs_data%sqrts = phs_par%sqrts phs_data%par%sqrts = phs_par%sqrts end select call phs_data%compute_md5sum () write (u, "(1x,A,A,A)") "MD5 sum (process) = '", & phs_data%md5sum_process, "'" write (u, "(1x,A,A,A)") "MD5 sum (model par) = '", & phs_data%md5sum_model_par, "'" write (u, "(1x,A,A,A)") "MD5 sum (phs config) = '", & phs_data%md5sum_phs_config, "'" select type (phs_data) type is (phs_wood_config_t) call phs_data%read_phs_file (exist, found, match) write (u, "(1x,A,L1)") "exist = ", exist write (u, "(1x,A,L1)") "found = ", found write (u, "(1x,A,L1)") "match = ", match end select write (u, "(A)") write (u, "(A)") "* Modify sqrts and check MD5 sum" write (u, "(A)") call phs_data%final () deallocate (phs_data) allocate (phs_wood_config_t :: phs_data) call phs_data%init (process_data, model) phs_par%sqrts = 500 select type (phs_data) type is (phs_wood_config_t) call phs_data%set_parameters (phs_par) phs_data%sqrts = phs_par%sqrts phs_data%par%sqrts = phs_par%sqrts end select call phs_data%compute_md5sum () write (u, "(1x,A,A,A)") "MD5 sum (process) = '", & phs_data%md5sum_process, "'" write (u, "(1x,A,A,A)") "MD5 sum (model par) = '", & phs_data%md5sum_model_par, "'" write (u, "(1x,A,A,A)") "MD5 sum (phs config) = '", & phs_data%md5sum_phs_config, "'" select type (phs_data) type is (phs_wood_config_t) call phs_data%read_phs_file (exist, found, match) write (u, "(1x,A,L1)") "exist = ", exist write (u, "(1x,A,L1)") "found = ", found write (u, "(1x,A,L1)") "match = ", match end select write (u, "(A)") write (u, "(A)") "* Modify process and check MD5 sum" write (u, "(A)") call phs_data%final () deallocate (phs_data) process_data%md5sum = "77777777777777777777777777777777" allocate (phs_wood_config_t :: phs_data) call phs_data%init (process_data, model) phs_par%sqrts = 1000 select type (phs_data) type is (phs_wood_config_t) call phs_data%set_parameters (phs_par) phs_data%sqrts = phs_par%sqrts phs_data%par%sqrts = phs_par%sqrts end select call phs_data%compute_md5sum () write (u, "(1x,A,A,A)") "MD5 sum (process) = '", & phs_data%md5sum_process, "'" write (u, "(1x,A,A,A)") "MD5 sum (model par) = '", & phs_data%md5sum_model_par, "'" write (u, "(1x,A,A,A)") "MD5 sum (phs config) = '", & phs_data%md5sum_phs_config, "'" select type (phs_data) type is (phs_wood_config_t) call phs_data%read_phs_file (exist, found, match) write (u, "(1x,A,L1)") "exist = ", exist write (u, "(1x,A,L1)") "found = ", found write (u, "(1x,A,L1)") "match = ", match end select write (u, "(A)") write (u, "(A)") "* Modify phs parameter and check MD5 sum" write (u, "(A)") call phs_data%final () deallocate (phs_data) allocate (phs_wood_config_t :: phs_data) process_data%md5sum = "1234567890abcdef1234567890abcdef" call phs_data%init (process_data, model) phs_par%sqrts = 1000 phs_par%off_shell = 17 select type (phs_data) type is (phs_wood_config_t) call phs_data%set_parameters (phs_par) phs_data%sqrts = phs_par%sqrts phs_data%par%sqrts = phs_par%sqrts end select call phs_data%compute_md5sum () write (u, "(1x,A,A,A)") "MD5 sum (process) = '", & phs_data%md5sum_process, "'" write (u, "(1x,A,A,A)") "MD5 sum (model par) = '", & phs_data%md5sum_model_par, "'" write (u, "(1x,A,A,A)") "MD5 sum (phs config) = '", & phs_data%md5sum_phs_config, "'" select type (phs_data) type is (phs_wood_config_t) call phs_data%read_phs_file (exist, found, match) write (u, "(1x,A,L1)") "exist = ", exist write (u, "(1x,A,L1)") "found = ", found write (u, "(1x,A,L1)") "match = ", match end select write (u, "(A)") write (u, "(A)") "* Modify model parameter and check MD5 sum" write (u, "(A)") call phs_data%final () deallocate (phs_data) allocate (phs_wood_config_t :: phs_data) call model%set_par (var_str ("ms"), 100._default) call phs_data%init (process_data, model) phs_par%sqrts = 1000 phs_par%off_shell = 1 select type (phs_data) type is (phs_wood_config_t) call phs_data%set_parameters (phs_par) phs_data%sqrts = phs_par%sqrts phs_data%par%sqrts = phs_par%sqrts end select call phs_data%compute_md5sum () write (u, "(1x,A,A,A)") "MD5 sum (process) = '", & phs_data%md5sum_process, "'" write (u, "(1x,A,A,A)") "MD5 sum (model par) = '", & phs_data%md5sum_model_par, "'" write (u, "(1x,A,A,A)") "MD5 sum (phs config) = '", & phs_data%md5sum_phs_config, "'" select type (phs_data) type is (phs_wood_config_t) call phs_data%read_phs_file (exist, found, match) write (u, "(1x,A,L1)") "exist = ", exist write (u, "(1x,A,L1)") "found = ", found write (u, "(1x,A,L1)") "match = ", match end select write (u, "(A)") write (u, "(A)") "* Cleanup" call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_wood_6" end subroutine phs_wood_6 @ %def phs_wood_6 @ <>= call test (phs_wood_vis_1, "phs_wood_vis_1", & "visualizing phase space channels", & u, results) <>= public :: phs_wood_vis_1 <>= subroutine phs_wood_vis_1 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_data_t), target :: model type(process_constants_t) :: process_data class(phs_config_t), allocatable :: phs_data type(mapping_defaults_t) :: mapping_defaults type(string_t) :: vis_file, pdf_file, ps_file real(default) :: sqrts logical :: exist, exist_pdf, exist_ps integer :: u_phs, iostat, u_vis character(95) :: buffer write (u, "(A)") "* Test output: phs_wood_vis_1" write (u, "(A)") "* Purpose: visualizing the & &phase-space configuration" write (u, "(A)") call os_data%init () call model%init_test () call syntax_phs_forest_init () write (u, "(A)") "* Initialize a process" write (u, "(A)") call init_test_process_data (var_str ("phs_wood_vis_1"), process_data) write (u, "(A)") "* Create a scratch phase-space file" write (u, "(A)") u_phs = free_unit () open (u_phs, status = "scratch", action = "readwrite") call write_test_phs_file (u_phs, var_str ("phs_wood_vis_1")) rewind (u_phs) do read (u_phs, "(A)", iostat = iostat) buffer if (iostat /= 0) exit write (u, "(A)") trim (buffer) end do write (u, "(A)") write (u, "(A)") "* Setup phase-space configuration object" write (u, "(A)") mapping_defaults%step_mapping = .false. allocate (phs_wood_config_t :: phs_data) call phs_data%init (process_data, model) select type (phs_data) type is (phs_wood_config_t) call phs_data%set_input (u_phs) call phs_data%set_mapping_defaults (mapping_defaults) phs_data%os_data = os_data phs_data%io_unit = 0 phs_data%io_unit_keep_open = .true. phs_data%vis_channels = .true. end select sqrts = 1000._default call phs_data%configure (sqrts) call phs_data%write (u) write (u, "(A)") select type (phs_data) type is (phs_wood_config_t) call phs_data%write_forest (u) end select vis_file = "phs_wood_vis_1.phs-vis.tex" ps_file = "phs_wood_vis_1.phs-vis.ps" pdf_file = "phs_wood_vis_1.phs-vis.pdf" inquire (file = char (vis_file), exist = exist) if (exist) then u_vis = free_unit () open (u_vis, file = char (vis_file), action = "read", status = "old") iostat = 0 do while (iostat == 0) read (u_vis, "(A)", iostat = iostat) buffer if (iostat == 0) write (u, "(A)") trim (buffer) end do close (u_vis) else write (u, "(A)") "[Visualize LaTeX file is missing]" end if inquire (file = char (ps_file), exist = exist_ps) if (exist_ps) then write (u, "(A)") "[Visualize Postscript file exists and is nonempty]" else write (u, "(A)") "[Visualize Postscript file is missing/non-regular]" end if inquire (file = char (pdf_file), exist = exist_pdf) if (exist_pdf) then write (u, "(A)") "[Visualize PDF file exists and is nonempty]" else write (u, "(A)") "[Visualize PDF file is missing/non-regular]" end if write (u, "(A)") write (u, "(A)") "* Cleanup" close (u_phs) call phs_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: phs_wood_vis_1" end subroutine phs_wood_vis_1 @ %def phs_wood_vis_1 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{The FKS phase space} <<[[phs_fks.f90]]>>= <> module phs_fks <> <> use constants use diagnostics use io_units, only: given_output_unit, free_unit use format_utils, only: write_separator use lorentz use physics_defs use flavors use pdg_arrays, only: is_colored use models, only: model_t use sf_mappings use sf_base use phs_base use resonances, only: resonance_contributors_t, resonance_history_t use phs_forests, only: phs_forest_final use phs_wood use cascades use cascades2 use process_constants use process_libraries use ttv_formfactors, only: generate_on_shell_decay_threshold, m1s_to_mpole <> <> <> <> <> contains <> end module phs_fks @ %def phs_fks @ @ A container for the $x_\oplus$- and $x_\ominus$-values for initial-state phase spaces. <>= public :: isr_kinematics_t <>= type :: isr_kinematics_t integer :: n_in real(default), dimension(2) :: x = one real(default), dimension(2) :: z = zero real(default), dimension(2) :: z_coll = zero real(default) :: sqrts_born = zero real(default) :: beam_energy = zero real(default) :: fac_scale = zero real(default), dimension(2) :: jacobian = one integer :: isr_mode = SQRTS_FIXED end type isr_kinematics_t @ %def type isr_kinematics_t @ <>= public :: phs_point_set_t <>= type :: phs_point_set_t type(phs_point_t), dimension(:), allocatable :: phs_point logical :: initialized = .false. contains <> end type phs_point_set_t @ %def phs_point_set_t @ <>= procedure :: init => phs_point_set_init <>= subroutine phs_point_set_init (phs_point_set, n_particles, n_phs) class(phs_point_set_t), intent(out) :: phs_point_set integer, intent(in) :: n_particles, n_phs integer :: i_phs allocate (phs_point_set%phs_point (n_phs)) do i_phs = 1, n_phs phs_point_set%phs_point(i_phs) = n_particles end do phs_point_set%initialized = .true. end subroutine phs_point_set_init @ %def phs_point_set_init @ <>= procedure :: write => phs_point_set_write <>= subroutine phs_point_set_write (phs_point_set, i_phs, contributors, unit, show_mass, & testflag, check_conservation, ultra, n_in) class(phs_point_set_t), intent(in) :: phs_point_set integer, intent(in), optional :: i_phs integer, intent(in), dimension(:), optional :: contributors integer, intent(in), optional :: unit logical, intent(in), optional :: show_mass logical, intent(in), optional :: testflag, ultra logical, intent(in), optional :: check_conservation integer, intent(in), optional :: n_in integer :: i, u type(vector4_t) :: p_sum u = given_output_unit (unit); if (u < 0) return if (present (i_phs)) then call phs_point_set%phs_point(i_phs)%write & (unit = u, show_mass = show_mass, testflag = testflag, & check_conservation = check_conservation, ultra = ultra, n_in = n_in) else do i = 1, size(phs_point_set%phs_point) call phs_point_set%phs_point(i)%write & (unit = u, show_mass = show_mass, testflag = testflag, & check_conservation = check_conservation, ultra = ultra, n_in = n_in) end do end if if (present (contributors)) then p_sum = vector4_null call msg_debug (D_SUBTRACTION, "Invariant masses for real emission: ") associate (p => phs_point_set%phs_point(i_phs)%p) do i = 1, size (contributors) p_sum = p_sum + p(contributors(i)) end do p_sum = p_sum + p(size(p)) end associate if (debug_active (D_SUBTRACTION)) & call vector4_write (p_sum, unit = unit, show_mass = show_mass, & testflag = testflag, ultra = ultra) end if end subroutine phs_point_set_write @ %def phs_point_set_write @ <>= procedure :: get_n_momenta => phs_point_set_get_n_momenta <>= elemental function phs_point_set_get_n_momenta (phs_point_set, i_res) result (n) integer :: n class(phs_point_set_t), intent(in) :: phs_point_set integer, intent(in) :: i_res n = phs_point_set%phs_point(i_res)%n_momenta end function phs_point_set_get_n_momenta @ %def phs_point_set_get_n_momenta @ <>= procedure :: get_momenta => phs_point_set_get_momenta <>= pure function phs_point_set_get_momenta (phs_point_set, i_phs, n_in) result (p) type(vector4_t), dimension(:), allocatable :: p class(phs_point_set_t), intent(in) :: phs_point_set integer, intent(in) :: i_phs integer, intent(in), optional :: n_in if (present (n_in)) then allocate (p (n_in), source = phs_point_set%phs_point(i_phs)%p(1:n_in)) else allocate (p (phs_point_set%phs_point(i_phs)%n_momenta), & source = phs_point_set%phs_point(i_phs)%p) end if end function phs_point_set_get_momenta @ %def phs_point_set_get_momenta @ <>= procedure :: get_momentum => phs_point_set_get_momentum <>= pure function phs_point_set_get_momentum (phs_point_set, i_phs, i_mom) result (p) type(vector4_t) :: p class(phs_point_set_t), intent(in) :: phs_point_set integer, intent(in) :: i_phs, i_mom p = phs_point_set%phs_point(i_phs)%p(i_mom) end function phs_point_set_get_momentum @ %def phs_point_set_get_momentum @ <>= procedure :: get_energy => phs_point_set_get_energy <>= pure function phs_point_set_get_energy (phs_point_set, i_phs, i_mom) result (E) real(default) :: E class(phs_point_set_t), intent(in) :: phs_point_set integer, intent(in) :: i_phs, i_mom E = phs_point_set%phs_point(i_phs)%p(i_mom)%p(0) end function phs_point_set_get_energy @ %def phs_point_set_get_energy @ <>= procedure :: get_sqrts => phs_point_set_get_sqrts <>= function phs_point_set_get_sqrts (phs_point_set, i_phs) result (sqrts) real(default) :: sqrts class(phs_point_set_t), intent(in) :: phs_point_set integer, intent(in) :: i_phs associate (p => phs_point_set%phs_point(i_phs)%p) sqrts = (p(1) + p(2))**1 end associate end function phs_point_set_get_sqrts @ %def phs_point_set_get_sqrts @ <>= generic :: set_momenta => set_momenta_p, set_momenta_phs_point procedure :: set_momenta_p => phs_point_set_set_momenta_p <>= subroutine phs_point_set_set_momenta_p (phs_point_set, i_phs, p) class(phs_point_set_t), intent(inout) :: phs_point_set integer, intent(in) :: i_phs type(vector4_t), intent(in), dimension(:) :: p phs_point_set%phs_point(i_phs)%p = p end subroutine phs_point_set_set_momenta_p @ %def phs_point_set_set_momenta_p @ <>= procedure :: set_momenta_phs_point => phs_point_set_set_momenta_phs_point <>= subroutine phs_point_set_set_momenta_phs_point (phs_point_set, i_phs, p) class(phs_point_set_t), intent(inout) :: phs_point_set integer, intent(in) :: i_phs type(phs_point_t), intent(in) :: p phs_point_set%phs_point(i_phs) = p end subroutine phs_point_set_set_momenta_phs_point @ %def phs_point_set_set_momenta_phs_point @ <>= procedure :: get_n_particles => phs_point_set_get_n_particles <>= function phs_point_set_get_n_particles (phs_point_set, i) result (n_particles) integer :: n_particles class(phs_point_set_t), intent(in) :: phs_point_set integer, intent(in), optional :: i integer :: j j = 1; if (present (i)) j = i n_particles = size (phs_point_set%phs_point(j)%p) end function phs_point_set_get_n_particles @ %def phs_point_set_get_n_particles @ <>= procedure :: get_n_phs => phs_point_set_get_n_phs <>= function phs_point_set_get_n_phs (phs_point_set) result (n_phs) integer :: n_phs class(phs_point_set_t), intent(in) :: phs_point_set n_phs = size (phs_point_set%phs_point) end function phs_point_set_get_n_phs @ %def phs_point_set_get_n_phs @ <>= procedure :: get_invariant_mass => phs_point_set_get_invariant_mass <>= function phs_point_set_get_invariant_mass (phs_point_set, i_phs, i_part) result (m2) real(default) :: m2 class(phs_point_set_t), intent(in) :: phs_point_set integer, intent(in) :: i_phs integer, intent(in), dimension(:) :: i_part type(vector4_t) :: p integer :: i p = vector4_null do i = 1, size (i_part) p = p + phs_point_set%phs_point(i_phs)%p(i_part(i)) end do m2 = p**2 end function phs_point_set_get_invariant_mass @ %def phs_point_set_get_invariant_mass @ <>= procedure :: write_phs_point => phs_point_set_write_phs_point <>= subroutine phs_point_set_write_phs_point (phs_point_set, i_phs, unit, show_mass, & testflag, check_conservation, ultra, n_in) class(phs_point_set_t), intent(in) :: phs_point_set integer, intent(in) :: i_phs integer, intent(in), optional :: unit logical, intent(in), optional :: show_mass logical, intent(in), optional :: testflag, ultra logical, intent(in), optional :: check_conservation integer, intent(in), optional :: n_in call phs_point_set%phs_point(i_phs)%write (unit, show_mass, testflag, & check_conservation, ultra, n_in) end subroutine phs_point_set_write_phs_point @ %def phs_point_set_write_phs_point @ <>= procedure :: final => phs_point_set_final <>= subroutine phs_point_set_final (phs_point_set) class(phs_point_set_t), intent(inout) :: phs_point_set integer :: i do i = 1, size (phs_point_set%phs_point) call phs_point_set%phs_point(i)%final () end do deallocate (phs_point_set%phs_point) phs_point_set%initialized = .false. end subroutine phs_point_set_final @ %def phs_point_set_final @ <>= public :: real_jacobian_t <>= type :: real_jacobian_t real(default), dimension(4) :: jac = 1._default end type real_jacobian_t @ %def real_jacobian_t @ <>= public :: real_kinematics_t <>= type :: real_kinematics_t logical :: supply_xi_max = .true. real(default) :: xi_tilde real(default) :: phi real(default), dimension(:), allocatable :: xi_max, y real(default) :: xi_mismatch, y_mismatch type(real_jacobian_t), dimension(:), allocatable :: jac real(default) :: jac_mismatch type(phs_point_set_t) :: p_born_cms type(phs_point_set_t) :: p_born_lab type(phs_point_set_t) :: p_real_cms type(phs_point_set_t) :: p_real_lab type(phs_point_set_t) :: p_born_onshell type(phs_point_set_t), dimension(2) :: p_real_onshell integer, dimension(:), allocatable :: alr_to_i_phs real(default), dimension(3) :: x_rad real(default), dimension(:), allocatable :: jac_rand real(default), dimension(:), allocatable :: y_soft real(default) :: cms_energy2 type(vector4_t), dimension(:), allocatable :: xi_ref_momenta contains <> end type real_kinematics_t @ %def real_kinematics_t @ <>= procedure :: init => real_kinematics_init <>= subroutine real_kinematics_init (r, n_tot, n_phs, n_alr, n_contr) class(real_kinematics_t), intent(inout) :: r integer, intent(in) :: n_tot, n_phs, n_alr, n_contr allocate (r%xi_max (n_phs)) allocate (r%y (n_phs)) allocate (r%y_soft (n_phs)) call r%p_born_cms%init (n_tot - 1, 1) call r%p_born_lab%init (n_tot - 1, 1) call r%p_real_cms%init (n_tot, n_phs) call r%p_real_lab%init (n_tot, n_phs) allocate (r%jac (n_phs), r%jac_rand (n_phs)) allocate (r%alr_to_i_phs (n_alr)) allocate (r%xi_ref_momenta (n_contr)) r%alr_to_i_phs = 0 r%xi_tilde = zero; r%xi_mismatch = zero r%xi_max = zero r%y = zero; r%y_mismatch = zero r%y_soft = zero r%phi = zero r%cms_energy2 = zero r%xi_ref_momenta = vector4_null r%jac_mismatch = one r%jac_rand = one end subroutine real_kinematics_init @ %def real_kinematics_init @ <>= procedure :: init_onshell => real_kinematics_init_onshell <>= subroutine real_kinematics_init_onshell (r, n_tot, n_phs) class(real_kinematics_t), intent(inout) :: r integer, intent(in) :: n_tot, n_phs call r%p_born_onshell%init (n_tot - 1, 1) call r%p_real_onshell(1)%init (n_tot, n_phs) call r%p_real_onshell(2)%init (n_tot, n_phs) end subroutine real_kinematics_init_onshell @ %def real_kinematics_init_onshell @ <>= procedure :: write => real_kinematics_write <>= subroutine real_kinematics_write (r, unit) class(real_kinematics_t), intent(in) :: r integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u,"(A)") "Real kinematics: " write (u,"(A,F5.3)") "xi_tilde: ", r%xi_tilde write (u,"(A,F5.3)") "phi: ", r%phi do i = 1, size (r%xi_max) write (u,"(A,I1,1X)") "i_phs: ", i write (u,"(A,100F5.3,1X)") "xi_max: ", r%xi_max(i) write (u,"(A,100F5.3,1X)") "y: ", r%y(i) write (u,"(A,100F5.3,1X)") "jac_rand: ", r%jac_rand(i) write (u,"(A,100F5.3,1X)") "y_soft: ", r%y_soft(i) end do write (u, "(A)") "Born Momenta: " write (u, "(A)") "CMS: " call r%p_born_cms%write (unit = u) write (u, "(A)") "Lab: " call r%p_born_lab%write (unit = u) write (u, "(A)") "Real Momenta: " write (u, "(A)") "CMS: " call r%p_real_cms%write (unit = u) write (u, "(A)") "Lab: " call r%p_real_lab%write (unit = u) end subroutine real_kinematics_write @ %def real_kinematics_write @ The boost to the center-of-mass system only has a reasonable meaning above the threshold. Below the threshold, we do not apply boost at all, so that the top quarks stay in the rest frame. However, with top quarks exactly at rest, problems arise in the matrix elements (e.g. in the computation of angles). Therefore, we apply a boost which is not exactly 1, but has a tiny value differing from that. <>= public :: get_boost_for_threshold_projection <>= function get_boost_for_threshold_projection (p, sqrts, mtop) result (L) type(lorentz_transformation_t) :: L type(vector4_t), intent(in), dimension(:) :: p real(default), intent(in) :: sqrts, mtop type(vector4_t) :: p_tmp type(vector3_t) :: dir real(default) :: scale_factor, arg p_tmp = p(THR_POS_WP) + p(THR_POS_B) arg = sqrts**2 - four * mtop**2 if (arg > zero) then scale_factor = sqrt (arg) / two else scale_factor = tiny_07*1000 end if dir = scale_factor * create_unit_vector (p_tmp) p_tmp = [sqrts / two, dir%p] L = boost (p_tmp, mtop) end function get_boost_for_threshold_projection @ %def get_boost_for_threshold_projection @ This routine recomputes the value of $\phi$ used to generate the real phase space. <>= function get_generation_phi (p_born, p_real, emitter, i_gluon) result (phi) real(default) :: phi type(vector4_t), intent(in), dimension(:) :: p_born, p_real integer, intent(in) :: emitter, i_gluon type(vector4_t) :: p1, p2, pp type(lorentz_transformation_t) :: rot_to_gluon, rot_to_z type(vector3_t) :: dir, z real(default) :: cpsi pp = p_real(emitter) + p_real(i_gluon) cpsi = (space_part_norm (pp)**2 - space_part_norm (p_real(emitter))**2 & + space_part_norm (p_real(i_gluon))**2) / & (two * space_part_norm (pp) * space_part_norm (p_real(i_gluon))) dir = create_orthogonal (space_part (p_born(emitter))) rot_to_gluon = rotation (cpsi, sqrt (one - cpsi**2), dir) pp = rot_to_gluon * p_born(emitter) z%p = [0, 0, 1] rot_to_z = rotation_to_2nd & (space_part (p_born(emitter)) / space_part_norm (p_born(emitter)), z) p1 = rot_to_z * pp / space_part_norm (pp) p2 = rot_to_z * p_real(i_gluon) phi = azimuthal_distance (p1, p2) if (phi < zero) phi = twopi - abs(phi) end function get_generation_phi @ %def get_generation_phi @ <>= procedure :: apply_threshold_projection_real => real_kinematics_apply_threshold_projection_real <>= subroutine real_kinematics_apply_threshold_projection_real (r, i_phs, mtop, L_to_cms, invert) class(real_kinematics_t), intent(inout) :: r integer, intent(in) :: i_phs real(default), intent(in) :: mtop type(lorentz_transformation_t), intent(in), dimension(:) :: L_to_cms logical, intent(in) :: invert integer :: leg, other_leg type(vector4_t), dimension(4) :: k_tmp type(vector4_t), dimension(4) :: k_decay_onshell_real type(vector4_t), dimension(3) :: k_decay_onshell_born do leg = 1, 2 other_leg = 3 - leg associate (p_real => r%p_real_cms%phs_point(i_phs)%p, & p_real_onshell => r%p_real_onshell(leg)%phs_point(i_phs)%p) p_real_onshell(1:2) = p_real(1:2) k_tmp(1) = p_real(7) k_tmp(2) = p_real(ass_quark(leg)) k_tmp(3) = p_real(ass_boson(leg)) k_tmp(4) = [mtop, zero, zero, zero] call generate_on_shell_decay_threshold (k_tmp(1:3), & k_tmp(4), k_decay_onshell_real (2:4)) k_decay_onshell_real (1) = k_tmp(4) k_tmp(1) = p_real(ass_quark(other_leg)) k_tmp(2) = p_real(ass_boson(other_leg)) k_decay_onshell_born = create_two_particle_decay (mtop**2, k_tmp(1), k_tmp(2)) p_real_onshell(THR_POS_GLUON) = L_to_cms(leg) * k_decay_onshell_real (2) p_real_onshell(ass_quark(leg)) = L_to_cms(leg) * k_decay_onshell_real(3) p_real_onshell(ass_boson(leg)) = L_to_cms(leg) * k_decay_onshell_real(4) p_real_onshell(ass_quark(other_leg)) = L_to_cms(leg) * k_decay_onshell_born (2) p_real_onshell(ass_boson(other_leg)) = L_to_cms(leg) * k_decay_onshell_born (3) if (invert) then call vector4_invert_direction (p_real_onshell (ass_quark(other_leg))) call vector4_invert_direction (p_real_onshell (ass_boson(other_leg))) end if end associate end do end subroutine real_kinematics_apply_threshold_projection_real @ %def real_kinematics_apply_threshold_projection_real @ <>= public :: threshold_projection_born <>= subroutine threshold_projection_born (mtop, L_to_cms, p_in, p_onshell) real(default), intent(in) :: mtop type(lorentz_transformation_t), intent(in) :: L_to_cms type(vector4_t), intent(in), dimension(:) :: p_in type(vector4_t), intent(out), dimension(:) :: p_onshell type(vector4_t), dimension(3) :: k_decay_onshell type(vector4_t) :: p_tmp_1, p_tmp_2 type(lorentz_transformation_t) :: L_to_cms_inv p_onshell(1:2) = p_in(1:2) L_to_cms_inv = inverse (L_to_cms) p_tmp_1 = L_to_cms_inv * p_in(THR_POS_B) p_tmp_2 = L_to_cms_inv * p_in(THR_POS_WP) k_decay_onshell = create_two_particle_decay (mtop**2, & p_tmp_1, p_tmp_2) p_onshell([THR_POS_B, THR_POS_WP]) = k_decay_onshell([2, 3]) p_tmp_1 = L_to_cms * p_in(THR_POS_BBAR) p_tmp_2 = L_to_cms * p_in(THR_POS_WM) k_decay_onshell = create_two_particle_decay (mtop**2, & p_tmp_1, p_tmp_2) p_onshell([THR_POS_BBAR, THR_POS_WM]) = k_decay_onshell([2, 3]) p_onshell([THR_POS_WP, THR_POS_B]) = L_to_cms * p_onshell([THR_POS_WP, THR_POS_B]) p_onshell([THR_POS_WM, THR_POS_BBAR]) = L_to_cms_inv * p_onshell([THR_POS_WM, THR_POS_BBAR]) end subroutine threshold_projection_born @ %def threshold_projection_born @ This routine computes the bounds of the Dalitz region for massive emitters, see below. It is also used by [[Powheg]], so the routine is public. The input parameter [[m2]] corresponds to the squared mass of the emitter and [[p]] is the four-momentum of the emitter. <>= public :: compute_dalitz_bounds <>= pure subroutine compute_dalitz_bounds (q0, m2, mrec2, z1, z2, k0_rec_max) real(default), intent(in) :: q0, m2, mrec2 real(default), intent(out) :: z1, z2, k0_rec_max k0_rec_max = (q0**2 - m2 + mrec2) / (two * q0) z1 = (k0_rec_max + sqrt(k0_rec_max**2 - mrec2)) / q0 z2 = (k0_rec_max - sqrt(k0_rec_max**2 - mrec2)) / q0 end subroutine compute_dalitz_bounds @ %def compute_dalitz_bounds @ Compute the [[kt2]] of a given emitter <>= procedure :: kt2 => real_kinematics_kt2 <>= function real_kinematics_kt2 & (real_kinematics, i_phs, emitter, kt2_type, xi, y) result (kt2) real(default) :: kt2 class(real_kinematics_t), intent(in) :: real_kinematics integer, intent(in) :: emitter, i_phs, kt2_type real(default), intent(in), optional :: xi, y real(default) :: xii, yy real(default) :: q, E_em, z, z1, z2, m2, mrec2, k0_rec_max type(vector4_t) :: p_emitter if (present (y)) then yy = y else yy = real_kinematics%y (i_phs) end if if (present (xi)) then xii = xi else xii = real_kinematics%xi_tilde * real_kinematics%xi_max (i_phs) end if select case (kt2_type) case (FSR_SIMPLE) kt2 = real_kinematics%cms_energy2 / two * xii**2 * (1 - yy) case (FSR_MASSIVE) q = sqrt (real_kinematics%cms_energy2) p_emitter = real_kinematics%p_born_cms%phs_point(1)%p(emitter) mrec2 = (q - p_emitter%p(0))**2 - sum (p_emitter%p(1:3)**2) m2 = p_emitter**2 E_em = energy (p_emitter) call compute_dalitz_bounds (q, m2, mrec2, z1, z2, k0_rec_max) z = z2 - (z2 - z1) * (one + yy) / two kt2 = xii**2 * q**3 * (one - z) / & (two * E_em - z * xii * q) case (FSR_MASSLESS_RECOILER) kt2 = real_kinematics%cms_energy2 / two * xii**2 * (1 - yy**2) / two case default kt2 = zero call msg_bug ("kt2_type must be set to a known value") end select end function real_kinematics_kt2 @ %def real_kinematics_kt2 @ <>= integer, parameter, public :: FSR_SIMPLE = 1 integer, parameter, public :: FSR_MASSIVE = 2 integer, parameter, public :: FSR_MASSLESS_RECOILER = 3 @ %def FSR_SIMPLE FSR_MASSIVE FSR_MASSLESS_RECOILER @ <>= procedure :: final => real_kinematics_final <>= subroutine real_kinematics_final (real_kin) class(real_kinematics_t), intent(inout) :: real_kin if (allocated (real_kin%xi_max)) deallocate (real_kin%xi_max) if (allocated (real_kin%y)) deallocate (real_kin%y) if (allocated (real_kin%alr_to_i_phs)) deallocate (real_kin%alr_to_i_phs) if (allocated (real_kin%jac_rand)) deallocate (real_kin%jac_rand) if (allocated (real_kin%y_soft)) deallocate (real_kin%y_soft) if (allocated (real_kin%xi_ref_momenta)) deallocate (real_kin%xi_ref_momenta) call real_kin%p_born_cms%final (); call real_kin%p_born_lab%final () call real_kin%p_real_cms%final (); call real_kin%p_real_lab%final () end subroutine real_kinematics_final @ %def real_kinematics_final @ <>= integer, parameter, public :: I_XI = 1 integer, parameter, public :: I_Y = 2 integer, parameter, public :: I_PHI = 3 integer, parameter, public :: PHS_MODE_UNDEFINED = 0 integer, parameter, public :: PHS_MODE_ADDITIONAL_PARTICLE = 1 integer, parameter, public :: PHS_MODE_COLLINEAR_REMNANT = 2 @ %def parameters @ <>= public :: phs_fks_config_t <>= type, extends (phs_wood_config_t) :: phs_fks_config_t integer :: mode = PHS_MODE_UNDEFINED character(32) :: md5sum_born_config logical :: make_dalitz_plot = .false. contains <> end type phs_fks_config_t @ %def phs_fks_config_t @ <>= procedure :: clear_phase_space => fks_config_clear_phase_space <>= subroutine fks_config_clear_phase_space (phs_config) class(phs_fks_config_t), intent(inout) :: phs_config end subroutine fks_config_clear_phase_space @ %def fks_config_clear_phase_space @ <>= procedure :: write => phs_fks_config_write <>= subroutine phs_fks_config_write (object, unit, include_id) class(phs_fks_config_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: include_id integer :: u u = given_output_unit (unit) call object%phs_wood_config_t%write (u) write (u, "(A,A)") "Extra Born md5sum: ", object%md5sum_born_config end subroutine phs_fks_config_write @ %def phs_fks_config_write @ <>= procedure :: set_mode => phs_fks_config_set_mode <>= subroutine phs_fks_config_set_mode (phs_config, mode) class(phs_fks_config_t), intent(inout) :: phs_config integer, intent(in) :: mode select case (mode) case (NLO_REAL, NLO_MISMATCH) phs_config%mode = PHS_MODE_ADDITIONAL_PARTICLE case (NLO_DGLAP) phs_config%mode = PHS_MODE_COLLINEAR_REMNANT end select end subroutine phs_fks_config_set_mode @ %def phs_fks_config_set_mod @ <>= procedure :: configure => phs_fks_config_configure <>= subroutine phs_fks_config_configure (phs_config, sqrts, & sqrts_fixed, cm_frame, azimuthal_dependence, rebuild, & ignore_mismatch, nlo_type, subdir) class(phs_fks_config_t), intent(inout) :: phs_config real(default), intent(in) :: sqrts logical, intent(in), optional :: sqrts_fixed logical, intent(in), optional :: cm_frame logical, intent(in), optional :: azimuthal_dependence logical, intent(in), optional :: rebuild logical, intent(in), optional :: ignore_mismatch integer, intent(in), optional :: nlo_type type(string_t), intent(in), optional :: subdir if (phs_config%extension_mode == EXTENSION_NONE) then select case (phs_config%mode) case (PHS_MODE_ADDITIONAL_PARTICLE) phs_config%n_par = phs_config%n_par + 3 case (PHS_MODE_COLLINEAR_REMNANT) phs_config%n_par = phs_config%n_par + 1 end select end if !!! Channel equivalences not accessible yet phs_config%provides_equivalences = .false. call phs_config%compute_md5sum () end subroutine phs_fks_config_configure @ %def phs_fks_config_configure @ <>= procedure :: startup_message => phs_fks_config_startup_message <>= subroutine phs_fks_config_startup_message (phs_config, unit) class(phs_fks_config_t), intent(in) :: phs_config integer, intent(in), optional :: unit call phs_config%phs_wood_config_t%startup_message (unit) end subroutine phs_fks_config_startup_message @ %def phs_fks_config_startup_message @ <>= procedure, nopass :: allocate_instance => phs_fks_config_allocate_instance <>= subroutine phs_fks_config_allocate_instance (phs) class(phs_t), intent(inout), pointer :: phs allocate (phs_fks_t :: phs) end subroutine phs_fks_config_allocate_instance @ %def phs_fks_config_allocate_instance @ If the phase space is generated from file, but we want to have resonance histories, we must force the cascade sets to be generated. However, it must be assured that Born flavors are used for this. <>= procedure :: generate_phase_space_extra => phs_fks_config_generate_phase_space_extra <>= subroutine phs_fks_config_generate_phase_space_extra (phs_config) class(phs_fks_config_t), intent(inout) :: phs_config integer :: off_shell, extra_off_shell type(flavor_t), dimension(:,:), allocatable :: flv_born integer :: i, j integer :: n_state, n_flv_born integer :: unit_fds logical :: valid type(string_t) :: file_name logical :: file_exists if (phs_config%use_cascades2) then allocate (phs_config%feyngraph_set) else allocate (phs_config%cascade_set) end if n_flv_born = size (phs_config%flv, 1) - 1 n_state = size (phs_config%flv, 2) allocate (flv_born (n_flv_born, n_state)) do i = 1, n_flv_born do j = 1, n_state flv_born(i, j) = phs_config%flv(i, j) end do end do if (phs_config%use_cascades2) then file_name = char (phs_config%id) // ".fds" inquire (file=char (file_name), exist=file_exists) if (.not. file_exists) call msg_fatal & ("The O'Mega input file " // char (file_name) // & " does not exist. " // "Please make sure that the " // & "variable ?omega_write_phs_output has been set correctly.") unit_fds = free_unit () open (unit=unit_fds, file=char(file_name), status='old', action='read') end if off_shell = phs_config%par%off_shell do extra_off_shell = 0, max (n_flv_born - 2, 0) phs_config%par%off_shell = off_shell + extra_off_shell if (phs_config%use_cascades2) then call feyngraph_set_generate (phs_config%feyngraph_set, & phs_config%model, phs_config%n_in, phs_config%n_out - 1, & flv_born, phs_config%par, phs_config%fatal_beam_decay, unit_fds, & phs_config%vis_channels) if (feyngraph_set_is_valid (phs_config%feyngraph_set)) exit else call cascade_set_generate (phs_config%cascade_set, & phs_config%model, phs_config%n_in, phs_config%n_out - 1, & flv_born, phs_config%par, phs_config%fatal_beam_decay) if (cascade_set_is_valid (phs_config%cascade_set)) exit end if end do if (phs_config%use_cascades2) then close (unit_fds) valid = feyngraph_set_is_valid (phs_config%feyngraph_set) else valid = cascade_set_is_valid (phs_config%cascade_set) end if if (.not. valid) & call msg_fatal ("Resonance extraction: Phase space generation failed") end subroutine phs_fks_config_generate_phase_space_extra @ %def phs_fks_config_generate_phase_space_extra @ <>= procedure :: set_born_config => phs_fks_config_set_born_config <>= subroutine phs_fks_config_set_born_config (phs_config, phs_cfg_born) class(phs_fks_config_t), intent(inout) :: phs_config type(phs_wood_config_t), intent(in), target :: phs_cfg_born call msg_debug (D_PHASESPACE, "phs_fks_config_set_born_config") phs_config%forest = phs_cfg_born%forest phs_config%n_channel = phs_cfg_born%n_channel allocate (phs_config%channel (phs_config%n_channel)) phs_config%channel = phs_cfg_born%channel phs_config%n_par = phs_cfg_born%n_par phs_config%n_state = phs_cfg_born%n_state phs_config%sqrts = phs_cfg_born%sqrts phs_config%par = phs_cfg_born%par phs_config%sqrts_fixed = phs_cfg_born%sqrts_fixed phs_config%azimuthal_dependence = phs_cfg_born%azimuthal_dependence phs_config%provides_chains = phs_cfg_born%provides_chains phs_config%cm_frame = phs_cfg_born%cm_frame phs_config%vis_channels = phs_cfg_born%vis_channels allocate (phs_config%chain (size (phs_cfg_born%chain))) phs_config%chain = phs_cfg_born%chain phs_config%model => phs_cfg_born%model phs_config%use_cascades2 = phs_cfg_born%use_cascades2 if (allocated (phs_cfg_born%cascade_set)) then allocate (phs_config%cascade_set) phs_config%cascade_set = phs_cfg_born%cascade_set end if if (allocated (phs_cfg_born%feyngraph_set)) then allocate (phs_config%feyngraph_set) phs_config%feyngraph_set = phs_cfg_born%feyngraph_set end if phs_config%md5sum_born_config = phs_cfg_born%md5sum_phs_config end subroutine phs_fks_config_set_born_config @ %def phs_fks_config_set_born_config @ <>= procedure :: get_resonance_histories => phs_fks_config_get_resonance_histories <>= function phs_fks_config_get_resonance_histories (phs_config) result (resonance_histories) type(resonance_history_t), dimension(:), allocatable :: resonance_histories class(phs_fks_config_t), intent(inout) :: phs_config if (allocated (phs_config%cascade_set)) then call cascade_set_get_resonance_histories & (phs_config%cascade_set, n_filter = 2, res_hists = resonance_histories) else if (allocated (phs_config%feyngraph_set)) then call feyngraph_set_get_resonance_histories & (phs_config%feyngraph_set, n_filter = 2, res_hists = resonance_histories) else call msg_debug (D_PHASESPACE, "Have to rebuild phase space for resonance histories") call phs_config%generate_phase_space_extra () if (phs_config%use_cascades2) then call feyngraph_set_get_resonance_histories & (phs_config%feyngraph_set, n_filter = 2, res_hists = resonance_histories) else call cascade_set_get_resonance_histories & (phs_config%cascade_set, n_filter = 2, res_hists = resonance_histories) end if end if end function phs_fks_config_get_resonance_histories @ %def phs_fks_config_get_resonance_histories @ <>= public :: dalitz_plot_t <>= type :: dalitz_plot_t integer :: unit = -1 type(string_t) :: filename logical :: active = .false. logical :: inverse = .false. contains <> end type dalitz_plot_t @ %def dalitz_plot_t @ <>= procedure :: init => dalitz_plot_init <>= subroutine dalitz_plot_init (plot, unit, filename, inverse) class(dalitz_plot_t), intent(inout) :: plot integer, intent(in) :: unit type(string_t), intent(in) :: filename logical, intent(in) :: inverse plot%active = .true. plot%unit = unit plot%inverse = inverse open (plot%unit, file = char (filename), action = "write") end subroutine dalitz_plot_init @ %def daltiz_plot_init @ <>= procedure :: write_header => dalitz_plot_write_header <>= subroutine dalitz_plot_write_header (plot) class(dalitz_plot_t), intent(in) :: plot write (plot%unit, "(A36)") "### Dalitz plot generated by WHIZARD" if (plot%inverse) then write (plot%unit, "(A10,1x,A4)") "### k0_n+1", "k0_n" else write (plot%unit, "(A8,1x,A6)") "### k0_n", "k0_n+1" end if end subroutine dalitz_plot_write_header @ %def dalitz_plot_write_header @ <>= procedure :: register => dalitz_plot_register <>= subroutine dalitz_plot_register (plot, k0_n, k0_np1) class(dalitz_plot_t), intent(in) :: plot real(default), intent(in) :: k0_n, k0_np1 if (plot%inverse) then write (plot%unit, "(F8.4,1X,F8.4)") k0_np1, k0_n else write (plot%unit, "(F8.4,1X,F8.4)") k0_np1, k0_n end if end subroutine dalitz_plot_register @ %def dalitz_plot_register @ <>= procedure :: final => dalitz_plot_final <>= subroutine dalitz_plot_final (plot) class(dalitz_plot_t), intent(inout) :: plot logical :: opened plot%active = .false. plot%inverse = .false. if (plot%unit >= 0) then inquire (unit = plot%unit, opened = opened) if (opened) close (plot%unit) end if plot%filename = var_str ('') plot%unit = -1 end subroutine dalitz_plot_final @ %def dalitz_plot_final @ <>= integer, parameter, public :: GEN_REAL_PHASE_SPACE = 1 integer, parameter, public :: GEN_SOFT_MISMATCH = 2 integer, parameter, public :: GEN_SOFT_LIMIT_TEST = 3 integer, parameter, public :: GEN_COLL_LIMIT_TEST = 4 integer, parameter, public :: GEN_ANTI_COLL_LIMIT_TEST = 5 integer, parameter, public :: GEN_SOFT_COLL_LIMIT_TEST = 6 integer, parameter, public :: GEN_SOFT_ANTI_COLL_LIMIT_TEST = 7 integer, parameter, public :: SQRTS_FIXED = 1 integer, parameter, public :: SQRTS_VAR = 2 real(default), parameter :: xi_tilde_test_soft = 0.0001_default real(default), parameter :: xi_tilde_test_coll = 0.5_default real(default), parameter :: y_test_soft = 0.5_default real(default), parameter :: y_test_coll = 0.999999_default @ @ Very soft or collinear phase-space points can become a problem for matrix elements providers, as some scalar products cannot be evaluated properly. Here, a nonsensical result can spoil the whole integration. We therefore check the scalar products appearing to be below a certain tolerance. <>= public :: check_scalar_products <>= function check_scalar_products (p) result (valid) logical :: valid type(vector4_t), intent(in), dimension(:) :: p real(default), parameter :: tolerance = 1E-6_default integer :: i, j valid = .true. do i = 1, size (p) do j = i, size (p) if (i /= j) then if (abs(p(i) * p(j)) < tolerance) then valid = .false. exit end if end if end do end do end function check_scalar_products @ %def check_scalar_products @ [[xi_min]] should be set to a non-zero value in order to avoid phase-space points with [[p_real(emitter) = 0]]. <>= public :: phs_fks_generator_t <>= type :: phs_fks_generator_t integer, dimension(:), allocatable :: emitters type(real_kinematics_t), pointer :: real_kinematics => null() type(isr_kinematics_t), pointer :: isr_kinematics => null() integer :: n_in real(default) :: xi_min = tiny_07 real(default) :: y_max = one real(default) :: sqrts real(default) :: E_gluon real(default) :: mrec2 real(default), dimension(:), allocatable :: m2 logical :: massive_phsp = .false. logical, dimension(:), allocatable :: is_massive logical :: singular_jacobian = .false. integer :: i_fsr_first = -1 type(resonance_contributors_t), dimension(:), allocatable :: resonance_contributors !!! Put somewhere else? integer :: mode = GEN_REAL_PHASE_SPACE contains <> end type phs_fks_generator_t @ %def phs_fks_generator_t @ <>= procedure :: connect_kinematics => phs_fks_generator_connect_kinematics <>= subroutine phs_fks_generator_connect_kinematics & (generator, isr_kinematics, real_kinematics, massive_phsp) class(phs_fks_generator_t), intent(inout) :: generator type(isr_kinematics_t), intent(in), pointer :: isr_kinematics type(real_kinematics_t), intent(in), pointer :: real_kinematics logical, intent(in) :: massive_phsp generator%real_kinematics => real_kinematics generator%isr_kinematics => isr_kinematics generator%massive_phsp = massive_phsp end subroutine phs_fks_generator_connect_kinematics @ %def phs_fks_generator_connect_kinematics @ <>= procedure :: compute_isr_kinematics => phs_fks_generator_compute_isr_kinematics <>= subroutine phs_fks_generator_compute_isr_kinematics (generator, r, p_in) class(phs_fks_generator_t), intent(inout) :: generator real(default), intent(in) :: r type(vector4_t), dimension(2), intent(in), optional :: p_in integer :: em type(vector4_t), dimension(2) :: p if (present (p_in)) then p = p_in else p = generator%real_kinematics%p_born_lab%phs_point(1)%p(1:2) end if associate (isr => generator%isr_kinematics) do em = 1, 2 isr%x(em) = p(em)%p(0) / isr%beam_energy isr%z(em) = one - (one - isr%x(em)) * r isr%jacobian(em) = one - isr%x(em) end do isr%sqrts_born = (p(1) + p(2))**1 end associate end subroutine phs_fks_generator_compute_isr_kinematics @ %def phs_fks_generator_compute_isr_kinematics @ <>= procedure :: final => phs_fks_generator_final <>= subroutine phs_fks_generator_final (generator) class(phs_fks_generator_t), intent(inout) :: generator if (allocated (generator%emitters)) deallocate (generator%emitters) if (associated (generator%real_kinematics)) nullify (generator%real_kinematics) if (associated (generator%isr_kinematics)) nullify (generator%isr_kinematics) if (allocated (generator%m2)) deallocate (generator%m2) generator%massive_phsp = .false. if (allocated (generator%is_massive)) deallocate (generator%is_massive) generator%singular_jacobian = .false. generator%i_fsr_first = -1 if (allocated (generator%resonance_contributors)) & deallocate (generator%resonance_contributors) generator%mode = GEN_REAL_PHASE_SPACE end subroutine phs_fks_generator_final @ %def phs_fks_generator_final @ A resonance phase space is uniquely specified via the resonance contributors and the corresponding emitters. The [[phs_identifier]] type also checks whether the given contributor-emitter configuration has already been evaluated to avoid duplicate computations. <>= public :: phs_identifier_t <>= type :: phs_identifier_t integer, dimension(:), allocatable :: contributors integer :: emitter = -1 logical :: evaluated = .false. contains <> end type phs_identifier_t @ %def phs_identifier_t @ <>= generic :: init => init_from_emitter, init_from_emitter_and_contributors procedure :: init_from_emitter => phs_identifier_init_from_emitter procedure :: init_from_emitter_and_contributors & => phs_identifier_init_from_emitter_and_contributors <>= subroutine phs_identifier_init_from_emitter (phs_id, emitter) class(phs_identifier_t), intent(out) :: phs_id integer, intent(in) :: emitter phs_id%emitter = emitter end subroutine phs_identifier_init_from_emitter subroutine phs_identifier_init_from_emitter_and_contributors & (phs_id, emitter, contributors) class(phs_identifier_t), intent(out) :: phs_id integer, intent(in) :: emitter integer, intent(in), dimension(:) :: contributors allocate (phs_id%contributors (size (contributors))) phs_id%contributors = contributors phs_id%emitter = emitter end subroutine phs_identifier_init_from_emitter_and_contributors @ %def phs_identifier_init_from_emitter @ %def phs_identifier_init_from_emitter_and_contributors @ <>= procedure :: check => phs_identifier_check <>= function phs_identifier_check (phs_id, emitter, contributors) result (check) logical :: check class(phs_identifier_t), intent(in) :: phs_id integer, intent(in) :: emitter integer, intent(in), dimension(:), optional :: contributors check = phs_id%emitter == emitter if (present (contributors)) then if (.not. allocated (phs_id%contributors)) & call msg_fatal ("Phs identifier: contributors not allocated!") check = check .and. all (phs_id%contributors == contributors) end if end function phs_identifier_check @ %def phs_identifier_check @ <>= procedure :: write => phs_identifier_write <>= subroutine phs_identifier_write (phs_id, unit) class(phs_identifier_t), intent(in) :: phs_id integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, '(A)') 'phs_identifier: ' write (u, '(A,1X,I1)') 'Emitter: ', phs_id%emitter if (allocated (phs_id%contributors)) then write (u, '(A)', advance = 'no') 'Resonance contributors: ' do i = 1, size (phs_id%contributors) write (u, '(I1,1X)', advance = 'no') phs_id%contributors(i) end do else write (u, '(A)') 'No Contributors allocated' end if end subroutine phs_identifier_write @ %def phs_identifier_write @ <>= public :: check_for_phs_identifier <>= subroutine check_for_phs_identifier (phs_id, n_in, emitter, contributors, phs_exist, i_phs) type(phs_identifier_t), intent(in), dimension(:) :: phs_id integer, intent(in) :: n_in, emitter integer, intent(in), dimension(:), optional :: contributors logical, intent(out) :: phs_exist integer, intent(out) :: i_phs integer :: i phs_exist = .false. i_phs = -1 do i = 1, size (phs_id) if (phs_id(i)%emitter < 0) then i_phs = i exit end if phs_exist = phs_id(i)%emitter == emitter if (present (contributors)) & phs_exist = phs_exist .and. all (phs_id(i)%contributors == contributors) if (phs_exist) then i_phs = i exit end if end do end subroutine check_for_phs_identifier @ %def check_for_phs_identifier @ @ The fks phase space type contains the wood phase space and separately the in- and outcoming momenta for the real process and the corresponding Born momenta. Additionally, there are the variables $\xi$,$\xi_{max}$, $y$ and $\phi$ which are used to create the real phase space, as well as the jacobian and its corresponding soft and collinear limit. Lastly, the array \texttt{ch\_to\_em} connects each channel with an emitter. <>= public :: phs_fks_t <>= type, extends (phs_wood_t) :: phs_fks_t integer :: mode = PHS_MODE_UNDEFINED type(vector4_t), dimension(:), allocatable :: p_born type(vector4_t), dimension(:), allocatable :: q_born type(vector4_t), dimension(:), allocatable :: p_real type(vector4_t), dimension(:), allocatable :: q_real type(vector4_t), dimension(:), allocatable :: p_born_tot type(phs_fks_generator_t) :: generator logical :: perform_generation = .true. real(default) :: r_isr type(phs_identifier_t), dimension(:), allocatable :: phs_identifiers contains <> end type phs_fks_t @ %def phs_fks_t @ <>= interface compute_beta module procedure compute_beta_massless module procedure compute_beta_massive end interface interface get_xi_max_fsr module procedure get_xi_max_fsr_massless module procedure get_xi_max_fsr_massive end interface @ %def interfaces @ <>= procedure :: write => phs_fks_write <>= subroutine phs_fks_write (object, unit, verbose) class(phs_fks_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u, i, n_id u = given_output_unit (unit) call object%base_write () n_id = size (object%phs_identifiers) if (n_id == 0) then write (u, "(A)") "No phs identifiers allocated! " else do i = 1, n_id call object%phs_identifiers(i)%write (u) end do end if end subroutine phs_fks_write @ %def phs_fks_write @ Initializer for the phase space. Calls the initialization of the corresponding Born phase space, sets up the channel-emitter-association and allocates space for the momenta. <>= procedure :: init => phs_fks_init <>= subroutine phs_fks_init (phs, phs_config) class(phs_fks_t), intent(out) :: phs class(phs_config_t), intent(in), target :: phs_config call phs%base_init (phs_config) select type (phs_config) type is (phs_fks_config_t) phs%config => phs_config phs%forest = phs_config%forest end select select type(phs) type is (phs_fks_t) select type (phs_config) type is (phs_fks_config_t) phs%mode = phs_config%mode end select select case (phs%mode) case (PHS_MODE_ADDITIONAL_PARTICLE) phs%n_r_born = phs%config%n_par - 3 case (PHS_MODE_COLLINEAR_REMNANT) phs%n_r_born = phs%config%n_par - 1 end select end select end subroutine phs_fks_init @ %def phs_fks_init @ <>= procedure :: allocate_momenta => phs_fks_allocate_momenta <>= subroutine phs_fks_allocate_momenta (phs, phs_config, data_is_born) class(phs_fks_t), intent(inout) :: phs class(phs_config_t), intent(in) :: phs_config logical, intent(in) :: data_is_born integer :: n_out_born allocate (phs%p_born (phs_config%n_in)) allocate (phs%p_real (phs_config%n_in)) select case (phs%mode) case (PHS_MODE_ADDITIONAL_PARTICLE) if (data_is_born) then n_out_born = phs_config%n_out else n_out_born = phs_config%n_out - 1 end if allocate (phs%q_born (n_out_born)) allocate (phs%q_real (n_out_born + 1)) allocate (phs%p_born_tot (phs_config%n_in + n_out_born)) end select end subroutine phs_fks_allocate_momenta @ %def phs_fks_allocate_momenta @ Evaluate selected channel. First, the subroutine calls the evaluation procedure of the underlying Born phase space, using $n_r - 3$ random numbers. Then, the remaining three random numbers are used to create $\xi$, $y$ and $\phi$, from which the real momenta are calculated from the Born momenta. <>= procedure :: evaluate_selected_channel => phs_fks_evaluate_selected_channel <>= subroutine phs_fks_evaluate_selected_channel (phs, c_in, r_in) class(phs_fks_t), intent(inout) :: phs integer, intent(in) :: c_in real(default), intent(in), dimension(:) :: r_in integer :: n_in call phs%phs_wood_t%evaluate_selected_channel (c_in, r_in) phs%r(:,c_in) = r_in phs%q_defined = phs%phs_wood_t%q_defined if (.not. phs%q_defined) return if (phs%perform_generation) then select case (phs%mode) case (PHS_MODE_ADDITIONAL_PARTICLE) n_in = phs%config%n_in phs%p_born = phs%phs_wood_t%p phs%q_born = phs%phs_wood_t%q phs%p_born_tot (1: n_in) = phs%p_born phs%p_born_tot (n_in + 1 :) = phs%q_born call phs%set_reference_frames (.true.) call phs%set_isr_kinematics (.true.) case (PHS_MODE_COLLINEAR_REMNANT) call phs%compute_isr_kinematics (r_in(phs%n_r_born + 1)) phs%r_isr = r_in(phs%n_r_born + 1) end select end if end subroutine phs_fks_evaluate_selected_channel @ %def phs_fks_evaluate_selected_channel @ <>= procedure :: evaluate_other_channels => phs_fks_evaluate_other_channels <>= subroutine phs_fks_evaluate_other_channels (phs, c_in) class(phs_fks_t), intent(inout) :: phs integer, intent(in) :: c_in call phs%phs_wood_t%evaluate_other_channels (c_in) phs%r_defined = .true. end subroutine phs_fks_evaluate_other_channels @ %def phs_fks_evaluate_other_channels @ <>= procedure :: get_mcpar => phs_fks_get_mcpar <>= subroutine phs_fks_get_mcpar (phs, c, r) class(phs_fks_t), intent(in) :: phs integer, intent(in) :: c real(default), dimension(:), intent(out) :: r r(1 : phs%n_r_born) = phs%r(1 : phs%n_r_born,c) select case (phs%mode) case (PHS_MODE_ADDITIONAL_PARTICLE) r(phs%n_r_born + 1 :) = phs%r_real case (PHS_MODE_COLLINEAR_REMNANT) r(phs%n_r_born + 1 :) = phs%r_isr end select end subroutine phs_fks_get_mcpar @ %def phs_fks_get_mcpar @ <>= procedure :: set_beam_energy => phs_fks_set_beam_energy <>= subroutine phs_fks_set_beam_energy (phs) class(phs_fks_t), intent(inout) :: phs call phs%generator%set_sqrts_hat (phs%config%sqrts) end subroutine phs_fks_set_beam_energy @ %def phs_fks_set_beam_energy @ <>= procedure :: set_emitters => phs_fks_set_emitters <>= subroutine phs_fks_set_emitters (phs, emitters) class(phs_fks_t), intent(inout) :: phs integer, intent(in), dimension(:), allocatable :: emitters call phs%generator%set_emitters (emitters) end subroutine phs_fks_set_emitters @ %def phs_fks_set_emitters @ <>= procedure :: set_momenta => phs_fks_set_momenta <>= subroutine phs_fks_set_momenta (phs, p) class(phs_fks_t), intent(inout) :: phs type(vector4_t), intent(in), dimension(:) :: p integer :: n_in, n_tot_born select case (phs%mode) case (PHS_MODE_ADDITIONAL_PARTICLE) n_in = phs%config%n_in; n_tot_born = phs%config%n_tot - 1 phs%p_born = p(1 : n_in) phs%q_born = p(n_in + 1 : n_tot_born) phs%p_born_tot = p end select end subroutine phs_fks_set_momenta @ %def phs_fks_set_momenta @ <>= procedure :: setup_masses => phs_fks_setup_masses <>= subroutine phs_fks_setup_masses (phs, n_tot) class(phs_fks_t), intent(inout) :: phs integer, intent(in) :: n_tot call phs%generator%setup_masses (n_tot) end subroutine phs_fks_setup_masses @ %def phs_fks_setup_masses @ <>= procedure :: get_born_momenta => phs_fks_get_born_momenta <>= subroutine phs_fks_get_born_momenta (phs, p) class(phs_fks_t), intent(inout) :: phs type(vector4_t), intent(out), dimension(:) :: p select case (phs%mode) case (PHS_MODE_ADDITIONAL_PARTICLE) p(1 : phs%config%n_in) = phs%p_born p(phs%config%n_in + 1 :) = phs%q_born case (PHS_MODE_COLLINEAR_REMNANT) p(1:phs%config%n_in) = phs%phs_wood_t%p p(phs%config%n_in + 1 : ) = phs%phs_wood_t%q end select if (.not. phs%config%cm_frame) p = phs%lt_cm_to_lab * p end subroutine phs_fks_get_born_momenta @ %def phs_fks_get_born_momenta @ <>= procedure :: get_outgoing_momenta => phs_fks_get_outgoing_momenta <>= subroutine phs_fks_get_outgoing_momenta (phs, q) class(phs_fks_t), intent(in) :: phs type(vector4_t), intent(out), dimension(:) :: q select case (phs%mode) case (PHS_MODE_ADDITIONAL_PARTICLE) q = phs%q_real case (PHS_MODE_COLLINEAR_REMNANT) q = phs%phs_wood_t%q end select end subroutine phs_fks_get_outgoing_momenta @ %def phs_fks_get_outgoing_momenta @ <>= procedure :: get_incoming_momenta => phs_fks_get_incoming_momenta <>= subroutine phs_fks_get_incoming_momenta (phs, p) class(phs_fks_t), intent(in) :: phs type(vector4_t), intent(inout), dimension(:), allocatable :: p p = phs%p_real end subroutine phs_fks_get_incoming_momenta @ %def phs_fks_get_incoming_momenta @ <>= procedure :: set_isr_kinematics => phs_fks_set_isr_kinematics <>= subroutine phs_fks_set_isr_kinematics (phs, requires_boost) class(phs_fks_t), intent(inout) :: phs logical, intent(in) :: requires_boost type(vector4_t), dimension(2) :: p if (phs%generator%isr_kinematics%isr_mode == SQRTS_VAR) then if (requires_boost) then p = phs%lt_cm_to_lab * phs%generator%real_kinematics%p_born_cms%phs_point(1)%p(1:2) else p = phs%generator%real_kinematics%p_born_lab%phs_point(1)%p(1:2) end if call phs%generator%set_isr_kinematics (p) end if end subroutine phs_fks_set_isr_kinematics @ %def phs_fks_set_isr_kinematics @ <>= procedure :: generate_radiation_variables => & phs_fks_generate_radiation_variables <>= subroutine phs_fks_generate_radiation_variables (phs, r_in, threshold) class(phs_fks_t), intent(inout) :: phs real(default), intent(in), dimension(:) :: r_in logical, intent(in) :: threshold type(vector4_t), dimension(:), allocatable :: p_born if (size (r_in) /= 3) call msg_fatal & ("Real kinematics need to be generated using three random numbers!") select case (phs%mode) case (PHS_MODE_ADDITIONAL_PARTICLE) allocate (p_born (size (phs%p_born_tot))) if (threshold) then p_born = phs%get_onshell_projected_momenta () else p_born = phs%p_born_tot if (.not. phs%is_cm_frame ()) & p_born = inverse (phs%lt_cm_to_lab) * p_born end if call phs%generator%generate_radiation_variables & (r_in, p_born, phs%phs_identifiers, threshold) phs%r_real = r_in end select end subroutine phs_fks_generate_radiation_variables @ %def phs_fks_generate_radiation_variables @ <>= procedure :: compute_xi_ref_momenta => phs_fks_compute_xi_ref_momenta <>= subroutine phs_fks_compute_xi_ref_momenta (phs, p_in, contributors) class(phs_fks_t), intent(inout) :: phs type(vector4_t), intent(in), dimension(:), optional :: p_in type(resonance_contributors_t), intent(in), dimension(:), optional :: contributors if (phs%mode == PHS_MODE_ADDITIONAL_PARTICLE) then if (present (p_in)) then call phs%generator%compute_xi_ref_momenta (p_in, contributors) else call phs%generator%compute_xi_ref_momenta (phs%p_born_tot, contributors) end if end if end subroutine phs_fks_compute_xi_ref_momenta @ %def phs_fks_compute_xi_ref_momenta @ <>= procedure :: compute_xi_ref_momenta_threshold => phs_fks_compute_xi_ref_momenta_threshold <>= subroutine phs_fks_compute_xi_ref_momenta_threshold (phs) class(phs_fks_t), intent(inout) :: phs select case (phs%mode) case (PHS_MODE_ADDITIONAL_PARTICLE) call phs%generator%compute_xi_ref_momenta_threshold & (phs%get_onshell_projected_momenta ()) end select end subroutine phs_fks_compute_xi_ref_momenta_threshold @ %def phs_fks_compute_xi_ref_momenta @ <>= procedure :: compute_cms_energy => phs_fks_compute_cms_energy <>= subroutine phs_fks_compute_cms_energy (phs) class(phs_fks_t), intent(inout) :: phs if (phs%mode == PHS_MODE_ADDITIONAL_PARTICLE) & call phs%generator%compute_cms_energy (phs%p_born_tot) end subroutine phs_fks_compute_cms_energy @ %def phs_fks_compute_cms_energy @ When initial-state radiation is involved, either due to beamnstrahlung or QCD corrections, it is important to have access to both the phase space points in the center-of-mass and lab frame. <>= procedure :: set_reference_frames => phs_fks_set_reference_frames <>= subroutine phs_fks_set_reference_frames (phs, is_cms) class(phs_fks_t), intent(inout) :: phs logical, intent(in) :: is_cms type(lorentz_transformation_t) :: lt associate (real_kinematics => phs%generator%real_kinematics) if (phs%config%cm_frame) then real_kinematics%p_born_cms%phs_point(1)%p = phs%p_born_tot real_kinematics%p_born_lab%phs_point(1)%p = phs%p_born_tot else if (is_cms) then real_kinematics%p_born_cms%phs_point(1)%p = phs%p_born_tot lt = phs%lt_cm_to_lab real_kinematics%p_born_lab%phs_point(1)%p = & lt * phs%p_born_tot else real_kinematics%p_born_lab%phs_point(1)%p = phs%p_born_tot lt = inverse (phs%lt_cm_to_lab) real_kinematics%p_born_cms%phs_point(1)%p = & lt * phs%p_born_tot end if end if end associate end subroutine phs_fks_set_reference_frames @ %def phs_fks_set_reference_frames @ <>= procedure :: i_phs_is_isr => phs_fks_i_phs_is_isr <>= function phs_fks_i_phs_is_isr (phs, i_phs) result (is_isr) logical :: is_isr class(phs_fks_t), intent(in) :: phs integer, intent(in) :: i_phs is_isr = phs%phs_identifiers(i_phs)%emitter <= phs%generator%n_in end function phs_fks_i_phs_is_isr @ %def phs_fks_i_phs_is_isr @ \subsection{Creation of the real phase space - FSR} At this point, the Born phase space has been generated, as well as the three random variables $\xi$, $y$ and $\phi$. The question is how the real phase space is generated for a final-state emission configuration. We work with two different sets of momenta, the Born configuration $\Bigl\{ \bar{k}_{\oplus}, \bar{k}_{\ominus}, \bar{k}_{1}, ..., \bar{k}_{n} \Bigr\}$ and the real configuration $\Bigl\{ k_{\oplus}, k_{\ominus}, k_1,..., k_n, k_{n+1} \Bigr\}$. We define the momentum of the emitter to be on the $n$-th position and the momentum of the radiated particle to be at position $n+1$. The magnitude of the spatial component of k is denoted by $\underline{k}$. For final-state emissions, it is $\bar{k}_\oplus = k_\oplus$ and $\bar{k}_\ominus = k_\ominus$. Thus, the center-of-mass systems coincide and it is \begin{equation} q = \sum_{i=1}^n \bar{k}_i = \sum_{i=1}^{n+1} k_i, \end{equation} with $\vec{q} = 0$ and $q^2 = \left(q^0\right)^2$. We want to construct the real phase space from the Born phase space using three random numbers. They are defined as follows: \begin{itemize} \item $\xi = \frac{2k_{n+1}^0}{\sqrt{s}} \in [0, \xi_{max}]$, where $k_{n+1}$ denotes the four-momentum of the radiated particle. \item $y = \cos\theta = \frac{\vec{k}_n \cdot \vec{k}_{n+1}}{\underline{k}_n \underline{k}_{n+1}}$ is the splitting angle. \item The angle between tho two splitting particles in the transversal plane, $phi \in [0,2\pi]$. \end{itemize} Further, $k_{rec} = \sum_{i=1}^{n-1} k_i$ denotes the sum of all recoiling momenta. <>= generic :: generate_fsr => generate_fsr_default, generate_fsr_resonances <>= procedure :: generate_fsr_default => phs_fks_generator_generate_fsr_default <>= subroutine phs_fks_generator_generate_fsr_default (generator, emitter, i_phs, & p_born, p_real, xi_y_phi, no_jacobians) class(phs_fks_generator_t), intent(inout) :: generator integer, intent(in) :: emitter, i_phs type(vector4_t), intent(in), dimension(:) :: p_born type(vector4_t), intent(inout), dimension(:) :: p_real real(default), intent(in), dimension(3), optional :: xi_y_phi logical, intent(in), optional :: no_jacobians real(default) :: q0 call generator%generate_fsr_in (p_born, p_real) q0 = sum (p_born(1:generator%n_in))**1 generator%i_fsr_first = generator%n_in + 1 call generator%generate_fsr_out (emitter, i_phs, p_born, p_real, q0, & xi_y_phi = xi_y_phi, no_jacobians = no_jacobians) if (debug_active (D_PHASESPACE)) then call vector4_check_momentum_conservation (p_real, generator%n_in, & rel_smallness = 1000 * tiny_07, abs_smallness = tiny_07) end if end subroutine phs_fks_generator_generate_fsr_default @ %def phs_fks_generator_generate_fsr @ <>= procedure :: generate_fsr_resonances => phs_fks_generator_generate_fsr_resonances <>= subroutine phs_fks_generator_generate_fsr_resonances (generator, & emitter, i_phs, i_con, p_born, p_real, xi_y_phi, no_jacobians) class(phs_fks_generator_t), intent(inout) :: generator integer, intent(in) :: emitter, i_phs integer, intent(in) :: i_con type(vector4_t), intent(in), dimension(:) :: p_born type(vector4_t), intent(inout), dimension(:) :: p_real real(default), intent(in), dimension(3), optional :: xi_y_phi logical, intent(in), optional :: no_jacobians integer, dimension(:), allocatable :: resonance_list integer, dimension(size(p_born)) :: inv_resonance_list type(vector4_t), dimension(:), allocatable :: p_tmp_born type(vector4_t), dimension(:), allocatable :: p_tmp_real type(vector4_t) :: p_resonance real(default) :: q0 integer :: i, j, nlegborn, nlegreal integer :: i_emitter type(lorentz_transformation_t) :: boost_to_resonance integer :: n_resonant_particles call msg_debug2 (D_PHASESPACE, "phs_fks_generator_generate_fsr_resonances") nlegborn = size (p_born); nlegreal = nlegborn + 1 allocate (resonance_list (size (generator%resonance_contributors(i_con)%c))) resonance_list = generator%resonance_contributors(i_con)%c n_resonant_particles = size (resonance_list) if (.not. any (resonance_list == emitter)) then call msg_fatal ("Emitter must be included in the resonance list!") else do i = 1, n_resonant_particles if (resonance_list (i) == emitter) i_emitter = i end do end if inv_resonance_list = & create_inverse_resonance_list (nlegborn, resonance_list) allocate (p_tmp_born (n_resonant_particles)) allocate (p_tmp_real (n_resonant_particles + 1)) p_tmp_born = vector4_null p_tmp_real = vector4_null j = 1 do i = 1, n_resonant_particles p_tmp_born(j) = p_born(resonance_list(i)) j = j + 1 end do call generator%generate_fsr_in (p_born, p_real) p_resonance = generator%real_kinematics%xi_ref_momenta(i_con) q0 = p_resonance**1 boost_to_resonance = inverse (boost (p_resonance, q0)) p_tmp_born = boost_to_resonance * p_tmp_born generator%i_fsr_first = 1 call generator%generate_fsr_out (emitter, i_phs, p_tmp_born, p_tmp_real, & q0, i_emitter, xi_y_phi) p_tmp_real = inverse (boost_to_resonance) * p_tmp_real do i = generator%n_in + 1, nlegborn if (any (resonance_list == i)) then p_real(i) = p_tmp_real(inv_resonance_list (i)) else p_real(i) = p_born (i) end if end do p_real(nlegreal) = p_tmp_real (n_resonant_particles + 1) if (debug_active (D_PHASESPACE)) then call vector4_check_momentum_conservation (p_real, generator%n_in, & rel_smallness = 1000 * tiny_07, abs_smallness = tiny_07) end if contains function create_inverse_resonance_list (nlegborn, resonance_list) & result (inv_resonance_list) integer, intent(in) :: nlegborn integer, intent(in), dimension(:) :: resonance_list integer, dimension(nlegborn) :: inv_resonance_list integer :: i, j inv_resonance_list = 0 j = 1 do i = 1, nlegborn if (any (i == resonance_list)) then inv_resonance_list (i) = j j = j + 1 end if end do end function create_inverse_resonance_list function boosted_energy () result (E) real(default) :: E type(vector4_t) :: p_boost p_boost = boost_to_resonance * p_resonance E = p_boost%p(0) end function boosted_energy end subroutine phs_fks_generator_generate_fsr_resonances @ %def phs_fks_generator_generate_fsr_resonances @ <>= procedure :: generate_fsr_threshold => phs_fks_generator_generate_fsr_threshold <>= subroutine phs_fks_generator_generate_fsr_threshold (generator, & emitter, i_phs, p_born, p_real, xi_y_phi) class(phs_fks_generator_t), intent(inout) :: generator integer, intent(in) :: emitter, i_phs type(vector4_t), intent(in), dimension(:) :: p_born type(vector4_t), intent(inout), dimension(:) :: p_real real(default), intent(in), dimension(3), optional :: xi_y_phi type(vector4_t), dimension(2) :: p_tmp_born type(vector4_t), dimension(3) :: p_tmp_real integer :: nlegborn, nlegreal type(vector4_t) :: p_top real(default) :: q0 type(lorentz_transformation_t) :: boost_to_top integer :: leg, other_leg real(default) :: sqrts, mtop call msg_debug2 (D_PHASESPACE, "phs_fks_generator_generate_fsr_resonances") nlegborn = size (p_born); nlegreal = nlegborn + 1 leg = thr_leg(emitter); other_leg = 3 - leg p_tmp_born(1) = p_born (ass_boson(leg)) p_tmp_born(2) = p_born (ass_quark(leg)) call generator%generate_fsr_in (p_born, p_real) p_top = generator%real_kinematics%xi_ref_momenta(leg) q0 = p_top**1 sqrts = two * p_born(1)%p(0) mtop = m1s_to_mpole (sqrts) if (sqrts**2 - four * mtop**2 > zero) then boost_to_top = inverse (boost (p_top, q0)) else boost_to_top = identity end if p_tmp_born = boost_to_top * p_tmp_born generator%i_fsr_first = 1 call generator%generate_fsr_out (emitter, i_phs, p_tmp_born, & p_tmp_real, q0, 2, xi_y_phi) p_tmp_real = inverse (boost_to_top) * p_tmp_real p_real(ass_boson(leg)) = p_tmp_real(1) p_real(ass_quark(leg)) = p_tmp_real(2) p_real(ass_boson(other_leg)) = p_born(ass_boson(other_leg)) p_real(ass_quark(other_leg)) = p_born(ass_quark(other_leg)) p_real(THR_POS_GLUON) = p_tmp_real(3) end subroutine phs_fks_generator_generate_fsr_threshold @ %def phs_fks_generator_generate_fsr_threshold @ <>= procedure :: generate_fsr_in => phs_fks_generator_generate_fsr_in <>= subroutine phs_fks_generator_generate_fsr_in (generator, p_born, p_real) class(phs_fks_generator_t), intent(inout) :: generator type(vector4_t), intent(in), dimension(:) :: p_born type(vector4_t), intent(inout), dimension(:) :: p_real integer :: i do i = 1, generator%n_in p_real(i) = p_born(i) end do end subroutine phs_fks_generator_generate_fsr_in @ %def phs_fks_generator_generate_fsr_in @ <>= procedure :: generate_fsr_out => phs_fks_generator_generate_fsr_out <>= subroutine phs_fks_generator_generate_fsr_out (generator, & emitter, i_phs, p_born, p_real, q0, p_emitter_index, xi_y_phi, no_jacobians) class(phs_fks_generator_t), intent(inout) :: generator integer, intent(in) :: emitter, i_phs type(vector4_t), intent(in), dimension(:) :: p_born type(vector4_t), intent(inout), dimension(:) :: p_real real(default), intent(in) :: q0 integer, intent(in), optional :: p_emitter_index real(default), intent(in), dimension(3), optional :: xi_y_phi logical, intent(in), optional :: no_jacobians real(default) :: xi, y, phi integer :: nlegborn, nlegreal real(default) :: uk_np1, uk_n real(default) :: uk_rec, k_rec0 type(vector3_t) :: k_n_born, k real(default) :: uk_n_born, uk, k2, k0_n real(default) :: cpsi, beta type(vector3_t) :: vec, vec_orth type(lorentz_transformation_t) :: rot integer :: i, p_em logical :: compute_jac p_em = emitter; if (present (p_emitter_index)) p_em = p_emitter_index compute_jac = .true. if (present (no_jacobians)) compute_jac = .not. no_jacobians if (generator%i_fsr_first < 0) & call msg_fatal ("FSR generator is called for outgoing particles but "& &"i_fsr_first is not set!") if (present (xi_y_phi)) then xi = xi_y_phi(I_XI) y = xi_y_phi(I_Y) phi = xi_y_phi(I_PHI) else associate (rad_var => generator%real_kinematics) xi = rad_var%xi_tilde if (rad_var%supply_xi_max) xi = xi * rad_var%xi_max(i_phs) y = rad_var%y(i_phs) phi = rad_var%phi end associate end if nlegborn = size (p_born) nlegreal = nlegborn + 1 generator%E_gluon = q0 * xi / two uk_np1 = generator%E_gluon k_n_born = p_born(p_em)%p(1:3) uk_n_born = k_n_born**1 generator%mrec2 = (q0 - p_born(p_em)%p(0))**2 & - space_part_norm(p_born(p_em))**2 if (generator%is_massive(emitter)) then call generator%compute_emitter_kinematics (y, emitter, & i_phs, q0, k0_n, uk_n, uk, compute_jac) else call generator%compute_emitter_kinematics (y, q0, uk_n, uk) generator%real_kinematics%y_soft(i_phs) = y k0_n = uk_n end if call msg_debug2 (D_PHASESPACE, "phs_fks_generator_generate_fsr_out") call debug_input_values () vec = uk_n / uk_n_born * k_n_born vec_orth = create_orthogonal (vec) p_real(p_em)%p(0) = k0_n p_real(p_em)%p(1:3) = vec%p(1:3) cpsi = (uk_n**2 + uk**2 - uk_np1**2) / (two * uk_n * uk) !!! This is to catch the case where cpsi = 1, but numerically !!! turns out to be slightly larger than 1. call check_cpsi_bound (cpsi) rot = rotation (cpsi, - sqrt (one - cpsi**2), vec_orth) p_real(p_em) = rot * p_real(p_em) vec = uk_np1 / uk_n_born * k_n_born vec_orth = create_orthogonal (vec) p_real(nlegreal)%p(0) = uk_np1 p_real(nlegreal)%p(1:3) = vec%p(1:3) cpsi = (uk_np1**2 + uk**2 - uk_n**2) / (two * uk_np1 * uk) call check_cpsi_bound (cpsi) rot = rotation (cpsi, sqrt (one - cpsi**2), vec_orth) p_real(nlegreal) = rot * p_real(nlegreal) call construct_recoiling_momenta () if (compute_jac) call compute_jacobians () contains <> end subroutine phs_fks_generator_generate_fsr_out @ %def phs_fks_generator_generate_fsr_out @ <>= subroutine debug_input_values () if (debug2_active (D_PHASESPACE)) then call generator%write () print *, 'emitter = ', emitter print *, 'p_born:' call vector4_write_set (p_born) print *, 'p_real:' call vector4_write_set (p_real) print *, 'q0 = ', q0 if (present(p_emitter_index)) then print *, 'p_emitter_index = ', p_emitter_index else print *, 'p_emitter_index not given' end if end if end subroutine debug_input_values <>= subroutine check_cpsi_bound (cpsi) real(default), intent(inout) :: cpsi if (cpsi > one) then cpsi = one else if (cpsi < -one) then cpsi = - one end if end subroutine check_cpsi_bound @ Construction of the recoiling momenta. The reshuffling of momenta must not change the invariant mass of the recoiling system, which means $k_{\rm{rec}}^2 = \bar{k_{\rm{rec}}}^2$. Therefore, the momenta are related by a boost, $\bar{k}_i = \Lambda k_i$. The boost parameter is \begin{equation*} \beta = \frac{q^2 - (k_{\rm{rec}}^0 + \underline{k}_{\rm{rec}})^2}{q^2 + (k_{\rm{rec}}^0 + \underline{k}_{\rm{rec}})^2} \end{equation*} <>= subroutine construct_recoiling_momenta () type(lorentz_transformation_t) :: lambda k_rec0 = q0 - p_real(p_em)%p(0) - p_real(nlegreal)%p(0) uk_rec = sqrt (k_rec0**2 - generator%mrec2) if (generator%is_massive(emitter)) then beta = compute_beta (q0**2, k_rec0, uk_rec, & p_born(p_em)%p(0), uk_n_born) else beta = compute_beta (q0**2, k_rec0, uk_rec) end if k = p_real(p_em)%p(1:3) + p_real(nlegreal)%p(1:3) vec%p(1:3) = one / uk * k%p(1:3) lambda = boost (beta / sqrt(one - beta**2), vec) do i = generator%i_fsr_first, nlegborn if (i /= p_em) then p_real(i) = lambda * p_born(i) end if end do vec%p(1:3) = p_born(p_em)%p(1:3) / uk_n_born rot = rotation (cos(phi), sin(phi), vec) p_real(nlegreal) = rot * p_real(nlegreal) p_real(p_em) = rot * p_real(p_em) end subroutine construct_recoiling_momenta @ The factor $\frac{q^2}{(4\pi)^3}$ is not included here since it is supplied during phase space generation. Also, we already divide by $\xi$. <>= subroutine compute_jacobians () associate (jac => generator%real_kinematics%jac(i_phs)) if (generator%is_massive(emitter)) then jac%jac(1) = jac%jac(1) * four / q0 / uk_n_born / xi else k2 = two * uk_n * uk_np1* (one - y) jac%jac(1) = uk_n**2 / uk_n_born / (uk_n - k2 / (two * q0)) end if jac%jac(2) = one jac%jac(3) = one - xi / two * q0 / uk_n_born end associate end subroutine compute_jacobians @ %def compute_jacobians @ <>= procedure :: generate_fsr_in => phs_fks_generate_fsr_in <>= subroutine phs_fks_generate_fsr_in (phs) class(phs_fks_t), intent(inout) :: phs type(vector4_t), dimension(:), allocatable :: p p = phs%generator%real_kinematics%p_born_lab%get_momenta (1, phs%generator%n_in) end subroutine phs_fks_generate_fsr_in @ %def phs_fks_generate_fsr_in @ <>= procedure :: generate_fsr => phs_fks_generate_fsr <>= subroutine phs_fks_generate_fsr (phs, emitter, i_phs, p_real, i_con, & xi_y_phi, no_jacobians) class(phs_fks_t), intent(inout) :: phs integer, intent(in) :: emitter, i_phs type(vector4_t), intent(inout), dimension(:) :: p_real integer, intent(in), optional :: i_con real(default), intent(in), dimension(3), optional :: xi_y_phi logical, intent(in), optional :: no_jacobians type(vector4_t), dimension(:), allocatable :: p associate (generator => phs%generator) allocate (p (1:generator%real_kinematics%p_born_cms%get_n_particles()), & source = generator%real_kinematics%p_born_cms%phs_point(1)%p) generator%real_kinematics%supply_xi_max = .true. if (present (i_con)) then call generator%generate_fsr (emitter, i_phs, i_con, p, p_real, & xi_y_phi, no_jacobians) else call generator%generate_fsr (emitter, i_phs, p, p_real, & xi_y_phi, no_jacobians) end if generator%real_kinematics%p_real_cms%phs_point(i_phs)%p = p_real if (.not. phs%config%cm_frame) p_real = phs%lt_cm_to_lab * p_real generator%real_kinematics%p_real_lab%phs_point(i_phs)%p = p_real end associate end subroutine phs_fks_generate_fsr @ %def phs_fks_generate_fsr @ <>= procedure :: get_onshell_projected_momenta => phs_fks_get_onshell_projected_momenta <>= pure function phs_fks_get_onshell_projected_momenta (phs) result (p) type(vector4_t), dimension(:), allocatable :: p class(phs_fks_t), intent(in) :: phs p = phs%generator%real_kinematics%p_born_onshell%phs_point(1)%p end function phs_fks_get_onshell_projected_momenta @ %def phs_fks_get_onshell_projected_momenta @ <>= procedure :: generate_fsr_threshold => phs_fks_generate_fsr_threshold <>= subroutine phs_fks_generate_fsr_threshold (phs, emitter, i_phs, p_real) class(phs_fks_t), intent(inout) :: phs integer, intent(in) :: emitter, i_phs type(vector4_t), intent(inout), dimension(:), optional :: p_real type(vector4_t), dimension(:), allocatable :: p_born type(vector4_t), dimension(:), allocatable :: pp integer :: leg associate (generator => phs%generator) generator%real_kinematics%supply_xi_max = .true. allocate (p_born (1 : generator%real_kinematics%p_born_cms%get_n_particles())) p_born = generator%real_kinematics%p_born_onshell%get_momenta (1) allocate (pp (size (p_born) + 1)) call generator%generate_fsr_threshold (emitter, i_phs, p_born, pp) leg = thr_leg (emitter) call generator%real_kinematics%p_real_onshell(leg)%set_momenta (i_phs, pp) if (present (p_real)) p_real = pp end associate end subroutine phs_fks_generate_fsr_threshold @ %def phs_fks_generate_fsr_threshold @ <>= generic :: compute_xi_max => compute_xi_max_internal, compute_xi_max_with_output procedure :: compute_xi_max_internal => phs_fks_compute_xi_max_internal <>= subroutine phs_fks_compute_xi_max_internal (phs, p, threshold) class(phs_fks_t), intent(inout) :: phs type(vector4_t), intent(in), dimension(:) :: p logical, intent(in) :: threshold integer :: i_phs, i_con, emitter do i_phs = 1, size (phs%phs_identifiers) associate (phs_id => phs%phs_identifiers(i_phs), generator => phs%generator) emitter = phs_id%emitter if (threshold) then call generator%compute_xi_max (emitter, i_phs, p, & generator%real_kinematics%xi_max(i_phs), i_con = thr_leg(emitter)) else if (allocated (phs_id%contributors)) then do i_con = 1, size (phs_id%contributors) call generator%compute_xi_max (emitter, i_phs, p, & generator%real_kinematics%xi_max(i_phs), i_con = 1) end do else call generator%compute_xi_max (emitter, i_phs, p, & generator%real_kinematics%xi_max(i_phs)) end if end associate end do end subroutine phs_fks_compute_xi_max_internal @ %def phs_fks_compute_xi_max @ <>= procedure :: compute_xi_max_with_output => phs_fks_compute_xi_max_with_output <>= subroutine phs_fks_compute_xi_max_with_output (phs, emitter, i_phs, y, p, xi_max) class(phs_fks_t), intent(inout) :: phs integer, intent(in) :: i_phs, emitter real(default), intent(in) :: y type(vector4_t), intent(in), dimension(:) :: p real(default), intent(out) :: xi_max call phs%generator%compute_xi_max (emitter, i_phs, p, xi_max, y_in = y) end subroutine phs_fks_compute_xi_max_with_output @ %def phs_fks_compute_xi_max_with_output @ <>= generic :: compute_emitter_kinematics => & compute_emitter_kinematics_massless, & compute_emitter_kinematics_massive procedure :: compute_emitter_kinematics_massless => & phs_fks_generator_compute_emitter_kinematics_massless procedure :: compute_emitter_kinematics_massive => & phs_fks_generator_compute_emitter_kinematics_massive <>= subroutine phs_fks_generator_compute_emitter_kinematics_massless & (generator, y, q0, uk_em, uk) class(phs_fks_generator_t), intent(inout) :: generator real(default), intent(in) :: y, q0 real(default), intent(out) :: uk_em, uk real(default) :: k0_np1, q2 k0_np1 = generator%E_gluon q2 = q0**2 uk_em = (q2 - generator%mrec2 - two * q0 * k0_np1) / (two * (q0 - k0_np1 * (one - y))) uk = sqrt (uk_em**2 + k0_np1**2 + two * uk_em * k0_np1 * y) end subroutine phs_fks_generator_compute_emitter_kinematics_massless subroutine phs_fks_generator_compute_emitter_kinematics_massive & (generator, y, em, i_phs, q0, k0_em, uk_em, uk, compute_jac) class(phs_fks_generator_t), intent(inout) :: generator real(default), intent(in) :: y integer, intent(in) :: em, i_phs real(default), intent(in) :: q0 real(default), intent(inout) :: k0_em, uk_em, uk logical, intent(in) :: compute_jac real(default) :: k0_np1, q2, mrec2, m2 real(default) :: k0_rec_max, k0_em_max, k0_rec, uk_rec real(default) :: z, z1, z2 k0_np1 = generator%E_gluon q2 = q0**2 mrec2 = generator%mrec2 m2 = generator%m2(em) k0_rec_max = (q2 - m2 + mrec2) / (two * q0) k0_em_max = (q2 + m2 - mrec2) /(two * q0) z1 = (k0_rec_max + sqrt (k0_rec_max**2 - mrec2)) / q0 z2 = (k0_rec_max - sqrt (k0_rec_max**2 - mrec2)) / q0 z = z2 - (z2 - z1) * (one + y) / two k0_em = k0_em_max - k0_np1 * z k0_rec = q0 - k0_np1 - k0_em uk_em = sqrt(k0_em**2 - m2) uk_rec = sqrt(k0_rec**2 - mrec2) uk = uk_rec if (compute_jac) & generator%real_kinematics%jac(i_phs)%jac = q0 * (z1 - z2) / four * k0_np1 generator%real_kinematics%y_soft(i_phs) = & (two * q2 * z - q2 - mrec2 + m2) / (sqrt(k0_em_max**2 - m2) * q0) / two end subroutine phs_fks_generator_compute_emitter_kinematics_massive @ %def phs_fks_generator_compute_emitter_kinematics @ <>= function recompute_xi_max (q0, mrec2, m2, y) result (xi_max) real(default) :: xi_max real(default), intent(in) :: q0, mrec2, m2, y real(default) :: q2, k0_np1_max, k0_rec_max real(default) :: z1, z2, z q2 = q0**2 k0_rec_max = (q2 - m2 + mrec2) / (two * q0) z1 = (k0_rec_max + sqrt (k0_rec_max**2 - mrec2)) / q0 z2 = (k0_rec_max - sqrt (k0_rec_max**2 - mrec2)) / q0 z = z2 - (z2 - z1) * (one + y) / 2 k0_np1_max = - (q2 * z**2 - two * q0 * k0_rec_max * z + mrec2) / (two * q0 * z * (one - z)) xi_max = two * k0_np1_max / q0 end function recompute_xi_max @ %def recompute_xi_max @ <>= function compute_beta_massless (q2, k0_rec, uk_rec) result (beta) real(default), intent(in) :: q2, k0_rec, uk_rec real(default) :: beta beta = (q2 - (k0_rec + uk_rec)**2) / (q2 + (k0_rec + uk_rec)**2) end function compute_beta_massless function compute_beta_massive (q2, k0_rec, uk_rec, & k0_em_born, uk_em_born) result (beta) real(default), intent(in) :: q2, k0_rec, uk_rec real(default), intent(in) :: k0_em_born, uk_em_born real(default) :: beta real(default) :: k0_rec_born, uk_rec_born, alpha k0_rec_born = sqrt(q2) - k0_em_born uk_rec_born = uk_em_born alpha = (k0_rec + uk_rec) / (k0_rec_born + uk_rec_born) beta = (one - alpha**2) / (one + alpha**2) end function compute_beta_massive @ %def compute_beta @ The momentum of the radiated particle is computed according to \begin{equation} \label{eq:phs fks:compute k_n} \underline{k}_n = \frac{q^2 - M_{\rm{rec}}^2 - 2q^0\underline{k}_{n+1}}{2(q^0 - \underline{k}_{n+1}(1-y))}, \end{equation} with $k = k_n + k_{n+1}$ and $M_{\rm{rec}}^2 = k_{\rm{rec}}^2 = \left(q-k\right)^2$. Because of $\boldsymbol{\bar{k}}_n \parallel \boldsymbol{k}_n + \boldsymbol{k}_{n+1}$ we find $M_{\rm{rec}}^2 = \left(q-\bar{k}_n\right)^2$. Equation \ref{eq:phs fks: compute k_n} follows from the fact that $\left(\boldsymbol{k} - \boldsymbol{k}_n\right)^2 = \boldsymbol{k}_{n+1}^2$, which is equivalent to $\boldsymbol{k}_n \cdot \boldsymbol{k} = \frac{1}{2} \left(\underline{k}_n^2 + \underline{k}^2 - \underline{k}_{n+1}^2\right)$.\\ $\boldsymbol{k}_n$ and $\boldsymbol{k}_{n+1}$ are obtained by first setting up vectors parallel to $\boldsymbol{\bar{k}}_n$, \begin{equation*} \boldsymbol{k}_n' = \underline{k}_n \frac{\bar{\pmb{k}}_n}{\underline{\bar{k}}_n}, \quad \pmb{k}_{n+1}' = \underline{k}_{n+1}\frac{\bar{\pmb{k}}_n}{\underline{\bar{k}}_n}, \end{equation*} and then rotating these vectors by an amount of $\cos\psi_n = \frac{\boldsymbol{k}_n\cdot\pmb{k}}{\underline{k}_n \underline{k}}$. @ The emitted particle cannot have more momentum than the emitter has in the Born phase space. Thus, there is an upper bound for $\xi$, determined by the condition $k_{n+1}^0 = \underline{\bar{k}}_n$, which is equal to \begin{equation*} \xi_{\rm{max}} = \frac{2}{\underline{\bar{k}}_n}{q^0}. \end{equation*} <>= pure function get_xi_max_fsr_massless (p_born, q0, emitter) result (xi_max) type(vector4_t), intent(in), dimension(:) :: p_born real(default), intent(in) :: q0 integer, intent(in) :: emitter real(default) :: xi_max real(default) :: uk_n_born uk_n_born = space_part_norm (p_born(emitter)) xi_max = two * uk_n_born / q0 end function get_xi_max_fsr_massless @ %def get_xi_max_fsr_massless @ The computation of $\xi_{\rm{max}}$ for massive emitters is described in arXiv:1202.0465. Let's recapitulate it here. We consider the Dalitz-domain created by $k_{n+1}^0$, $k_n^0$ and $k_{\rm{rec}}^0$ and introduce the parameterization \begin{equation*} k_n^0 = \bar{k}_n^0 - zk_{n+1}^0 \end{equation*} Then, for each value of $z$, there exists a maximum value of $\underline{k}_{n+1}$ from which $\xi_{\rm{max}}$ can be extracted via $\xi_{\rm{max}} = 2k_{n+1}^0/q$. It is determined by the condition \begin{equation*} \underline{k}_{n+1} \pm \underline{k}_n \pm \underline{k}_{\rm{rec}} = 0. \end{equation*} This can be manipulated to yield \begin{equation*} \left(\underline{k}_{n+1}^2 + \underline{k}_n^2 - \underline{k}_{\rm{rec}}^2\right)^2 = 4\underline{k}^2_{n+1}\underline{k}_n^2. \end{equation*} Here we can use $\underline{k}_n^2 = \left(k_n^0\right)^2 - m^2$ and $\underline{k}_{\rm{rec}}^2 = \left(q - k_n^0 - k_{n+1}^0\right)^2 - M_{\rm{rec}}^2$, as well as the above parameterization of $k_n^0$, to obtain \begin{equation*} 4\underline{k}_{n+1}^2\left(2\underline{k}_{n+1}qz(1-z) + q^2z^2 - 2q\bar{k}_{\rm{rec}}^0z + M_{\rm{rec}}^2\right) = 0. \end{equation*} Solving for $k_{n+1}^0$ gives \begin{equation} k_{n+1}^0 = \frac{2q\bar{k}^0_{\rm{rec}}z - q^2z^2 - M_{\rm{rec}}^2}{2qz(1-z)}. \label{XiMaxMassive} \end{equation} It is still open how to compute $z$. For this, consider that the right-hand-side of equation (\ref{XiMaxMassive}) vanishes for \begin{equation*} z_{1,2} = \left(\bar{k}_{\rm{rec}}^0 \pm \sqrt{\left(\bar{k}_{\rm{rec}}^0\right)^2 - M_{\rm{rec}}^2}\right)/q, \end{equation*} which corresponds to the borders of the Dalitz-region where the gluon momentum vanishes. Thus we define \begin{equation*} z = z_2 - \frac{1}{2} (z_2 - z_1)(1+y). \end{equation*} <>= pure function get_xi_max_fsr_massive (p_born, q0, emitter, m2, y) result (xi_max) real(default) :: xi_max type(vector4_t), intent(in), dimension(:) :: p_born real(default), intent(in) :: q0 integer, intent(in) :: emitter real(default), intent(in) :: m2, y real(default) :: mrec2 real(default) :: k0_rec_max real(default) :: z, z1, z2 real(default) :: k0_np1_max associate (p => p_born(emitter)%p) mrec2 = (q0 - p(0))**2 - p(1)**2 - p(2)**2 - p(3)**2 end associate call compute_dalitz_bounds (q0, m2, mrec2, z1, z2, k0_rec_max) z = z2 - (z2 - z1) * (one + y) / two k0_np1_max = - (q0**2 * z**2 - two * q0 * k0_rec_max * z + mrec2) & / (two * q0 * z * (one - z)) xi_max = two * k0_np1_max / q0 end function get_xi_max_fsr_massive @ %def get_xi_max_fsr_massive @ <>= integer, parameter, public :: I_PLUS = 1 integer, parameter, public :: I_MINUS = 2 @ %def parameters @ <>= function get_xi_max_isr (xb, y) result (xi_max) real(default) :: xi_max real(default), dimension(2), intent(in) :: xb real(default), intent(in) :: y xi_max = one - max (xi_max_isr_plus (xb(I_PLUS), y), xi_max_isr_minus (xb(I_MINUS), y)) end function get_xi_max_isr @ %def get_xi_max_isr @ <>= function xi_max_isr_plus (x, y) real(default) :: xi_max_isr_plus real(default), intent(in) :: x, y real(default) :: deno deno = sqrt ((one + x**2)**2 * (one - y)**2 + 16 * y * x**2) + (one - y) * (1 - x**2) xi_max_isr_plus = two * (one + y) * x**2 / deno end function xi_max_isr_plus function xi_max_isr_minus (x, y) real(default) :: xi_max_isr_minus real(default), intent(in) :: x, y real(default) :: deno deno = sqrt ((one + x**2)**2 * (one + y)**2 - 16 * y * x**2) + (one + y) * (1 - x**2) xi_max_isr_minus = two * (one - y) * x**2 / deno end function xi_max_isr_minus @ %def xi_max_isr_plus, xi_max_isr_minus @ <>= recursive function get_xi_max_isr_decay (p) result (xi_max) real(default) :: xi_max type(vector4_t), dimension(:), intent(in) :: p integer :: n_tot type(vector4_t), dimension(:), allocatable :: p_dec_new n_tot = size (p) if (n_tot == 3) then xi_max = xi_max_one_to_two (p(1), p(2), p(3)) else allocate (p_dec_new (n_tot - 1)) p_dec_new(1) = sum (p (3 : )) p_dec_new(2 : n_tot - 1) = p (3 : n_tot) xi_max = min (xi_max_one_to_two (p(1), p(2), sum(p(3 : ))), & get_xi_max_isr_decay (p_dec_new)) end if contains function xi_max_one_to_two (p_in, p_out1, p_out2) result (xi_max) real(default) :: xi_max type(vector4_t), intent(in) :: p_in, p_out1, p_out2 real(default) :: m_in, m_out1, m_out2 m_in = p_in**1 m_out1 = p_out1**1; m_out2 = p_out2**1 xi_max = one - (m_out1 + m_out2)**2 / m_in**2 end function xi_max_one_to_two end function get_xi_max_isr_decay @ %def get_xi_max_isr_decay @ \subsection{Creation of the real phase space - ISR} <>= procedure :: generate_isr => phs_fks_generate_isr <>= subroutine phs_fks_generate_isr (phs, i_phs, p_real) class(phs_fks_t), intent(inout) :: phs integer, intent(in) :: i_phs type(vector4_t), intent(inout), dimension(:) :: p_real type(vector4_t) :: p0, p1 type(lorentz_transformation_t) :: lt real(default) :: sqrts_hat type(vector4_t), dimension(:), allocatable :: p_work associate (generator => phs%generator) select case (generator%n_in) case (1) allocate (p_work (1:generator%real_kinematics%p_born_cms%get_n_particles()), & source = generator%real_kinematics%p_born_cms%phs_point(1)%p) call generator%generate_isr_fixed_beam_energy (i_phs, p_work, p_real) phs%config%cm_frame = .true. case (2) select case (generator%isr_kinematics%isr_mode) case (SQRTS_FIXED) allocate (p_work (1:generator%real_kinematics%p_born_cms%get_n_particles()), & source = generator%real_kinematics%p_born_cms%phs_point(1)%p) call generator%generate_isr_fixed_beam_energy (i_phs, p_work, p_real) case (SQRTS_VAR) allocate (p_work (1:generator%real_kinematics%p_born_lab%get_n_particles()), & source = generator%real_kinematics%p_born_lab%phs_point(1)%p) call generator%generate_isr (i_phs, p_work, p_real) end select end select generator%real_kinematics%p_real_lab%phs_point(i_phs)%p = p_real if (.not. phs%config%cm_frame) then sqrts_hat = (p_real(1) + p_real(2))**1 p0 = p_real(1) + p_real(2) lt = boost (p0, sqrts_hat) p1 = inverse(lt) * p_real(1) lt = lt * rotation_to_2nd (3, space_part (p1)) phs%generator%real_kinematics%p_real_cms%phs_point(i_phs)%p = & inverse (lt) * p_real else phs%generator%real_kinematics%p_real_cms%phs_point(i_phs)%p = p_real end if end associate end subroutine phs_fks_generate_isr @ %def phs_fks_generate_isr @ The real phase space for an inital-state emission involved in a decay process is generated by first setting the gluon momentum like in the scattering case by using its angular coordinates $y$ and $\phi$ and then adjusting the gluon energy with $\xi$. The emitter momentum is kept identical to the Born case, i.e. $p_{\rm{in}} = \bar{p}_{\rm{in}}$, so that after the emission it has momentum $p_{\rm{virt}} = p_{\rm{in}} - p_{\rm{g}}$ and invariant mass $m^2 = p_{\rm{virt}}^2$. Note that the final state momenta have to remain on-shell, so that $p_1^2 = \bar{p}_1^2 = m_1^2$ and $p_2^2 = \bar{p}_2^2 = m_2^2$. Let $\Lambda$ be the boost from into the rest frame of the emitter after emission, i.e. $\Lambda p_{\rm{virt}} = \left(m, 0, 0, 0\right)$. In this reference frame, the spatial components of the final-state momenta sum up to zero, and their magnitude is \begin{equation*} p = \frac{\sqrt {\lambda (m^2, m_1^2, m_2^2)}}{2m}, \end{equation*} a fact already used in the evaluation of the phase space trees of [[phs_forest]]. Obviously, from this, the final-state energies can be deferred via $E_i^2 = m_i^2 - p^2$. In the next step, the $p_{1,2}$ are set up as vectors $(E,0,0,\pm p)$ along the z-axis and then rotated about the same azimuthal and polar angles as in the Born system. Finally, the momenta are boosted out of the rest frame by multiplying with $\Lambda$. <>= procedure :: generate_isr_fixed_beam_energy => phs_fks_generator_generate_isr_fixed_beam_energy <>= subroutine phs_fks_generator_generate_isr_fixed_beam_energy (generator, i_phs, p_born, p_real) class(phs_fks_generator_t), intent(inout) :: generator integer, intent(in) :: i_phs type(vector4_t), intent(in), dimension(:) :: p_born type(vector4_t), intent(inout), dimension(:) :: p_real real(default) :: xi_max, xi, y, phi integer :: nlegborn, nlegreal, i real(default) :: k0_np1 real(default) :: msq_in type(vector4_t) :: p_virt real(default) :: jac_real associate (rad_var => generator%real_kinematics) xi_max = rad_var%xi_max(i_phs) xi = rad_var%xi_tilde * xi_max y = rad_var%y(i_phs) phi = rad_var%phi rad_var%y_soft(i_phs) = y end associate nlegborn = size (p_born) nlegreal = nlegborn + 1 msq_in = sum (p_born(1:generator%n_in))**2 generator%real_kinematics%jac(i_phs)%jac = one p_real(1) = p_born(1) if (generator%n_in > 1) p_real(2) = p_born(2) k0_np1 = zero do i = 1, generator%n_in k0_np1 = k0_np1 + p_real(i)%p(0) * xi / two end do p_real(nlegreal)%p(0) = k0_np1 p_real(nlegreal)%p(1) = k0_np1 * sqrt(one - y**2) * sin(phi) p_real(nlegreal)%p(2) = k0_np1 * sqrt(one - y**2) * cos(phi) p_real(nlegreal)%p(3) = k0_np1 * y p_virt = sum (p_real(1:generator%n_in)) - p_real(nlegreal) jac_real = one call generate_on_shell_decay (p_virt, & p_born(generator%n_in + 1 : nlegborn), p_real(generator%n_in + 1 : nlegreal - 1), & 1, msq_in, jac_real) associate (jac => generator%real_kinematics%jac(i_phs)) jac%jac(1) = jac_real jac%jac(2) = one end associate end subroutine phs_fks_generator_generate_isr_fixed_beam_energy @ %def phs_fks_generator_generate_isr_fixed_beam_energy @ <>= procedure :: generate_isr_factorized => phs_fks_generator_generate_isr_factorized <>= subroutine phs_fks_generator_generate_isr_factorized (generator, i_phs, emitter, p_born, p_real) class(phs_fks_generator_t), intent(inout) :: generator integer, intent(in) :: i_phs, emitter type(vector4_t), intent(in), dimension(:) :: p_born type(vector4_t), intent(inout), dimension(:) :: p_real type(vector4_t), dimension(3) :: p_tmp_born type(vector4_t), dimension(4) :: p_tmp_real type(vector4_t) :: p_top type(lorentz_transformation_t) :: boost_to_rest_frame integer, parameter :: nlegreal = 7 !!! Factorized phase space so far only required for ee -> bwbw p_tmp_born = vector4_null; p_tmp_real = vector4_null p_real(1:2) = p_born(1:2) if (emitter == THR_POS_B) then p_top = p_born (THR_POS_WP) + p_born (THR_POS_B) p_tmp_born(2) = p_born (THR_POS_WP) p_tmp_born(3) = p_born (THR_POS_B) else if (emitter == THR_POS_BBAR) then p_top = p_born (THR_POS_WM) + p_born (THR_POS_BBAR) p_tmp_born(2) = p_born (THR_POS_WM) p_tmp_born(3) = p_born (THR_POS_BBAR) else call msg_fatal ("Threshold computation requires emitters to be at position 5 and 6 " // & "Please check if your process specification fulfills this requirement.") end if p_tmp_born (1) = p_top boost_to_rest_frame = inverse (boost (p_top, p_top**1)) p_tmp_born = boost_to_rest_frame * p_tmp_born call generator%compute_xi_max_isr_factorized (i_phs, p_tmp_born) call generator%generate_isr_fixed_beam_energy (i_phs, p_tmp_born, p_tmp_real) p_tmp_real = inverse (boost_to_rest_frame) * p_tmp_real if (emitter == THR_POS_B) then p_real(THR_POS_WP) = p_tmp_real(2) p_real(THR_POS_B) = p_tmp_real(3) p_real(THR_POS_WM) = p_born(THR_POS_WM) p_real(THR_POS_BBAR) = p_born(THR_POS_BBAR) !!! Exception has been handled above else p_real(THR_POS_WM) = p_tmp_real(2) p_real(THR_POS_BBAR) = p_tmp_real(3) p_real(THR_POS_WP) = p_born(THR_POS_WP) p_real(THR_POS_B) = p_born(THR_POS_B) end if p_real(nlegreal) = p_tmp_real(4) end subroutine phs_fks_generator_generate_isr_factorized @ %def phs_fks_generator_generate_isr_factorized @ <>= procedure :: generate_isr => phs_fks_generator_generate_isr <>= subroutine phs_fks_generator_generate_isr (generator, i_phs, p_born, p_real) !!! Important: Import momenta in the lab frame class(phs_fks_generator_t), intent(inout) :: generator integer, intent(in) :: i_phs type(vector4_t), intent(in) , dimension(:) :: p_born type(vector4_t), intent(inout), dimension(:) :: p_real real(default) :: xi_max, xi_tilde, xi, y, phi integer :: nlegborn, nlegreal real(default) :: sqrts_real real(default) :: k0_np1 type(lorentz_transformation_t) :: lambda_transv, lambda_longit, lambda_longit_inv real(default) :: x_plus, x_minus, xb_plus, xb_minus real(default) :: onemy, onepy integer :: i real(default) :: xi_plus, xi_minus real(default) :: beta_gamma type(vector3_t) :: beta_vec associate (rad_var => generator%real_kinematics) xi_max = rad_var%xi_max(i_phs) xi_tilde = rad_var%xi_tilde xi = xi_tilde * xi_max y = rad_var%y(i_phs) onemy = one - y; onepy = one + y phi = rad_var%phi rad_var%y_soft(i_phs) = y end associate nlegborn = size (p_born) nlegreal = nlegborn + 1 generator%isr_kinematics%sqrts_born = (p_born(1) + p_born(2))**1 !!! Initial state real momenta xb_plus = generator%isr_kinematics%x(I_PLUS) xb_minus = generator%isr_kinematics%x(I_MINUS) x_plus = xb_plus / sqrt(one - xi) * sqrt ((two - xi * onemy) / (two - xi * onepy)) x_minus = xb_minus / sqrt(one - xi) * sqrt ((two - xi * onepy) / (two - xi * onemy)) xi_plus = xi_tilde * (one - xb_plus) xi_minus = xi_tilde * (one - xb_minus) p_real(I_PLUS) = x_plus / xb_plus * p_born(I_PLUS) p_real(I_MINUS) = x_minus / xb_minus * p_born(I_MINUS) generator%isr_kinematics%z(I_PLUS) = x_plus / xb_plus generator%isr_kinematics%z(I_MINUS) = x_minus / xb_minus generator%isr_kinematics%z_coll(I_PLUS) = one / (one - xi_plus) generator%isr_kinematics%z_coll(I_MINUS) = one / (one - xi_minus) !!! Create radiation momentum sqrts_real = generator%isr_kinematics%sqrts_born / sqrt (one - xi) k0_np1 = sqrts_real * xi / two p_real(nlegreal)%p(0) = k0_np1 p_real(nlegreal)%p(1) = k0_np1 * sqrt (one - y**2) * sin(phi) p_real(nlegreal)%p(2) = k0_np1 * sqrt (one - y**2) * cos(phi) p_real(nlegreal)%p(3) = k0_np1 * y call get_boost_parameters (p_real, beta_gamma, beta_vec) lambda_longit = create_longitudinal_boost (beta_gamma, beta_vec, inverse = .true.) p_real(nlegreal) = lambda_longit * p_real(nlegreal) call get_boost_parameters (p_born, beta_gamma, beta_vec) lambda_longit = create_longitudinal_boost (beta_gamma, beta_vec, inverse = .false.) forall (i = 3 : nlegborn) p_real(i) = lambda_longit * p_born(i) lambda_transv = create_transversal_boost (p_real(nlegreal), xi, sqrts_real) forall (i = 3 : nlegborn) p_real(i) = lambda_transv * p_real(i) lambda_longit_inv = create_longitudinal_boost (beta_gamma, beta_vec, inverse = .true.) forall (i = 3 : nlegborn) p_real(i) = lambda_longit_inv * p_real(i) !!! Compute jacobians associate (jac => generator%real_kinematics%jac(i_phs)) !!! Additional 1 / (1 - xi) factor because in the real jacobian, !!! there is s_real in the numerator !!! We also have to adapt the flux factor, which is 1/2s_real for the real component !!! The reweighting factor is s_born / s_real, cancelling the (1-x) factor from above jac%jac(1) = one / (one - xi) jac%jac(2) = one jac%jac(3) = one / (one - xi_plus)**2 jac%jac(4) = one / (one - xi_minus)**2 end associate contains subroutine get_boost_parameters (p, beta_gamma, beta_vec) type(vector4_t), intent(in), dimension(:) :: p real(default), intent(out) :: beta_gamma type(vector3_t), intent(out) :: beta_vec beta_vec = (p(1)%p(1:3) + p(2)%p(1:3)) / (p(1)%p(0) + p(2)%p(0)) beta_gamma = beta_vec**1 / sqrt (one - beta_vec**2) beta_vec = beta_vec / beta_vec**1 end subroutine get_boost_parameters function create_longitudinal_boost (beta_gamma, beta_vec, inverse) result (lambda) real(default), intent(in) :: beta_gamma type(vector3_t), intent(in) :: beta_vec logical, intent(in) :: inverse type(lorentz_transformation_t) :: lambda if (inverse) then lambda = boost (beta_gamma, beta_vec) else lambda = boost (-beta_gamma, beta_vec) end if end function create_longitudinal_boost function create_transversal_boost (p_rad, xi, sqrts_real) result (lambda) type(vector4_t), intent(in) :: p_rad real(default), intent(in) :: xi, sqrts_real type(lorentz_transformation_t) :: lambda type(vector3_t) :: vec_transverse real(default) :: pt2, beta, beta_gamma pt2 = transverse_part (p_rad)**2 beta = one / sqrt (one + sqrts_real**2 * (one - xi) / pt2) beta_gamma = beta / sqrt (one - beta**2) vec_transverse%p(1:2) = p_rad%p(1:2) vec_transverse%p(3) = zero vec_transverse = normalize (vec_transverse) lambda = boost (-beta_gamma, vec_transverse) end function create_transversal_boost end subroutine phs_fks_generator_generate_isr @ %def phs_fks_generator_generate_isr @ <>= procedure :: set_sqrts_hat => phs_fks_generator_set_sqrts_hat <>= subroutine phs_fks_generator_set_sqrts_hat (generator, sqrts) class(phs_fks_generator_t), intent(inout) :: generator real(default), intent(in) :: sqrts generator%sqrts = sqrts end subroutine phs_fks_generator_set_sqrts_hat @ %def phs_fks_generator_set_sqrts_hat @ <>= procedure :: set_emitters => phs_fks_generator_set_emitters <>= subroutine phs_fks_generator_set_emitters (generator, emitters) class(phs_fks_generator_t), intent(inout) :: generator integer, intent(in), dimension(:), allocatable :: emitters allocate (generator%emitters (size (emitters))) generator%emitters = emitters end subroutine phs_fks_generator_set_emitters @ %def phs_fks_generator_set_emitters @ <>= procedure :: setup_masses => phs_fks_generator_setup_masses <>= subroutine phs_fks_generator_setup_masses (generator, n_tot) class (phs_fks_generator_t), intent(inout) :: generator integer, intent(in) :: n_tot if (.not. allocated (generator%m2)) then allocate (generator%is_massive (n_tot)) allocate (generator%m2 (n_tot)) generator%is_massive = .false. generator%m2 = zero end if end subroutine phs_fks_generator_setup_masses @ %def phs_fks_generator_setup_masses @ <>= procedure :: set_xi_and_y_bounds => phs_fks_generator_set_xi_and_y_bounds <>= subroutine phs_fks_generator_set_xi_and_y_bounds (generator, xi_min, y_max) class(phs_fks_generator_t), intent(inout) :: generator real(default), intent(in) :: xi_min, y_max generator%xi_min = xi_min generator%y_max = y_max end subroutine phs_fks_generator_set_xi_and_y_bounds @ %def phs_fks_generator_set_xi_and_y_bounds @ <>= procedure :: set_isr_kinematics => phs_fks_generator_set_isr_kinematics <>= subroutine phs_fks_generator_set_isr_kinematics (generator, p) class(phs_fks_generator_t), intent(inout) :: generator type(vector4_t), dimension(2), intent(in) :: p generator%isr_kinematics%x = p%p(0) / generator%isr_kinematics%beam_energy end subroutine phs_fks_generator_set_isr_kinematics @ %def phs_fks_generator_set_isr_kinematics @ <>= procedure :: generate_radiation_variables => & phs_fks_generator_generate_radiation_variables <>= subroutine phs_fks_generator_generate_radiation_variables & (generator, r_in, p_born, phs_identifiers, threshold) class(phs_fks_generator_t), intent(inout) :: generator real(default), intent(in), dimension(:) :: r_in type(vector4_t), intent(in), dimension(:) :: p_born type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers logical, intent(in), optional :: threshold associate (rad_var => generator%real_kinematics) rad_var%phi = r_in (I_PHI) * twopi select case (generator%mode) case (GEN_REAL_PHASE_SPACE) rad_var%jac_rand = twopi call generator%compute_y_real_phs (r_in(I_Y), p_born, phs_identifiers, & rad_var%jac_rand, rad_var%y, threshold) case (GEN_SOFT_MISMATCH) rad_var%jac_mismatch = twopi call generator%compute_y_mismatch (r_in(I_Y), rad_var%jac_mismatch, & rad_var%y_mismatch, rad_var%y_soft) case default call generator%compute_y_test (rad_var%y) end select call generator%compute_xi_tilde (r_in(I_XI)) call generator%set_masses (p_born, phs_identifiers) end associate end subroutine phs_fks_generator_generate_radiation_variables @ %def phs_fks_generator_generate_radiation_variables @ <>= procedure :: compute_xi_ref_momenta => phs_fks_generator_compute_xi_ref_momenta <>= subroutine phs_fks_generator_compute_xi_ref_momenta & (generator, p_born, resonance_contributors) class(phs_fks_generator_t), intent(inout) :: generator type(vector4_t), intent(in), dimension(:) :: p_born type(resonance_contributors_t), intent(in), dimension(:), optional & :: resonance_contributors integer :: i_con, n_contributors if (present (resonance_contributors)) then n_contributors = size (resonance_contributors) if (.not. allocated (generator%resonance_contributors)) & allocate (generator%resonance_contributors (n_contributors)) do i_con = 1, n_contributors generator%real_kinematics%xi_ref_momenta(i_con) = & get_resonance_momentum (p_born, resonance_contributors(i_con)%c) generator%resonance_contributors(i_con) = resonance_contributors(i_con) end do else generator%real_kinematics%xi_ref_momenta(1) = sum (p_born(1:generator%n_in)) end if end subroutine phs_fks_generator_compute_xi_ref_momenta @ %def phs_fks_generator_compute_xi_ref_momenta @ <>= procedure :: compute_xi_ref_momenta_threshold & => phs_fks_generator_compute_xi_ref_momenta_threshold <>= subroutine phs_fks_generator_compute_xi_ref_momenta_threshold (generator, p_born) class(phs_fks_generator_t), intent(inout) :: generator type(vector4_t), intent(in), dimension(:) :: p_born generator%real_kinematics%xi_ref_momenta(1) = p_born(THR_POS_WP) + p_born(THR_POS_B) generator%real_kinematics%xi_ref_momenta(2) = p_born(THR_POS_WM) + p_born(THR_POS_BBAR) end subroutine phs_fks_generator_compute_xi_ref_momenta_threshold @ %def phs_fks_generator_compute_xi_ref_momenta @ <>= procedure :: compute_cms_energy => phs_fks_generator_compute_cms_energy <>= subroutine phs_fks_generator_compute_cms_energy (generator, p_born) class(phs_fks_generator_t), intent(inout) :: generator type(vector4_t), intent(in), dimension(:) :: p_born type(vector4_t) :: p_sum p_sum = sum (p_born (1 : generator%n_in)) generator%real_kinematics%cms_energy2 = p_sum**2 end subroutine phs_fks_generator_compute_cms_energy @ %def phs_fks_generator_compute_cms_energy @ <>= procedure :: compute_xi_max => phs_fks_generator_compute_xi_max <>= subroutine phs_fks_generator_compute_xi_max (generator, emitter, & i_phs, p, xi_max, i_con, y_in) class(phs_fks_generator_t), intent(inout) :: generator integer, intent(in) :: i_phs, emitter type(vector4_t), intent(in), dimension(:) :: p real(default), intent(out) :: xi_max integer, intent(in), optional :: i_con real(default), intent(in), optional :: y_in real(default) :: q0 type(vector4_t), dimension(:), allocatable :: pp, pp_decay type(vector4_t) :: p_res type(lorentz_transformation_t) :: L_to_resonance real(default) :: y if (.not. any (generator%emitters == emitter)) return allocate (pp (size (p))) associate (rad_var => generator%real_kinematics) if (present (i_con)) then q0 = rad_var%xi_ref_momenta(i_con)**1 else q0 = energy (sum (p(1:generator%n_in))) end if if (present (y_in)) then y = y_in else y = rad_var%y(i_phs) end if if (present (i_con)) then p_res = rad_var%xi_ref_momenta(i_con) L_to_resonance = inverse (boost (p_res, q0)) pp = L_to_resonance * p else pp = p end if if (emitter <= generator%n_in) then select case (generator%isr_kinematics%isr_mode) case (SQRTS_FIXED) if (generator%n_in > 1) then allocate (pp_decay (size (pp) - 1)) else allocate (pp_decay (size (pp))) end if pp_decay (1) = sum (pp(1:generator%n_in)) pp_decay (2 : ) = pp (generator%n_in + 1 : ) xi_max = get_xi_max_isr_decay (pp_decay) deallocate (pp_decay) case (SQRTS_VAR) xi_max = get_xi_max_isr (generator%isr_kinematics%x, y) end select else if (generator%is_massive(emitter)) then xi_max = get_xi_max_fsr (pp, q0, emitter, generator%m2(emitter), y) else xi_max = get_xi_max_fsr (pp, q0, emitter) end if end if deallocate (pp) end associate end subroutine phs_fks_generator_compute_xi_max @ %def phs_fks_generator_compute_xi_max @ <>= procedure :: compute_xi_max_isr_factorized & => phs_fks_generator_compute_xi_max_isr_factorized <>= subroutine phs_fks_generator_compute_xi_max_isr_factorized & (generator, i_phs, p) class(phs_fks_generator_t), intent(inout) :: generator integer, intent(in) :: i_phs type(vector4_t), intent(in), dimension(:) :: p generator%real_kinematics%xi_max(i_phs) = get_xi_max_isr_decay (p) end subroutine phs_fks_generator_compute_xi_max_isr_factorized @ %def phs_fks_generator_compute_xi_max_isr_factorized @ <>= procedure :: set_masses => phs_fks_generator_set_masses <>= subroutine phs_fks_generator_set_masses (generator, p, phs_identifiers) class(phs_fks_generator_t), intent(inout) :: generator type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers type(vector4_t), intent(in), dimension(:) :: p integer :: emitter, i_phs do i_phs = 1, size (phs_identifiers) emitter = phs_identifiers(i_phs)%emitter if (any (generator%emitters == emitter) .and. emitter > 0) then if (generator%is_massive (emitter) .and. emitter > generator%n_in) & generator%m2(emitter) = p(emitter)**2 end if end do end subroutine phs_fks_generator_set_masses @ %def phs_fhs_generator_set_masses @ <>= public :: compute_y_from_emitter <>= subroutine compute_y_from_emitter (r_y, p, n_in, emitter, massive, & y_max, jac_rand, y, contributors, threshold) real(default), intent(in) :: r_y type(vector4_t), intent(in), dimension(:) :: p integer, intent(in) :: n_in integer, intent(in) :: emitter logical, intent(in) :: massive real(default), intent(in) :: y_max real(default), intent(inout) :: jac_rand real(default), intent(out) :: y integer, intent(in), dimension(:), allocatable, optional :: contributors logical, intent(in), optional :: threshold logical :: thr, resonance type(vector4_t) :: p_res, p_em real(default) :: q0 type(lorentz_transformation_t) :: boost_to_resonance integer :: i real(default) :: beta, one_m_beta, one_p_beta thr = .false.; if (present (threshold)) thr = threshold p_res = vector4_null if (present (contributors)) then resonance = allocated (contributors) else resonance = .false. end if if (massive) then if (resonance) then do i = 1, size (contributors) p_res = p_res + p(contributors(i)) end do else if (thr) then p_res = p(ass_boson(thr_leg(emitter))) + p(ass_quark(thr_leg(emitter))) else p_res = sum (p(1:n_in)) end if q0 = p_res**1 boost_to_resonance = inverse (boost (p_res, q0)) p_em = boost_to_resonance * p(emitter) beta = beta_emitter (q0, p_em) one_m_beta = one - beta one_p_beta = one + beta y = one / beta * (one - one_p_beta * & exp ( - r_y * log(one_p_beta / one_m_beta))) jac_rand = jac_rand * & (one - beta * y) * log(one_p_beta / one_m_beta) / beta else y = (one - two * r_y) * y_max jac_rand = jac_rand * 3 * (one - y**2) y = 1.5_default * (y - y**3 / 3) end if end subroutine compute_y_from_emitter @ %def compute_y_from_emitter @ <>= procedure :: compute_y_real_phs => phs_fks_generator_compute_y_real_phs <>= subroutine phs_fks_generator_compute_y_real_phs (generator, r_y, p, phs_identifiers, & jac_rand, y, threshold) class(phs_fks_generator_t), intent(inout) :: generator real(default), intent(in) :: r_y type(vector4_t), intent(in), dimension(:) :: p type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers real(default), intent(inout), dimension(:) :: jac_rand real(default), intent(out), dimension(:) :: y logical, intent(in), optional :: threshold real(default) :: beta, one_p_beta, one_m_beta type(lorentz_transformation_t) :: boost_to_resonance real(default) :: q0 type(vector4_t) :: p_res, p_em integer :: i, i_phs, emitter logical :: thr logical :: construct_massive_fsr construct_massive_fsr = .false. thr = .false.; if (present (threshold)) thr = threshold do i_phs = 1, size (phs_identifiers) emitter = phs_identifiers(i_phs)%emitter !!! We need this additional check because of decay phase spaces !!! t -> bW has a massive emitter at position 1, which should !!! not be treated here. construct_massive_fsr = emitter > generator%n_in if (construct_massive_fsr) construct_massive_fsr = & construct_massive_fsr .and. generator%is_massive (emitter) call compute_y_from_emitter (r_y, p, generator%n_in, emitter, construct_massive_fsr, & generator%y_max, jac_rand(i_phs), y(i_phs), & phs_identifiers(i_phs)%contributors, threshold) end do end subroutine phs_fks_generator_compute_y_real_phs @ %def phs_fks_generator_compute_y_real_phs @ <>= procedure :: compute_y_mismatch => phs_fks_generator_compute_y_mismatch <>= subroutine phs_fks_generator_compute_y_mismatch (generator, r_y, jac_rand, y, y_soft) class(phs_fks_generator_t), intent(inout) :: generator real(default), intent(in) :: r_y real(default), intent(inout) :: jac_rand real(default), intent(out) :: y real(default), intent(out), dimension(:) :: y_soft y = (one - two * r_y) * generator%y_max jac_rand = jac_rand * 3 * (one - y**2) y = 1.5_default * (y - y**3 / 3) y_soft = y end subroutine phs_fks_generator_compute_y_mismatch @ %def phs_fks_generator_compute_y_mismatch @ <>= procedure :: compute_y_test => phs_fks_generator_compute_y_test <>= subroutine phs_fks_generator_compute_y_test (generator, y) class(phs_fks_generator_t), intent(inout) :: generator real(default), intent(out), dimension(:):: y select case (generator%mode) case (GEN_SOFT_LIMIT_TEST) y = y_test_soft case (GEN_COLL_LIMIT_TEST) y = y_test_coll case (GEN_ANTI_COLL_LIMIT_TEST) y = - y_test_coll case (GEN_SOFT_COLL_LIMIT_TEST) y = y_test_coll case (GEN_SOFT_ANTI_COLL_LIMIT_TEST) y = - y_test_coll end select end subroutine phs_fks_generator_compute_y_test @ %def phs_fks_generator_compute_y_test @ <>= public :: beta_emitter <>= pure function beta_emitter (q0, p) result (beta) real(default), intent(in) :: q0 type(vector4_t), intent(in) :: p real(default) :: beta real(default) :: m2, mrec2, k0_max m2 = p**2 mrec2 = (q0 - p%p(0))**2 - p%p(1)**2 - p%p(2)**2 - p%p(3)**2 k0_max = (q0**2 - mrec2 + m2) / (two * q0) beta = sqrt(one - m2 / k0_max**2) end function beta_emitter @ %def beta_emitter @ <>= procedure :: compute_xi_tilde => phs_fks_generator_compute_xi_tilde <>= pure subroutine phs_fks_generator_compute_xi_tilde (generator, r) class(phs_fks_generator_t), intent(inout) :: generator real(default), intent(in) :: r real(default) :: deno associate (rad_var => generator%real_kinematics) select case (generator%mode) case (GEN_REAL_PHASE_SPACE) if (generator%singular_jacobian) then rad_var%xi_tilde = (one - generator%xi_min) - (one - r)**2 * & (one - two * generator%xi_min) rad_var%jac_rand = rad_var%jac_rand * two * (one - r) * & (one - two * generator%xi_min) else rad_var%xi_tilde = generator%xi_min + r * (one - generator%xi_min) rad_var%jac_rand = rad_var%jac_rand * (one - generator%xi_min) end if case (GEN_SOFT_MISMATCH) deno = one - r if (deno < tiny_13) deno = tiny_13 rad_var%xi_mismatch = generator%xi_min + r / deno rad_var%jac_mismatch = rad_var%jac_mismatch / deno**2 case (GEN_SOFT_LIMIT_TEST) rad_var%xi_tilde = r * two * xi_tilde_test_soft rad_var%jac_rand = two * xi_tilde_test_soft case (GEN_COLL_LIMIT_TEST) rad_var%xi_tilde = xi_tilde_test_coll rad_var%jac_rand = xi_tilde_test_coll case (GEN_ANTI_COLL_LIMIT_TEST) rad_var%xi_tilde = xi_tilde_test_coll rad_var%jac_rand = xi_tilde_test_coll case (GEN_SOFT_COLL_LIMIT_TEST) rad_var%xi_tilde = r * two * xi_tilde_test_soft rad_var%jac_rand = two * xi_tilde_test_soft case (GEN_SOFT_ANTI_COLL_LIMIT_TEST) rad_var%xi_tilde = r * two * xi_tilde_test_soft rad_var%jac_rand = two * xi_tilde_test_soft end select end associate end subroutine phs_fks_generator_compute_xi_tilde @ %def phs_fks_generator_compute_xi_tilde @ <>= procedure :: prepare_generation => phs_fks_generator_prepare_generation <>= subroutine phs_fks_generator_prepare_generation (generator, r_in, i_phs, & emitter, p_born, phs_identifiers, contributors, i_con) class(phs_fks_generator_t), intent(inout) :: generator real(default), dimension(3), intent(in) :: r_in integer, intent(in) :: i_phs, emitter type(vector4_t), intent(in), dimension(:) :: p_born type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers type(resonance_contributors_t), intent(in), dimension(:), optional :: contributors integer, intent(in), optional :: i_con call generator%generate_radiation_variables (r_in, p_born, phs_identifiers) call generator%compute_xi_ref_momenta (p_born, contributors) call generator%compute_xi_max (emitter, i_phs, p_born, & generator%real_kinematics%xi_max(i_phs), i_con = i_con) end subroutine phs_fks_generator_prepare_generation @ %def phs_fks_generator_prepare_generation @ Get [[xi]] and [[y]] from an external routine (e.g. [[powheg]]) and generate an FSR phase space. Note that the flag [[supply\_xi\_max]] is set to [[.false.]] because it is assumed that the upper bound on [[xi]] has already been taken into account during its generation. <>= procedure :: generate_fsr_from_xi_and_y => & phs_fks_generator_generate_fsr_from_xi_and_y <>= subroutine phs_fks_generator_generate_fsr_from_xi_and_y (generator, xi, y, & phi, emitter, i_phs, p_born, p_real) class(phs_fks_generator_t), intent(inout) :: generator real(default), intent(in) :: xi, y, phi integer, intent(in) :: emitter, i_phs type(vector4_t), intent(in), dimension(:) :: p_born type(vector4_t), intent(inout), dimension(:) :: p_real associate (rad_var => generator%real_kinematics) rad_var%supply_xi_max = .false. rad_var%xi_tilde = xi rad_var%y(i_phs) = y rad_var%phi = phi end associate call generator%set_sqrts_hat (p_born(1)%p(0) + p_born(2)%p(0)) call generator%generate_fsr (emitter, i_phs, p_born, p_real) end subroutine phs_fks_generator_generate_fsr_from_xi_and_y @ %def phs_fks_generator_generate_fsr_from_xi_and_y @ <>= procedure :: get_radiation_variables => & phs_fks_generator_get_radiation_variables <>= pure subroutine phs_fks_generator_get_radiation_variables (generator, & i_phs, xi, y, phi) class(phs_fks_generator_t), intent(in) :: generator integer, intent(in) :: i_phs real(default), intent(out) :: xi, y real(default), intent(out), optional :: phi associate (rad_var => generator%real_kinematics) xi = rad_var%xi_max(i_phs) * rad_var%xi_tilde y = rad_var%y(i_phs) if (present (phi)) phi = rad_var%phi end associate end subroutine phs_fks_generator_get_radiation_variables @ %def phs_fks_generator_get_radiation_variables @ <>= procedure :: write => phs_fks_generator_write <>= subroutine phs_fks_generator_write (generator, unit) class(phs_fks_generator_t), intent(in) :: generator integer, intent(in), optional :: unit integer :: u type(string_t) :: massive_phsp u = given_output_unit (unit); if (u < 0) return if (generator%massive_phsp) then massive_phsp = " massive " else massive_phsp = " massless " end if write (u, "(A)") char ("This is a generator for a" & // massive_phsp // "phase space") if (associated (generator%real_kinematics)) then call generator%real_kinematics%write () else write (u, "(A)") "Warning: There are no real " // & "kinematics associated with this generator" end if call write_separator (u) write (u, "(A,F5.3)") "sqrts: ", generator%sqrts write (u, "(A,F5.3)") "E_gluon: ", generator%E_gluon write (u, "(A,F5.3)") "mrec2: ", generator%mrec2 end subroutine phs_fks_generator_write @ %def phs_fks_generator_write @ <>= procedure :: compute_isr_kinematics => phs_fks_compute_isr_kinematics <>= subroutine phs_fks_compute_isr_kinematics (phs, r) class(phs_fks_t), intent(inout) :: phs real(default), intent(in) :: r if (.not. phs%config%cm_frame) then call phs%generator%compute_isr_kinematics (r, phs%lt_cm_to_lab * phs%phs_wood_t%p) else call phs%generator%compute_isr_kinematics (r, phs%phs_wood_t%p) end if end subroutine phs_fks_compute_isr_kinematics @ %def phs_fks_compute_isr_kinematics @ <>= procedure :: final => phs_fks_final <>= subroutine phs_fks_final (object) class(phs_fks_t), intent(inout) :: object call phs_forest_final (object%forest) call object%generator%final () end subroutine phs_fks_final @ %def phs_fks_final @ <>= public :: get_filtered_resonance_histories <>= subroutine filter_particles_from_resonances (res_hist, exclusion_list, & model, res_hist_filtered) type(resonance_history_t), intent(in), dimension(:) :: res_hist type(string_t), intent(in), dimension(:) :: exclusion_list type(model_t), intent(in) :: model type(resonance_history_t), intent(out), dimension(:), allocatable :: res_hist_filtered integer :: i_hist, i_flv, i_new, n_orig logical, dimension(size (res_hist)) :: to_filter type(flavor_t) :: flv to_filter = .false. n_orig = size (res_hist) do i_flv = 1, size (exclusion_list) call flv%init (exclusion_list (i_flv), model) do i_hist = 1, size (res_hist) if (res_hist(i_hist)%has_flavor (flv)) to_filter (i_hist) = .true. end do end do allocate (res_hist_filtered (n_orig - count (to_filter))) i_new = 1 do i_hist = 1, size (res_hist) if (.not. to_filter (i_hist)) then res_hist_filtered (i_new) = res_hist (i_hist) i_new = i_new + 1 end if end do end subroutine filter_particles_from_resonances @ %def filter_particles_from_resonances @ <>= subroutine clean_resonance_histories (res_hist, n_in, flv, res_hist_clean, success) type(resonance_history_t), intent(in), dimension(:) :: res_hist integer, intent(in) :: n_in integer, intent(in), dimension(:) :: flv type(resonance_history_t), intent(out), dimension(:), allocatable :: res_hist_clean logical, intent(out) :: success integer :: i_hist type(resonance_history_t), dimension(:), allocatable :: res_hist_colored, res_hist_contracted call msg_debug (D_SUBTRACTION, "resonance_mapping_init") if (debug_active (D_SUBTRACTION)) then call msg_debug (D_SUBTRACTION, "Original resonances:") do i_hist = 1, size(res_hist) call res_hist(i_hist)%write () end do end if call remove_uncolored_resonances () call contract_resonances (res_hist_colored, res_hist_contracted) call remove_subresonances (res_hist_contracted, res_hist_clean) !!! Here, we are still not sure whether we actually would rather use !!! call remove_multiple_resonances (res_hist_contracted, res_hist_clean) if (debug_active (D_SUBTRACTION)) then call msg_debug (D_SUBTRACTION, "Resonances after removing uncolored and duplicates: ") do i_hist = 1, size (res_hist_clean) call res_hist_clean(i_hist)%write () end do end if if (size (res_hist_clean) == 0) then call msg_warning ("No resonances found. Proceed in usual FKS mode.") success = .false. else success = .true. end if contains subroutine remove_uncolored_resonances () type(resonance_history_t), dimension(:), allocatable :: res_hist_tmp integer :: n_hist, nleg_out, n_removed integer :: i_res, i_hist n_hist = size (res_hist) nleg_out = size (flv) - n_in allocate (res_hist_tmp (n_hist)) allocate (res_hist_colored (n_hist)) do i_hist = 1, n_hist res_hist_tmp(i_hist) = res_hist(i_hist) call res_hist_tmp(i_hist)%add_offset (n_in) n_removed = 0 do i_res = 1, res_hist_tmp(i_hist)%n_resonances associate (resonance => res_hist_tmp(i_hist)%resonances(i_res - n_removed)) if (.not. any (is_colored (flv (resonance%contributors%c))) & .or. size (resonance%contributors%c) == nleg_out) then call res_hist_tmp(i_hist)%remove_resonance (i_res - n_removed) n_removed = n_removed + 1 end if end associate end do if (allocated (res_hist_tmp(i_hist)%resonances)) then if (any (res_hist_colored == res_hist_tmp(i_hist))) then cycle else do i_res = 1, res_hist_tmp(i_hist)%n_resonances associate (resonance => res_hist_tmp(i_hist)%resonances(i_res)) call res_hist_colored(i_hist)%add_resonance (resonance) end associate end do end if end if end do end subroutine remove_uncolored_resonances subroutine contract_resonances (res_history_in, res_history_out) type(resonance_history_t), intent(in), dimension(:) :: res_history_in type(resonance_history_t), intent(out), dimension(:), allocatable :: res_history_out logical, dimension(:), allocatable :: i_non_zero integer :: n_hist_non_zero, n_hist integer :: i_hist_new n_hist = size (res_history_in); n_hist_non_zero = 0 allocate (i_non_zero (n_hist)) i_non_zero = .false. do i_hist = 1, n_hist if (res_history_in(i_hist)%n_resonances /= 0) then n_hist_non_zero = n_hist_non_zero + 1 i_non_zero(i_hist) = .true. end if end do allocate (res_history_out (n_hist_non_zero)) i_hist_new = 1 do i_hist = 1, n_hist if (i_non_zero (i_hist)) then res_history_out (i_hist_new) = res_history_in (i_hist) i_hist_new = i_hist_new + 1 end if end do end subroutine contract_resonances subroutine remove_subresonances (res_history_in, res_history_out) type(resonance_history_t), intent(in), dimension(:) :: res_history_in type(resonance_history_t), intent(out), dimension(:), allocatable :: res_history_out logical, dimension(:), allocatable :: i_non_sub_res integer :: n_hist, n_hist_non_sub_res integer :: i_hist1, i_hist2 logical :: is_not_subres n_hist = size (res_history_in); n_hist_non_sub_res = 0 allocate (i_non_sub_res (n_hist)); i_non_sub_res = .false. do i_hist1 = 1, n_hist is_not_subres = .true. do i_hist2 = 1, n_hist if (i_hist1 == i_hist2) cycle is_not_subres = is_not_subres .and. & .not.(res_history_in(i_hist2) .contains. res_history_in(i_hist1)) end do if (is_not_subres) then n_hist_non_sub_res = n_hist_non_sub_res + 1 i_non_sub_res (i_hist1) = .true. end if end do allocate (res_history_out (n_hist_non_sub_res)) i_hist2 = 1 do i_hist1 = 1, n_hist if (i_non_sub_res (i_hist1)) then res_history_out (i_hist2) = res_history_in (i_hist1) i_hist2 = i_hist2 + 1 end if end do end subroutine remove_subresonances subroutine remove_multiple_resonances (res_history_in, res_history_out) type(resonance_history_t), intent(in), dimension(:) :: res_history_in type(resonance_history_t), intent(out), dimension(:), allocatable :: res_history_out integer :: n_hist, n_hist_single logical, dimension(:), allocatable :: i_hist_single integer :: i_hist, j n_hist = size (res_history_in) n_hist_single = 0 allocate (i_hist_single (n_hist)); i_hist_single = .false. do i_hist = 1, n_hist if (res_history_in(i_hist)%n_resonances == 1) then n_hist_single = n_hist_single + 1 i_hist_single(i_hist) = .true. end if end do allocate (res_history_out (n_hist_single)) j = 1 do i_hist = 1, n_hist if (i_hist_single(i_hist)) then res_history_out(j) = res_history_in(i_hist) j = j + 1 end if end do end subroutine remove_multiple_resonances end subroutine clean_resonance_histories @ %def clean_resonance_histories @ <>= subroutine get_filtered_resonance_histories (phs_config, n_in, flv_state, model, & excluded_resonances, resonance_histories_filtered, success) type(phs_fks_config_t), intent(inout) :: phs_config integer, intent(in) :: n_in integer, intent(in), dimension(:,:), allocatable :: flv_state type(model_t), intent(in) :: model type(string_t), intent(in), dimension(:), allocatable :: excluded_resonances type(resonance_history_t), intent(out), dimension(:), & allocatable :: resonance_histories_filtered logical, intent(out) :: success type(resonance_history_t), dimension(:), allocatable :: resonance_histories type(resonance_history_t), dimension(:), allocatable :: & resonance_histories_clean!, resonance_histories_filtered allocate (resonance_histories (size (phs_config%get_resonance_histories ()))) resonance_histories = phs_config%get_resonance_histories () call clean_resonance_histories (resonance_histories, & n_in, flv_state (:,1), resonance_histories_clean, success) if (success .and. allocated (excluded_resonances)) then call filter_particles_from_resonances (resonance_histories_clean, & excluded_resonances, model, resonance_histories_filtered) else allocate (resonance_histories_filtered (size (resonance_histories_clean))) resonance_histories_filtered = resonance_histories_clean end if end subroutine get_filtered_resonance_histories @ %def get_filtered_resonance_histories @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Unit tests} Test module for FKS phase space, followed by the corresponding implementation module. <<[[phs_fks_ut.f90]]>>= <> module phs_fks_ut use unit_tests use phs_fks_uti <> <> contains <> end module phs_fks_ut @ %def phs_fks_ut @ <<[[phs_fks_uti.f90]]>>= <> module phs_fks_uti <> use format_utils, only: write_separator, pac_fmt use format_defs, only: FMT_15, FMT_19 use numeric_utils, only: nearly_equal use constants, only: tiny_07, zero, one, two use lorentz use physics_defs, only: THR_POS_B, THR_POS_BBAR, THR_POS_WP, THR_POS_WM, THR_POS_GLUON use physics_defs, only: thr_leg use resonances, only: resonance_contributors_t use phs_fks <> <> contains <> end module phs_fks_uti @ %def phs_fks_uti @ API: driver for the unit tests below. <>= public :: phs_fks_generator_test <>= subroutine phs_fks_generator_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results call test(phs_fks_generator_1, "phs_fks_generator_1", & "Test the generation of FKS phase spaces", u, results) call test(phs_fks_generator_2, "phs_fks_generator_2", & "Test the generation of an ISR FKS phase space", u, results) call test(phs_fks_generator_3, "phs_fks_generator_3", & "Test the generation of a real phase space for decays", & u, results) call test(phs_fks_generator_4, "phs_fks_generator_4", & "Test the generation of an FSR phase space with "& &"conserved invariant resonance masses", u, results) call test(phs_fks_generator_5, "phs_fks_generator_5", & "Test on-shell projection of a Born phase space and the generation"& &" of a real phase-space from that", u, results) call test(phs_fks_generator_6, "phs_fks_generator_6", & "Test the generation of a real phase space for 1 -> 3 decays", & u, results) call test(phs_fks_generator_7, "phs_fks_generator_7", & "Test the generation of an ISR FKS phase space for fixed beam energy", & u, results) end subroutine phs_fks_generator_test @ %def phs_fks_generator_test @ <>= public :: phs_fks_generator_1 <>= subroutine phs_fks_generator_1 (u) integer, intent(in) :: u type(phs_fks_generator_t) :: generator type(vector4_t), dimension(:), allocatable :: p_born type(vector4_t), dimension(:), allocatable :: p_real integer :: emitter, i_phs real(default) :: x1, x2, x3 real(default), parameter :: sqrts = 250.0_default type(phs_identifier_t), dimension(2) :: phs_identifiers write (u, "(A)") "* Test output: phs_fks_generator_1" write (u, "(A)") "* Purpose: Create massless fsr phase space" write (u, "(A)") allocate (p_born (4)) p_born(1)%p(0) = 125.0_default p_born(1)%p(1:2) = 0.0_default p_born(1)%p(3) = 125.0_default p_born(2)%p(0) = 125.0_default p_born(2)%p(1:2) = 0.0_default p_born(2)%p(3) = -125.0_default p_born(3)%p(0) = 125.0_default p_born(3)%p(1) = -39.5618_default p_born(3)%p(2) = -20.0791_default p_born(3)%p(3) = -114.6957_default p_born(4)%p(0) = 125.0_default p_born(4)%p(1:3) = -p_born(3)%p(1:3) allocate (generator%isr_kinematics) generator%n_in = 2 generator%isr_kinematics%isr_mode = SQRTS_FIXED call generator%set_sqrts_hat (sqrts) write (u, "(A)") "* Use four-particle phase space containing: " call vector4_write_set (p_born, u, testflag = .true., ultra = .true.) write (u, "(A)") "***********************" write (u, "(A)") x1 = 0.5_default; x2 = 0.25_default; x3 = 0.75_default write (u, "(A)" ) "* Use random numbers: " write (u, "(A,F3.2,1X,A,F3.2,1X,A,F3.2)") & "x1: ", x1, "x2: ", x2, "x3: ", x3 allocate (generator%real_kinematics) call generator%real_kinematics%init (4, 2, 2, 1) allocate (generator%emitters (2)) generator%emitters(1) = 3; generator%emitters(2) = 4 allocate (generator%m2 (4)) generator%m2 = zero allocate (generator%is_massive (4)) generator%is_massive(1:2) = .false. generator%is_massive(3:4) = .true. phs_identifiers(1)%emitter = 3 phs_identifiers(2)%emitter = 4 call generator%compute_xi_ref_momenta (p_born) call generator%generate_radiation_variables ([x1,x2,x3], p_born, phs_identifiers) do i_phs = 1, 2 emitter = phs_identifiers(i_phs)%emitter call generator%compute_xi_max (emitter, i_phs, p_born, & generator%real_kinematics%xi_max(i_phs)) end do write (u, "(A)") & "* With these, the following radiation variables have been produced:" associate (rad_var => generator%real_kinematics) write (u, "(A,F3.2)") "xi_tilde: ", rad_var%xi_tilde write (u, "(A,F3.2)") "y: " , rad_var%y(1) write (u, "(A,F3.2)") "phi: ", rad_var%phi end associate call write_separator (u) write (u, "(A)") "Produce real momenta: " i_phs = 1; emitter = phs_identifiers(i_phs)%emitter write (u, "(A,I1)") "emitter: ", emitter allocate (p_real (5)) call generator%generate_fsr (emitter, i_phs, p_born, p_real) call vector4_write_set (p_real, u, testflag = .true., ultra = .true.) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Test output end: phs_fks_generator_1" end subroutine phs_fks_generator_1 @ %def phs_fks_generator_1 @ <>= public :: phs_fks_generator_2 <>= subroutine phs_fks_generator_2 (u) integer, intent(in) :: u type(phs_fks_generator_t) :: generator type(vector4_t), dimension(:), allocatable :: p_born type(vector4_t), dimension(:), allocatable :: p_real integer :: emitter, i_phs real(default) :: x1, x2, x3 real(default), parameter :: sqrts_hadronic = 250.0_default type(phs_identifier_t), dimension(2) :: phs_identifiers write (u, "(A)") "* Test output: phs_fks_generator_2" write (u, "(A)") "* Purpose: Create massless ISR phase space" write (u, "(A)") allocate (p_born (4)) p_born(1)%p(0) = 114.661_default p_born(1)%p(1:2) = 0.0_default p_born(1)%p(3) = 114.661_default p_born(2)%p(0) = 121.784_default p_born(2)%p(1:2) = 0.0_default p_born(2)%p(3) = -121.784_default p_born(3)%p(0) = 115.148_default p_born(3)%p(1) = -46.250_default p_born(3)%p(2) = -37.711_default p_born(3)%p(3) = 98.478_default p_born(4)%p(0) = 121.296_default p_born(4)%p(1:2) = -p_born(3)%p(1:2) p_born(4)%p(3) = -105.601_default phs_identifiers(1)%emitter = 1 phs_identifiers(2)%emitter = 2 allocate (generator%emitters (2)) allocate (generator%isr_kinematics) generator%emitters(1) = 1; generator%emitters(2) = 2 generator%sqrts = sqrts_hadronic generator%isr_kinematics%beam_energy = sqrts_hadronic / two call generator%set_sqrts_hat (sqrts_hadronic) call generator%set_isr_kinematics (p_born) generator%n_in = 2 generator%isr_kinematics%isr_mode = SQRTS_VAR write (u, "(A)") "* Use four-particle phase space containing: " call vector4_write_set (p_born, u, testflag = .true., ultra = .true.) write (u, "(A)") "***********************" write (u, "(A)") x1=0.5_default; x2=0.25_default; x3=0.65_default write (u, "(A)" ) "* Use random numbers: " write (u, "(A,F3.2,1X,A,F3.2,1X,A,F3.2)") & "x1: ", x1, "x2: ", x2, "x3: ", x3 allocate (generator%real_kinematics) call generator%real_kinematics%init (4, 2, 2, 1) call generator%real_kinematics%p_born_lab%set_momenta (1, p_born) allocate (generator%m2 (2)) generator%m2(1) = 0._default; generator%m2(2) = 0._default allocate (generator%is_massive (4)) generator%is_massive = .false. call generator%generate_radiation_variables ([x1,x2,x3], p_born, phs_identifiers) call generator%compute_xi_ref_momenta (p_born) do i_phs = 1, 2 emitter = phs_identifiers(i_phs)%emitter call generator%compute_xi_max (emitter, i_phs, p_born, & generator%real_kinematics%xi_max(i_phs)) end do write (u, "(A)") & "* With these, the following radiation variables have been produced:" associate (rad_var => generator%real_kinematics) write (u, "(A,F3.2)") "xi_tilde: ", rad_var%xi_tilde write (u, "(A,F3.2)") "y: " , rad_var%y(1) write (u, "(A,F3.2)") "phi: ", rad_var%phi end associate write (u, "(A)") "Initial-state momentum fractions: " associate (xb => generator%isr_kinematics%x) write (u, "(A,F3.2)") "x_born_plus: ", xb(1) write (u, "(A,F3.2)") "x_born_minus: ", xb(2) end associate call write_separator (u) write (u, "(A)") "Produce real momenta: " i_phs = 1; emitter = phs_identifiers(i_phs)%emitter write (u, "(A,I1)") "emitter: ", emitter allocate (p_real(5)) call generator%generate_isr (i_phs, p_born, p_real) call vector4_write_set (p_real, u, testflag = .true., ultra = .true.) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Test output end: phs_fks_generator_2" end subroutine phs_fks_generator_2 @ %def phs_fks_generator_2 @ <>= public :: phs_fks_generator_3 <>= subroutine phs_fks_generator_3 (u) integer, intent(in) :: u type(phs_fks_generator_t) :: generator type(vector4_t), dimension(:), allocatable :: p_born type(vector4_t), dimension(:), allocatable :: p_real real(default) :: x1, x2, x3 real(default) :: mB, mW, mT integer :: i, emitter, i_phs type(phs_identifier_t), dimension(2) :: phs_identifiers write (u, "(A)") "* Test output: phs_fks_generator_3" write (u, "(A)") "* Puropse: Create real phase space for particle decays" write (u, "(A)") allocate (p_born(3)) p_born(1)%p(0) = 172._default p_born(1)%p(1) = 0._default p_born(1)%p(2) = 0._default p_born(1)%p(3) = 0._default p_born(2)%p(0) = 104.72866679_default p_born(2)%p(1) = 45.028053213_default p_born(2)%p(2) = 29.450337581_default p_born(2)%p(3) = -5.910229156_default p_born(3)%p(0) = 67.271333209_default p_born(3)%p(1:3) = -p_born(2)%p(1:3) generator%n_in = 1 allocate (generator%isr_kinematics) generator%isr_kinematics%isr_mode = SQRTS_FIXED mB = 4.2_default mW = 80.376_default mT = 172._default generator%sqrts = mT write (u, "(A)") "* Use three-particle phase space containing: " call vector4_write_set (p_born, u, testflag = .true., ultra = .true.) write (u, "(A)") "**********************" write (u, "(A)") x1 = 0.5_default; x2 = 0.25_default; x3 = 0.6_default write (u, "(A)") "* Use random numbers: " write (u, "(A,F3.2,1X,A,F3.2,A,1X,F3.2)") & "x1: ", x1, "x2: ", x2, "x3: ", x3 allocate (generator%real_kinematics) call generator%real_kinematics%init (3, 2, 2, 1) call generator%real_kinematics%p_born_lab%set_momenta (1, p_born) allocate (generator%emitters(2)) generator%emitters(1) = 1 generator%emitters(2) = 3 allocate (generator%m2 (3), generator%is_massive(3)) generator%m2(1) = mT**2 generator%m2(2) = mW**2 generator%m2(3) = mB**2 generator%is_massive = .true. phs_identifiers(1)%emitter = 1 phs_identifiers(2)%emitter = 3 call generator%generate_radiation_variables ([x1,x2,x3], p_born, phs_identifiers) call generator%compute_xi_ref_momenta (p_born) do i_phs = 1, 2 emitter = phs_identifiers(i_phs)%emitter call generator%compute_xi_max (emitter, i_phs, p_born, & generator%real_kinematics%xi_max(i_phs)) end do write (u, "(A)") & "* With these, the following radiation variables have been produced: " associate (rad_var => generator%real_kinematics) write (u, "(A,F4.2)") "xi_tilde: ", rad_var%xi_tilde do i = 1, 2 write (u, "(A,I1,A,F5.2)") "i: ", i, "y: " , rad_var%y(i) end do write (u, "(A,F4.2)") "phi: ", rad_var%phi end associate call write_separator (u) write (u, "(A)") "Produce real momenta via initial-state emission: " i_phs = 1; emitter = phs_identifiers(i_phs)%emitter write (u, "(A,I1)") "emitter: ", emitter allocate (p_real (4)) call generator%generate_isr_fixed_beam_energy (i_phs, p_born, p_real) call pacify (p_real, 1E-6_default) call vector4_write_set (p_real, u, testflag = .true., ultra = .true.) call write_separator(u) write (u, "(A)") "Produce real momenta via final-state emisson: " i_phs = 2; emitter = phs_identifiers(i_phs)%emitter write (u, "(A,I1)") "emitter: ", emitter call generator%generate_fsr (emitter, i_phs, p_born, p_real) call pacify (p_real, 1E-6_default) call vector4_write_set (p_real, u, testflag = .true., ultra = .true.) write (u, "(A)") write (u, "(A)") "* Test output end: phs_fks_generator_3" end subroutine phs_fks_generator_3 @ %def phs_fks_generator_3 @ <>= public :: phs_fks_generator_4 <>= subroutine phs_fks_generator_4 (u) integer, intent(in) :: u type(phs_fks_generator_t) :: generator type(vector4_t), dimension(:), allocatable :: p_born type(vector4_t), dimension(:), allocatable :: p_real integer, dimension(:), allocatable :: emitters integer, dimension(:,:), allocatable :: resonance_lists type(resonance_contributors_t), dimension(2) :: alr_contributors real(default) :: x1, x2, x3 real(default), parameter :: sqrts = 250.0_default integer, parameter :: nlegborn = 6 integer :: i_phs, i_con, emitter real(default) :: m_inv_born, m_inv_real character(len=7) :: fmt type(phs_identifier_t), dimension(2) :: phs_identifiers call pac_fmt (fmt, FMT_19, FMT_15, .true.) write (u, "(A)") "* Test output: phs_fks_generator_4" write (u, "(A)") "* Purpose: Create FSR phase space with fixed resonances" write (u, "(A)") allocate (p_born (nlegborn)) p_born(1)%p(0) = 250._default p_born(1)%p(1) = 0._default p_born(1)%p(2) = 0._default p_born(1)%p(3) = 250._default p_born(2)%p(0) = 250._default p_born(2)%p(1) = 0._default p_born(2)%p(2) = 0._default p_born(2)%p(3) = -250._default p_born(3)%p(0) = 145.91184486_default p_born(3)%p(1) = 50.39727589_default p_born(3)%p(2) = 86.74156041_default p_born(3)%p(3) = -69.03608748_default p_born(4)%p(0) = 208.1064784_default p_born(4)%p(1) = -44.07610020_default p_born(4)%p(2) = -186.34264578_default p_born(4)%p(3) = 13.48038407_default p_born(5)%p(0) = 26.25614471_default p_born(5)%p(1) = -25.12258068_default p_born(5)%p(2) = -1.09540228_default p_born(5)%p(3) = -6.27703505_default p_born(6)%p(0) = 119.72553196_default p_born(6)%p(1) = 18.80140499_default p_born(6)%p(2) = 100.69648766_default p_born(6)%p(3) = 61.83273846_default allocate (generator%isr_kinematics) generator%n_in = 2 generator%isr_kinematics%isr_mode = SQRTS_FIXED call generator%set_sqrts_hat (sqrts) write (u, "(A)") "* Test process: e+ e- -> W+ W- b b~" write (u, "(A)") "* Resonance pairs: (3,5) and (4,6)" write (u, "(A)") "* Use four-particle phase space containing: " call vector4_write_set (p_born, u, testflag = .true., ultra = .true.) write (u, "(A)") "******************************" write (u, "(A)") x1 = 0.5_default; x2 = 0.25_default; x3 = 0.75_default write (u, "(A)") "* Use random numbers: " write (u, "(A,F3.2,1X,A,F3.2,1X,A,F3.2)") & "x1: ", x1, "x2: ", x2, "x3: ", x3 allocate (generator%real_kinematics) call generator%real_kinematics%init (nlegborn, 2, 2, 2) allocate (generator%emitters (2)) generator%emitters(1) = 5; generator%emitters(2) = 6 allocate (generator%m2 (nlegborn)) generator%m2 = p_born**2 allocate (generator%is_massive (nlegborn)) generator%is_massive (1:2) = .false. generator%is_massive (3:6) = .true. phs_identifiers(1)%emitter = 5 phs_identifiers(2)%emitter = 6 do i_phs = 1, 2 allocate (phs_identifiers(i_phs)%contributors (2)) end do allocate (resonance_lists (2, 2)) resonance_lists (1,:) = [3,5] resonance_lists (2,:) = [4,6] !!! Here is obviously some redundance. Surely we can improve on this. do i_phs = 1, 2 phs_identifiers(i_phs)%contributors = resonance_lists(i_phs,:) end do do i_con = 1, 2 allocate (alr_contributors(i_con)%c (size (resonance_lists(i_con,:)))) alr_contributors(i_con)%c = resonance_lists(i_con,:) end do call generator%generate_radiation_variables & ([x1, x2, x3], p_born, phs_identifiers) allocate (p_real(nlegborn + 1)) call generator%compute_xi_ref_momenta (p_born, alr_contributors) !!! Keep the distinction between i_phs and i_con because in general, !!! they are not the same. do i_phs = 1, 2 i_con = i_phs emitter = phs_identifiers(i_phs)%emitter write (u, "(A,I1,1X,A,I1,A,I1,A)") & "* Generate FSR phase space for emitter ", emitter, & "and resonance pair (", resonance_lists (i_con, 1), ",", & resonance_lists (i_con, 2), ")" call generator%compute_xi_max (emitter, i_phs, p_born, & generator%real_kinematics%xi_max(i_phs), i_con = i_con) call generator%generate_fsr (emitter, i_phs, i_con, p_born, p_real) call vector4_write_set (p_real, u, testflag = .true., ultra = .true.) call write_separator(u) write (u, "(A)") "* Check if resonance masses are conserved: " m_inv_born = compute_resonance_mass (p_born, resonance_lists (i_con,:)) m_inv_real = compute_resonance_mass (p_real, resonance_lists (i_con,:), 7) write (u, "(A,1X, " // fmt // ")") "m_inv_born = ", m_inv_born write (u, "(A,1X, " // fmt // ")") "m_inv_real = ", m_inv_real if (abs (m_inv_born - m_inv_real) < tiny_07) then write (u, "(A)") " Success! " else write (u, "(A)") " Failure! " end if call write_separator(u) call write_separator(u) end do deallocate (p_real) write (u, "(A)") write (u, "(A)") "* Test output end: phs_fks_generator_4" end subroutine phs_fks_generator_4 @ %def phs_fks_generator_4 @ <>= public :: phs_fks_generator_5 <>= subroutine phs_fks_generator_5 (u) use ttv_formfactors, only: init_parameters integer, intent(in) :: u type(phs_fks_generator_t) :: generator type(vector4_t), dimension(:), allocatable :: p_born type(vector4_t), dimension(:), allocatable :: p_born_onshell type(vector4_t), dimension(:), allocatable :: p_real real(default) :: x1, x2, x3 real(default) :: mB, mW, mtop, mcheck integer :: i, emitter, i_phs type(phs_identifier_t), dimension(2) :: phs_identifiers type(lorentz_transformation_t) :: L_to_cms real(default), parameter :: sqrts = 360._default real(default), parameter :: momentum_tolerance = 1E-10_default real(default) :: mpole, gam_out write (u, "(A)") "* Test output: phs_fks_generator_5" write (u, "(A)") "* Puropse: Perform threshold on-shell projection of " write (u, "(A)") "* Born momenta and create a real phase-space " write (u, "(A)") "* point from those. " write (u, "(A)") allocate (p_born(6), p_born_onshell(6)) p_born(1)%p(0) = sqrts / two p_born(1)%p(1:2) = zero p_born(1)%p(3) = sqrts / two p_born(2)%p(0) = sqrts / two p_born(2)%p(1:2) = zero p_born(2)%p(3) = -sqrts / two p_born(3)%p(0) = 117.1179139230_default p_born(3)%p(1) = 56.91215483880_default p_born(3)%p(2) = -40.02386013017_default p_born(3)%p(3) = -49.07634310496_default p_born(4)%p(0) = 98.91904548743_default p_born(4)%p(1) = 56.02241403836_default p_born(4)%p(2) = -8.302977504723_default p_born(4)%p(3) = -10.50293716131_default p_born(5)%p(0) = 62.25884689208_default p_born(5)%p(1) = -60.00786540278_default p_born(5)%p(2) = 4.753602375910_default p_born(5)%p(3) = 15.32916731546_default p_born(6)%p(0) = 81.70419369751_default p_born(6)%p(1) = -52.92670347439_default p_born(6)%p(2) = 43.57323525898_default p_born(6)%p(3) = 44.25011295081_default generator%n_in = 2 allocate (generator%isr_kinematics) generator%isr_kinematics%isr_mode = SQRTS_FIXED mB = 4.2_default mW = 80.376_default mtop = 172._default generator%sqrts = sqrts !!! Dummy-initialization of the threshold model because generate_fsr_threshold !!! uses m1s_to_mpole to determine if it is above or below threshold. call init_parameters (mpole, gam_out, mtop, one, one / 1.5_default, 125._default, & 0.47_default, 0.118_default, 91._default, 80._default, 4.2_default, & one, one, one, one, zero, zero, zero, zero, zero, zero, .false., zero) write (u, "(A)") "* Use four-particle phase space containing: " call vector4_write_set (p_born, u, testflag = .true., ultra = .true.) call vector4_check_momentum_conservation & (p_born, 2, unit = u, abs_smallness = momentum_tolerance, verbose = .true.) write (u, "(A)") "**********************" write (u, "(A)") allocate (generator%real_kinematics) call generator%real_kinematics%init (7, 2, 2, 2) call generator%real_kinematics%init_onshell (7, 2) generator%real_kinematics%p_born_cms%phs_point(1)%p = p_born write (u, "(A)") "Get boost projection system -> CMS: " L_to_cms = get_boost_for_threshold_projection (p_born, sqrts, mtop) call L_to_cms%write (u, testflag = .true., ultra = .true.) write (u, "(A)") "**********************" write (u, "(A)") write (u, "(A)") "* Perform onshell-projection:" associate (p_born => generator%real_kinematics%p_born_cms%phs_point(1)%p, & p_born_onshell => generator%real_kinematics%p_born_onshell%phs_point(1)%p) call threshold_projection_born (mtop, L_to_cms, p_born, p_born_onshell) end associate call generator%real_kinematics%p_born_onshell%write (1, unit = u, testflag = .true., & ultra = .true.) associate (p => generator%real_kinematics%p_born_onshell%phs_point(1)%p) p_born_onshell = p call check_phsp (p, 0) end associate allocate (generator%emitters (2)) generator%emitters(1) = THR_POS_B; generator%emitters(2) = THR_POS_BBAR allocate (generator%m2 (6), generator%is_massive(6)) generator%m2 = p_born**2 generator%is_massive (1:2) = .false. generator%is_massive (3:6) = .true. phs_identifiers(1)%emitter = THR_POS_B phs_identifiers(2)%emitter = THR_POS_BBAR x1 = 0.5_default; x2 = 0.25_default; x3 = 0.6_default write (u, "(A)") "* Use random numbers: " write (u, "(A,F3.2,1X,A,F3.2,A,1X,F3.2)") & "x1: ", x1, "x2: ", x2, "x3: ", x3 call generator%generate_radiation_variables ([x1,x2,x3], p_born_onshell, phs_identifiers) do i_phs = 1, 2 emitter = phs_identifiers(i_phs)%emitter call generator%compute_xi_ref_momenta_threshold (p_born_onshell) call generator%compute_xi_max (emitter, i_phs, p_born_onshell, & generator%real_kinematics%xi_max(i_phs), i_con = thr_leg(emitter)) end do write (u, "(A)") & "* With these, the following radiation variables have been produced: " associate (rad_var => generator%real_kinematics) write (u, "(A,F4.2)") "xi_tilde: ", rad_var%xi_tilde write (u, "(A)") "xi_max: " write (u, "(2F5.2)") rad_var%xi_max(1), rad_var%xi_max(2) write (u, "(A)") "y: " write (u, "(2F5.2)") rad_var%y(1), rad_var%y(2) write (u, "(A,F4.2)") "phi: ", rad_var%phi end associate call write_separator (u) write (u, "(A)") "* Produce real momenta from on-shell phase space: " allocate (p_real(7)) do i_phs = 1, 2 emitter = phs_identifiers(i_phs)%emitter write (u, "(A,I1)") "emitter: ", emitter call generator%generate_fsr_threshold (emitter, i_phs, p_born_onshell, p_real) call check_phsp (p_real, emitter) end do call write_separator(u) write (u, "(A)") write (u, "(A)") "* Test output end: phs_fks_generator_5" contains subroutine check_phsp (p, emitter) type(vector4_t), intent(inout), dimension(:) :: p integer, intent(in) :: emitter type(vector4_t) :: pp real(default) :: E_tot logical :: check write (u, "(A)") "* Check momentum conservation: " call vector4_check_momentum_conservation & (p, 2, unit = u, abs_smallness = momentum_tolerance, verbose = .true.) write (u, "(A)") "* Check invariant masses: " write (u, "(A)", advance = "no") "inv(W+, b, gl): " pp = p(THR_POS_WP) + p(THR_POS_B) if (emitter == THR_POS_B) pp = pp + p(THR_POS_GLUON) if (nearly_equal (pp**1, mtop)) then write (u, "(A)") "CHECK" else write (u, "(A,F7.3)") "FAIL: ", pp**1 end if write (u, "(A)", advance = "no") "inv(W-, bbar): " pp = p(THR_POS_WM) + p(THR_POS_BBAR) if (emitter == THR_POS_BBAR) pp = pp + p(THR_POS_GLUON) if (nearly_equal (pp**1, mtop)) then write (u, "(A)") "CHECK" else write (u, "(A,F7.3)") "FAIL: ", pp**1 end if write (u, "(A)") "* Sum of energies equal to sqrts?" E_tot = sum(p(1:2)%p(0)); check = nearly_equal (E_tot, sqrts) write (u, "(A,L1)") "Initial state: ", check if (.not. check) write (u, "(A,F7.3)") "E_tot: ", E_tot if (emitter > 0) then E_tot = sum(p(3:7)%p(0)) else E_tot = sum(p(3:6)%p(0)) end if check = nearly_equal (E_tot, sqrts) write (u, "(A,L1)") "Final state : ", check if (.not. check) write (u, "(A,F7.3)") "E_tot: ", E_tot call pacify (p, 1E-6_default) call vector4_write_set (p, u, testflag = .true., ultra = .true.) end subroutine check_phsp end subroutine phs_fks_generator_5 @ %def phs_fks_generator_5 @ <>= public :: phs_fks_generator_6 <>= subroutine phs_fks_generator_6 (u) integer, intent(in) :: u type(phs_fks_generator_t) :: generator type(vector4_t), dimension(:), allocatable :: p_born type(vector4_t), dimension(:), allocatable :: p_real real(default) :: x1, x2, x3 real(default) :: mB, mW, mT integer :: i, emitter, i_phs type(phs_identifier_t), dimension(2) :: phs_identifiers write (u, "(A)") "* Test output: phs_fks_generator_6" write (u, "(A)") "* Puropse: Create real phase space for particle decays" write (u, "(A)") allocate (p_born(4)) p_born(1)%p(0) = 173.1_default p_born(1)%p(1) = zero p_born(1)%p(2) = zero p_born(1)%p(3) = zero p_born(2)%p(0) = 68.17074462929_default p_born(2)%p(1) = -37.32578717617_default p_born(2)%p(2) = 30.99675959336_default p_born(2)%p(3) = -47.70321718398_default p_born(3)%p(0) = 65.26639312326_default p_born(3)%p(1) = -1.362927648502_default p_born(3)%p(2) = -33.25327150840_default p_born(3)%p(3) = 56.14324922494_default p_born(4)%p(0) = 39.66286224745_default p_born(4)%p(1) = 38.68871482467_default p_born(4)%p(2) = 2.256511915049_default p_born(4)%p(3) = -8.440032040958_default generator%n_in = 1 allocate (generator%isr_kinematics) generator%isr_kinematics%isr_mode = SQRTS_FIXED mB = 4.2_default mW = 80.376_default mT = 173.1_default generator%sqrts = mT write (u, "(A)") "* Use four-particle phase space containing: " call vector4_write_set (p_born, u, testflag = .true., ultra = .true.) write (u, "(A)") "**********************" write (u, "(A)") x1=0.5_default; x2=0.25_default; x3=0.6_default write (u, "(A)") "* Use random numbers: " write (u, "(A,F3.2,1X,A,F3.2,A,1X,F3.2)") & "x1: ", x1, "x2: ", x2, "x3: ", x3 allocate (generator%real_kinematics) call generator%real_kinematics%init (3, 2, 2, 1) call generator%real_kinematics%p_born_lab%set_momenta (1, p_born) allocate (generator%emitters(2)) generator%emitters(1) = 1 generator%emitters(2) = 2 allocate (generator%m2 (4), generator%is_massive(4)) generator%m2(1) = mT**2 generator%m2(2) = mB**2 generator%m2(3) = zero generator%m2(4) = zero generator%is_massive(1:2) = .true. generator%is_massive(3:4) = .false. phs_identifiers(1)%emitter = 1 phs_identifiers(2)%emitter = 2 call generator%generate_radiation_variables ([x1,x2,x3], p_born, phs_identifiers) call generator%compute_xi_ref_momenta (p_born) do i_phs = 1, 2 emitter = phs_identifiers(i_phs)%emitter call generator%compute_xi_max (emitter, i_phs, p_born, & generator%real_kinematics%xi_max(i_phs)) end do write (u, "(A)") & "* With these, the following radiation variables have been produced: " associate (rad_var => generator%real_kinematics) write (u, "(A,F4.2)") "xi_tilde: ", rad_var%xi_tilde do i = 1, 2 write (u, "(A,I1,A,F5.2)") "i: ", i, "y: " , rad_var%y(i) end do write (u, "(A,F4.2)") "phi: ", rad_var%phi end associate call write_separator (u) write (u, "(A)") "Produce real momenta via initial-state emission: " i_phs = 1; emitter = phs_identifiers(i_phs)%emitter write (u, "(A,I1)") "emitter: ", emitter allocate (p_real(5)) call generator%generate_isr_fixed_beam_energy (i_phs, p_born, p_real) call pacify (p_real, 1E-6_default) call vector4_write_set (p_real, u, testflag = .true., ultra = .true.) call write_separator(u) write (u, "(A)") "Produce real momenta via final-state emisson: " i_phs = 2; emitter = phs_identifiers(i_phs)%emitter write (u, "(A,I1)") "emitter: ", emitter call generator%generate_fsr (emitter, i_phs, p_born, p_real) call pacify (p_real, 1E-6_default) call vector4_write_set (p_real, u, testflag = .true., ultra = .true.) write (u, "(A)") write (u, "(A)") "* Test output end: phs_fks_generator_6" end subroutine phs_fks_generator_6 @ %def phs_fks_generator_6 @ <>= public :: phs_fks_generator_7 <>= subroutine phs_fks_generator_7 (u) integer, intent(in) :: u type(phs_fks_generator_t) :: generator type(vector4_t), dimension(:), allocatable :: p_born type(vector4_t), dimension(:), allocatable :: p_real real(default) :: x1, x2, x3 integer :: i, emitter, i_phs type(phs_identifier_t), dimension(2) :: phs_identifiers real(default), parameter :: sqrts = 1000.0_default write (u, "(A)") "* Test output: phs_fks_generator_7" write (u, "(A)") "* Puropse: Create real phase space for scattering ISR" write (u, "(A)") "* keeping the beam energy fixed." write (u, "(A)") allocate (p_born(4)) p_born(1)%p(0) = 500._default p_born(1)%p(1) = 0._default p_born(1)%p(2) = 0._default p_born(1)%p(3) = 500._default p_born(2)%p(0) = 500._default p_born(2)%p(1) = 0._default p_born(2)%p(2) = 0._default p_born(2)%p(3) = -500._default p_born(3)%p(0) = 500._default p_born(3)%p(1) = 11.275563070_default p_born(3)%p(2) = -13.588797663_default p_born(3)%p(3) = 486.93070588_default p_born(4)%p(0) = 500._default p_born(4)%p(1:3) = -p_born(3)%p(1:3) phs_identifiers(1)%emitter = 1 phs_identifiers(2)%emitter = 2 allocate (generator%emitters(2)) generator%n_in = 2 allocate (generator%isr_kinematics) generator%isr_kinematics%isr_mode = SQRTS_FIXED generator%emitters(1) = 1; generator%emitters(2) = 2 generator%sqrts = sqrts write (u, "(A)") "* Use 2 -> 2 phase space containing: " call vector4_write_set (p_born, u, testflag = .true., ultra = .true.) write (u, "(A)") "**********************" write (u, "(A)") x1 = 0.5_default; x2 = 0.25_default; x3 = 0.6_default write (u, "(A)") "* Use random numbers: " write (u, "(A,F3.2,1X,A,F3.2,A,1X,F3.2)") & "x1: ", x1, "x2: ", x2, "x3: ", x3 allocate (generator%real_kinematics) call generator%real_kinematics%init (4, 2, 2, 1) call generator%real_kinematics%p_born_lab%set_momenta (1, p_born) allocate (generator%m2 (4)) generator%m2 = 0._default allocate (generator%is_massive(4)) generator%is_massive = .false. call generator%generate_radiation_variables ([x1,x2,x3], p_born, phs_identifiers) call generator%compute_xi_ref_momenta (p_born) do i_phs = 1, 2 emitter = phs_identifiers(i_phs)%emitter call generator%compute_xi_max (emitter, i_phs, p_born, & generator%real_kinematics%xi_max(i_phs)) end do write (u, "(A)") & "* With these, the following radiation variables have been produced: " associate (rad_var => generator%real_kinematics) write (u, "(A,F4.2)") "xi_tilde: ", rad_var%xi_tilde do i = 1, 2 write (u, "(A,I1,A,F5.2)") "i: ", i, "y: " , rad_var%y(i) end do write (u, "(A,F4.2)") "phi: ", rad_var%phi end associate call write_separator (u) write (u, "(A)") "Produce real momenta via initial-state emission: " i_phs = 1; emitter = phs_identifiers(i_phs)%emitter write (u, "(A,I1)") "emitter: ", emitter allocate (p_real(5)) call generator%generate_isr_fixed_beam_energy (i_phs, p_born, p_real) call pacify (p_real, 1E-6_default) call vector4_write_set (p_real, u, testflag = .true., ultra = .true.) call write_separator(u) i_phs = 2; emitter = phs_identifiers(i_phs)%emitter write (u, "(A,I1)") "emitter: ", emitter call generator%generate_isr_fixed_beam_energy (i_phs, p_born, p_real) call pacify (p_real, 1E-6_default) call vector4_write_set (p_real, u, testflag = .true., ultra = .true.) write (u, "(A)") write (u, "(A)") "* Test output end: phs_fks_generator_7" end subroutine phs_fks_generator_7 @ %def phs_fks_generator_3 @ \section{Dispatch} <<[[dispatch_phase_space.f90]]>>= <> module dispatch_phase_space <> <> use io_units, only: free_unit use variables, only: var_list_t use os_interface, only: os_data_t use diagnostics use sf_mappings, only: sf_channel_t use beam_structures, only: beam_structure_t use dispatch_beams, only: sf_prop_t, strfun_mode use mappings use phs_forests, only: phs_parameters_t use phs_base use phs_none use phs_single use phs_rambo use phs_wood use phs_fks <> <> contains <> end module dispatch_phase_space @ %def dispatch_phase_space Allocate a phase-space object according to the variable [[$phs_method]]. <>= public :: dispatch_phs <>= subroutine dispatch_phs (phs, var_list, os_data, process_id, & mapping_defaults, phs_par, phs_method_in) class(phs_config_t), allocatable, intent(inout) :: phs type(var_list_t), intent(in) :: var_list type(os_data_t), intent(in) :: os_data type(string_t), intent(in) :: process_id type(mapping_defaults_t), intent(in), optional :: mapping_defaults type(phs_parameters_t), intent(in), optional :: phs_par type(string_t), intent(in), optional :: phs_method_in type(string_t) :: phs_method, phs_file, run_id logical :: use_equivalences, vis_channels, fatal_beam_decay integer :: u_phs logical :: exist if (present (phs_method_in)) then phs_method = phs_method_in else phs_method = & var_list%get_sval (var_str ("$phs_method")) end if phs_file = & var_list%get_sval (var_str ("$phs_file")) use_equivalences = & var_list%get_lval (var_str ("?use_vamp_equivalences")) vis_channels = & var_list%get_lval (var_str ("?vis_channels")) fatal_beam_decay = & var_list%get_lval (var_str ("?fatal_beam_decay")) run_id = & var_list%get_sval (var_str ("$run_id")) select case (char (phs_method)) case ("none") allocate (phs_none_config_t :: phs) case ("single") allocate (phs_single_config_t :: phs) if (vis_channels) then call msg_warning ("Visualizing phase space channels not " // & "available for method 'single'.") end if case ("rambo") allocate (phs_rambo_config_t :: phs) if (vis_channels) & call msg_warning ("Visualizing phase space channels not " // & "available for method 'rambo'.") case ("fks") allocate (phs_fks_config_t :: phs) case ("wood", "default", "fast_wood") call dispatch_wood () case default call msg_fatal ("Phase space: parameterization method '" & // char (phs_method) // "' not implemented") end select contains <> end subroutine dispatch_phs @ %def dispatch_phs @ <>= subroutine dispatch_wood () allocate (phs_wood_config_t :: phs) select type (phs) type is (phs_wood_config_t) if (phs_file /= "") then inquire (file = char (phs_file), exist = exist) if (exist) then call msg_message ("Phase space: reading configuration from '" & // char (phs_file) // "'") u_phs = free_unit () open (u_phs, file = char (phs_file), & action = "read", status = "old") call phs%set_input (u_phs) else call msg_fatal ("Phase space: configuration file '" & // char (phs_file) // "' not found") end if end if if (present (phs_par)) & call phs%set_parameters (phs_par) if (use_equivalences) & call phs%enable_equivalences () if (present (mapping_defaults)) & call phs%set_mapping_defaults (mapping_defaults) if (phs_method == "fast_wood") phs%use_cascades2 = .true. phs%vis_channels = vis_channels phs%fatal_beam_decay = fatal_beam_decay phs%os_data = os_data phs%run_id = run_id end select end subroutine dispatch_wood @ @ Configure channel mappings, using some conditions from the phase space configuration. If there are no structure functions, we enable a default setup with a single (dummy) structure-function channel. Otherwise, we look at the channel collection that we got from the phase-space configuration step. Each entry should be translated into an independent structure-function channel, where typically there is one default entry, which could be mapped using a standard s-channel mapping if the structure function setup recommends this, and other entries with s-channel resonances. The latter need to be translated into global mappings from the structure-function chain. <>= public :: dispatch_sf_channels <>= subroutine dispatch_sf_channels (sf_channel, sf_string, sf_prop, coll, & var_list, sqrts, beam_structure) type(sf_channel_t), dimension(:), allocatable, intent(out) :: sf_channel type(string_t), intent(out) :: sf_string type(sf_prop_t), intent(in) :: sf_prop type(phs_channel_collection_t), intent(in) :: coll type(var_list_t), intent(in) :: var_list real(default), intent(in) :: sqrts type(beam_structure_t), intent(in) :: beam_structure type(beam_structure_t) :: beam_structure_tmp class(channel_prop_t), allocatable :: prop integer :: n_strfun, n_sf_channel, i logical :: sf_allow_s_mapping, circe1_map, circe1_generate logical :: s_mapping_enable, endpoint_mapping, power_mapping logical :: single_parameter integer, dimension(:), allocatable :: s_mapping, single_mapping real(default) :: s_mapping_power real(default) :: circe1_mapping_slope, endpoint_mapping_slope real(default) :: power_mapping_eps beam_structure_tmp = beam_structure - call beam_structure_tmp%write () call beam_structure_tmp%expand (strfun_mode) n_strfun = beam_structure_tmp%get_n_record () sf_string = beam_structure_tmp%to_string (sf_only = .true.) sf_allow_s_mapping = & var_list%get_lval (var_str ("?sf_allow_s_mapping")) circe1_generate = & var_list%get_lval (var_str ("?circe1_generate")) circe1_map = & var_list%get_lval (var_str ("?circe1_map")) circe1_mapping_slope = & var_list%get_rval (var_str ("circe1_mapping_slope")) s_mapping_enable = .false. s_mapping_power = 1 endpoint_mapping = .false. endpoint_mapping_slope = 1 power_mapping = .false. single_parameter = .false. select case (char (sf_string)) case ("", "[any particles]") case ("pdf_builtin, none", & "pdf_builtin_photon, none", & "none, pdf_builtin", & "none, pdf_builtin_photon", & "lhapdf, none", & "lhapdf_photon, none", & "none, lhapdf", & "none, lhapdf_photon") single_parameter = .true. case ("pdf_builtin, none => none, pdf_builtin", & "pdf_builtin, none => none, pdf_builtin_photon", & "pdf_builtin_photon, none => none, pdf_builtin", & "pdf_builtin_photon, none => none, pdf_builtin_photon", & "lhapdf, none => none, lhapdf", & "lhapdf, none => none, lhapdf_photon", & "lhapdf_photon, none => none, lhapdf", & "lhapdf_photon, none => none, lhapdf_photon") allocate (s_mapping (2), source = [1, 2]) s_mapping_enable = .true. s_mapping_power = 2 case ("pdf_builtin, none => none, pdf_builtin => epa, none => none, epa", & "pdf_builtin, none => none, pdf_builtin => ewa, none => none, ewa", & "pdf_builtin, none => none, pdf_builtin => ewa, none => none, epa", & "pdf_builtin, none => none, pdf_builtin => epa, none => none, ewa") allocate (s_mapping (2), source = [1, 2]) s_mapping_enable = .true. s_mapping_power = 2 case ("isr, none", & "none, isr") allocate (single_mapping (1), source = [1]) single_parameter = .true. case ("isr, none => none, isr") allocate (s_mapping (2), source = [1, 2]) power_mapping = .true. power_mapping_eps = minval (sf_prop%isr_eps) case ("isr, none => none, isr => epa, none => none, epa", & "isr, none => none, isr => ewa, none => none, ewa", & "isr, none => none, isr => ewa, none => none, epa", & "isr, none => none, isr => epa, none => none, ewa") allocate (s_mapping (2), source = [1, 2]) power_mapping = .true. power_mapping_eps = minval (sf_prop%isr_eps) case ("circe1 => isr, none => none, isr => epa, none => none, epa", & "circe1 => isr, none => none, isr => ewa, none => none, ewa", & "circe1 => isr, none => none, isr => ewa, none => none, epa", & "circe1 => isr, none => none, isr => epa, none => none, ewa") if (circe1_generate) then allocate (s_mapping (2), source = [2, 3]) else allocate (s_mapping (3), source = [1, 2, 3]) endpoint_mapping = .true. endpoint_mapping_slope = circe1_mapping_slope end if power_mapping = .true. power_mapping_eps = minval (sf_prop%isr_eps) case ("pdf_builtin, none => none, isr", & "pdf_builtin_photon, none => none, isr", & "lhapdf, none => none, isr", & "lhapdf_photon, none => none, isr") allocate (single_mapping (1), source = [2]) case ("isr, none => none, pdf_builtin", & "isr, none => none, pdf_builtin_photon", & "isr, none => none, lhapdf", & "isr, none => none, lhapdf_photon") allocate (single_mapping (1), source = [1]) case ("epa, none", & "none, epa") allocate (single_mapping (1), source = [1]) single_parameter = .true. case ("epa, none => none, epa") allocate (single_mapping (2), source = [1, 2]) case ("epa, none => none, isr", & "isr, none => none, epa", & "ewa, none => none, isr", & "isr, none => none, ewa") allocate (single_mapping (2), source = [1, 2]) case ("pdf_builtin, none => none, epa", & "pdf_builtin_photon, none => none, epa", & "lhapdf, none => none, epa", & "lhapdf_photon, none => none, epa") allocate (single_mapping (1), source = [2]) case ("pdf_builtin, none => none, ewa", & "pdf_builtin_photon, none => none, ewa", & "lhapdf, none => none, ewa", & "lhapdf_photon, none => none, ewa") allocate (single_mapping (1), source = [2]) case ("epa, none => none, pdf_builtin", & "epa, none => none, pdf_builtin_photon", & "epa, none => none, lhapdf", & "epa, none => none, lhapdf_photon") allocate (single_mapping (1), source = [1]) case ("ewa, none => none, pdf_builtin", & "ewa, none => none, pdf_builtin_photon", & "ewa, none => none, lhapdf", & "ewa, none => none, lhapdf_photon") allocate (single_mapping (1), source = [1]) case ("ewa, none", & "none, ewa") allocate (single_mapping (1), source = [1]) single_parameter = .true. case ("ewa, none => none, ewa") allocate (single_mapping (2), source = [1, 2]) case ("energy_scan, none => none, energy_scan") allocate (s_mapping (2), source = [1, 2]) case ("sf_test_1, none => none, sf_test_1") allocate (s_mapping (2), source = [1, 2]) case ("circe1") if (circe1_generate) then !!! no mapping else if (circe1_map) then allocate (s_mapping (1), source = [1]) endpoint_mapping = .true. endpoint_mapping_slope = circe1_mapping_slope else allocate (s_mapping (1), source = [1]) s_mapping_enable = .true. end if case ("circe1 => isr, none => none, isr") if (circe1_generate) then allocate (s_mapping (2), source = [2, 3]) else allocate (s_mapping (3), source = [1, 2, 3]) endpoint_mapping = .true. endpoint_mapping_slope = circe1_mapping_slope end if power_mapping = .true. power_mapping_eps = minval (sf_prop%isr_eps) case ("circe1 => isr, none", & "circe1 => none, isr") allocate (single_mapping (1), source = [2]) case ("circe1 => epa, none => none, epa") if (circe1_generate) then allocate (single_mapping (2), source = [2, 3]) else call msg_fatal ("CIRCE/EPA: supported with ?circe1_generate=true & &only") end if case ("circe1 => ewa, none => none, ewa") if (circe1_generate) then allocate (single_mapping (2), source = [2, 3]) else call msg_fatal ("CIRCE/EWA: supported with ?circe1_generate=true & &only") end if case ("circe1 => epa, none", & "circe1 => none, epa") if (circe1_generate) then allocate (single_mapping (1), source = [2]) else call msg_fatal ("CIRCE/EPA: supported with ?circe1_generate=true & &only") end if case ("circe1 => epa, none => none, isr", & "circe1 => isr, none => none, epa", & "circe1 => ewa, none => none, isr", & "circe1 => isr, none => none, ewa") if (circe1_generate) then allocate (single_mapping (2), source = [2, 3]) else call msg_fatal ("CIRCE/EPA: supported with ?circe1_generate=true & &only") end if case ("circe2", & "gaussian", & "beam_events") !!! no mapping case ("circe2 => isr, none => none, isr", & "gaussian => isr, none => none, isr", & "beam_events => isr, none => none, isr") allocate (s_mapping (2), source = [2, 3]) power_mapping = .true. power_mapping_eps = minval (sf_prop%isr_eps) case ("circe2 => isr, none", & "circe2 => none, isr", & "gaussian => isr, none", & "gaussian => none, isr", & "beam_events => isr, none", & "beam_events => none, isr") allocate (single_mapping (1), source = [2]) case ("circe2 => epa, none => none, epa", & "gaussian => epa, none => none, epa", & "beam_events => epa, none => none, epa") allocate (single_mapping (2), source = [2, 3]) case ("circe2 => epa, none", & "circe2 => none, epa", & "circe2 => ewa, none", & "circe2 => none, ewa", & "gaussian => epa, none", & "gaussian => none, epa", & "gaussian => ewa, none", & "gaussian => none, ewa", & "beam_events => epa, none", & "beam_events => none, epa", & "beam_events => ewa, none", & "beam_events => none, ewa") allocate (single_mapping (1), source = [2]) case ("circe2 => epa, none => none, isr", & "circe2 => isr, none => none, epa", & "circe2 => ewa, none => none, isr", & "circe2 => isr, none => none, ewa", & "gaussian => epa, none => none, isr", & "gaussian => isr, none => none, epa", & "gaussian => ewa, none => none, isr", & "gaussian => isr, none => none, ewa", & "beam_events => epa, none => none, isr", & "beam_events => isr, none => none, epa", & "beam_events => ewa, none => none, isr", & "beam_events => isr, none => none, ewa") allocate (single_mapping (2), source = [2, 3]) case ("energy_scan") case default call msg_fatal ("Beam structure: " & // char (sf_string) // " not supported") end select if (sf_allow_s_mapping .and. coll%n > 0) then n_sf_channel = coll%n allocate (sf_channel (n_sf_channel)) do i = 1, n_sf_channel call sf_channel(i)%init (n_strfun) if (allocated (single_mapping)) then call sf_channel(i)%activate_mapping (single_mapping) end if if (allocated (prop)) deallocate (prop) call coll%get_entry (i, prop) if (allocated (prop)) then if (endpoint_mapping .and. power_mapping) then select type (prop) type is (resonance_t) call sf_channel(i)%set_eir_mapping (s_mapping, & a = endpoint_mapping_slope, eps = power_mapping_eps, & m = prop%mass / sqrts, w = prop%width / sqrts) type is (on_shell_t) call sf_channel(i)%set_eio_mapping (s_mapping, & a = endpoint_mapping_slope, eps = power_mapping_eps, & m = prop%mass / sqrts) end select else if (endpoint_mapping) then select type (prop) type is (resonance_t) call sf_channel(i)%set_epr_mapping (s_mapping, & a = endpoint_mapping_slope, & m = prop%mass / sqrts, w = prop%width / sqrts) type is (on_shell_t) call sf_channel(i)%set_epo_mapping (s_mapping, & a = endpoint_mapping_slope, & m = prop%mass / sqrts) end select else if (power_mapping) then select type (prop) type is (resonance_t) call sf_channel(i)%set_ipr_mapping (s_mapping, & eps = power_mapping_eps, & m = prop%mass / sqrts, w = prop%width / sqrts) type is (on_shell_t) call sf_channel(i)%set_ipo_mapping (s_mapping, & eps = power_mapping_eps, & m = prop%mass / sqrts) end select else if (allocated (s_mapping)) then select type (prop) type is (resonance_t) call sf_channel(i)%set_res_mapping (s_mapping, & m = prop%mass / sqrts, w = prop%width / sqrts, & single = single_parameter) type is (on_shell_t) call sf_channel(i)%set_os_mapping (s_mapping, & m = prop%mass / sqrts, & single = single_parameter) end select else if (allocated (single_mapping)) then select type (prop) type is (resonance_t) call sf_channel(i)%set_res_mapping (single_mapping, & m = prop%mass / sqrts, w = prop%width / sqrts, & single = single_parameter) type is (on_shell_t) call sf_channel(i)%set_os_mapping (single_mapping, & m = prop%mass / sqrts, & single = single_parameter) end select end if else if (endpoint_mapping .and. power_mapping) then call sf_channel(i)%set_ei_mapping (s_mapping, & a = endpoint_mapping_slope, eps = power_mapping_eps) else if (endpoint_mapping .and. .not. allocated (single_mapping)) then call sf_channel(i)%set_ep_mapping (s_mapping, & a = endpoint_mapping_slope) else if (power_mapping .and. .not. allocated (single_mapping)) then call sf_channel(i)%set_ip_mapping (s_mapping, & eps = power_mapping_eps) else if (s_mapping_enable .and. .not. allocated (single_mapping)) then call sf_channel(i)%set_s_mapping (s_mapping, & power = s_mapping_power) end if end do else if (sf_allow_s_mapping) then allocate (sf_channel (1)) call sf_channel(1)%init (n_strfun) if (allocated (single_mapping)) then call sf_channel(1)%activate_mapping (single_mapping) else if (endpoint_mapping .and. power_mapping) then call sf_channel(i)%set_ei_mapping (s_mapping, & a = endpoint_mapping_slope, eps = power_mapping_eps) else if (endpoint_mapping) then call sf_channel(1)%set_ep_mapping (s_mapping, & a = endpoint_mapping_slope) else if (power_mapping) then call sf_channel(1)%set_ip_mapping (s_mapping, & eps = power_mapping_eps) else if (s_mapping_enable) then call sf_channel(1)%set_s_mapping (s_mapping, & power = s_mapping_power) end if else allocate (sf_channel (1)) call sf_channel(1)%init (n_strfun) if (allocated (single_mapping)) then call sf_channel(1)%activate_mapping (single_mapping) end if end if end subroutine dispatch_sf_channels @ %def dispatch_sf_channels @ @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[dispatch_phs_ut.f90]]>>= <> module dispatch_phs_ut use unit_tests use dispatch_phs_uti <> <> contains <> end module dispatch_phs_ut @ %def dispatch_phs_ut @ <<[[dispatch_phs_uti.f90]]>>= <> module dispatch_phs_uti <> <> use variables use io_units, only: free_unit use os_interface, only: os_data_t use process_constants use model_data use models use phs_base use phs_none use phs_forests use phs_wood use mappings use dispatch_phase_space <> <> contains <> end module dispatch_phs_uti @ %def dispatch_phs_ut @ API: driver for the unit tests below. <>= public ::dispatch_phs_test <>= subroutine dispatch_phs_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine dispatch_phs_test @ %def dispatch_phs_test @ \subsubsection{Select type: phase-space configuration object} <>= call test (dispatch_phs_1, "dispatch_phs_1", & "phase-space configuration", & u, results) <>= public :: dispatch_phs_1 <>= subroutine dispatch_phs_1 (u) integer, intent(in) :: u type(var_list_t) :: var_list class(phs_config_t), allocatable :: phs type(phs_parameters_t) :: phs_par type(os_data_t) :: os_data type(mapping_defaults_t) :: mapping_defs write (u, "(A)") "* Test output: dispatch_phs_1" write (u, "(A)") "* Purpose: select phase-space configuration method" write (u, "(A)") call var_list%init_defaults (0) write (u, "(A)") "* Allocate PHS as phs_none_t" write (u, "(A)") call var_list%set_string (& var_str ("$phs_method"), & var_str ("none"), is_known = .true.) call dispatch_phs (phs, var_list, os_data, var_str ("dispatch_phs_1")) call phs%write (u) call phs%final () deallocate (phs) write (u, "(A)") write (u, "(A)") "* Allocate PHS as phs_single_t" write (u, "(A)") call var_list%set_string (& var_str ("$phs_method"), & var_str ("single"), is_known = .true.) call dispatch_phs (phs, var_list, os_data, var_str ("dispatch_phs_1")) call phs%write (u) call phs%final () deallocate (phs) write (u, "(A)") write (u, "(A)") "* Allocate PHS as phs_wood_t" write (u, "(A)") call var_list%set_string (& var_str ("$phs_method"), & var_str ("wood"), is_known = .true.) call dispatch_phs (phs, var_list, os_data, var_str ("dispatch_phs_1")) call phs%write (u) call phs%final () deallocate (phs) write (u, "(A)") write (u, "(A)") "* Setting parameters for phs_wood_t" write (u, "(A)") phs_par%m_threshold_s = 123 phs_par%m_threshold_t = 456 phs_par%t_channel = 42 phs_par%off_shell = 17 phs_par%keep_nonresonant = .false. mapping_defs%energy_scale = 987 mapping_defs%invariant_mass_scale = 654 mapping_defs%momentum_transfer_scale = 321 mapping_defs%step_mapping = .false. mapping_defs%step_mapping_exp = .false. mapping_defs%enable_s_mapping = .true. call dispatch_phs (phs, var_list, os_data, var_str ("dispatch_phs_1"), & mapping_defs, phs_par) call phs%write (u) call phs%final () call var_list%final () write (u, "(A)") write (u, "(A)") "* Test output end: dispatch_phs_1" end subroutine dispatch_phs_1 @ %def dispatch_phs_1 @ \subsubsection{Phase-space configuration with file} <>= call test (dispatch_phs_2, "dispatch_phs_2", & "configure phase space using file", & u, results) <>= public :: dispatch_phs_2 <>= subroutine dispatch_phs_2 (u) use phs_base_ut, only: init_test_process_data use phs_wood_ut, only: write_test_phs_file use phs_forests integer, intent(in) :: u type(var_list_t) :: var_list type(os_data_t) :: os_data type(process_constants_t) :: process_data type(model_list_t) :: model_list type(model_t), pointer :: model class(phs_config_t), allocatable :: phs integer :: u_phs write (u, "(A)") "* Test output: dispatch_phs_2" write (u, "(A)") "* Purpose: select 'wood' phase-space & &for a test process" write (u, "(A)") "* and read phs configuration from file" write (u, "(A)") write (u, "(A)") "* Initialize a process" write (u, "(A)") call var_list%init_defaults (0) call os_data%init () call syntax_model_file_init () call model_list%read_model & (var_str ("Test"), var_str ("Test.mdl"), os_data, model) call syntax_phs_forest_init () call init_test_process_data (var_str ("dispatch_phs_2"), process_data) write (u, "(A)") "* Write phase-space file" u_phs = free_unit () open (u_phs, file = "dispatch_phs_2.phs", action = "write", status = "replace") call write_test_phs_file (u_phs, var_str ("dispatch_phs_2")) close (u_phs) write (u, "(A)") write (u, "(A)") "* Allocate PHS as phs_wood_t" write (u, "(A)") call var_list%set_string (& var_str ("$phs_method"), & var_str ("wood"), is_known = .true.) call var_list%set_string (& var_str ("$phs_file"), & var_str ("dispatch_phs_2.phs"), is_known = .true.) call dispatch_phs (phs, var_list, os_data, var_str ("dispatch_phs_2")) call phs%init (process_data, model) call phs%configure (sqrts = 1000._default) call phs%write (u) write (u, "(A)") select type (phs) type is (phs_wood_config_t) call phs%write_forest (u) end select call phs%final () call var_list%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: dispatch_phs_2" end subroutine dispatch_phs_2 @ %def dispatch_phs_2 @%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{A lexer for O'Mega's phase-space output} This module provides three data types. One of them is the type [[dag_string_t]] which should contain the information of all Feynman diagrams in the factorized form which is provided by O'Mega in its phase-space outout. This output is translated into a string of tokens (in the form of an a array of the type [[dag_token_t]]) which have a certain meaning. The purpose of this module is only to identify these tokens correctly and to provide some procedures and interfaces which allow us to use these strings in a similar way as variables of the basic character type or the type [[iso_varying_string]]. Both [[character]] and [[iso_varying_string]] have some disadvantages at least if one wants to keep support for some older compiler versions. These can be circumvented by the [[dag_string_t]] type. Finally the [[dag_chain_t]] type is used to create a larger string in several steps without always recreating the string, which is done in the form of a simple linked list. In the end one can create a single [[dag_string]] out of this list, which is more useful. <<[[cascades2_lexer.f90]]>>= <> module cascades2_lexer <> use kinds, only: TC, i8 <> <> <> <> <> contains <> end module cascades2_lexer @ %def cascades2_lexer @ This is the token type. By default the variable [[type]] is [[EMPTY_TK]] but can obtain other values corresponding to the parameters defined below. The type of the token corresponds to a particular sequence of characters. When the token corresponds to a node of a tree, i.e. some particle in the Feynman diagram, the type is [[NODE_TK]] and the [[particle_name]] variable is holding the name of the particle. O'Megas output contains in addition to the particle name some numbers which indicate the external momenta that are flowing through this line. These numbers are translated into a binary code and saved in the variable [[bincode]]. In this case the number 1 corresponds to a bit set at position 0, 2 corresponds to a bit set at position 1, etc. Instead of numbers which are composed out of several digits, letters are used, i.e. A instead of 10 (bit at position 9), B instead of 11 (bit at position 10), etc.\\ When the DAG is reconstructed from a [[dag_string]] which was built from O'Mega's output, this string is modified such that a substring (a set of tokens) is replaced by a single token where the type variable is one of the three parameters [[DAG_NODE_TK]], [[DAG_OPTIONS_TK]] and [[DAG_COMBINATION_TK]]. These parameters correspond to the three types [[dag_node_t]], [[dag_options_t]] and [[dag_combination_t]] (see [[cascades2]] for more information. In this case, since these objects are organized in arrays, the [[index]] variable holds the corresponding position in the array.\\ In any case, we want to be able to reproduce the character string from which a token (or a string) has been created. The variable [[char_len]] is the length of this string. For tokens with the type [[DAG_NODE_TK]], [[DAG_OPTIONS_TK]] and [[DAG_COMBINATION_TK]] we use output of the form [[]], [[]] or [[]] which is useful for debugging the parser. Here 23 is the [[index]] and [[N]], [[O]] or [[C]] obviously corresponds to the [[type]]. <>= integer, parameter :: PRT_NAME_LEN = 20 @ %def PRT_NAME_LEN <>= public :: dag_token_t <>= type :: dag_token_t integer :: type = EMPTY_TK integer :: char_len = 0 integer(TC) :: bincode = 0 character (PRT_NAME_LEN) :: particle_name="" integer :: index = 0 contains <> end type dag_token_t @ %def dag_token_t @ This is the string type. It also holds the number of characters in the corresponding character string. It contains an array of tokens. If the [[dag_string]] is constructed using the type [[dag_chain_t]], which creates a linked list, we also need the pointer [[next]]. <>= public :: dag_string_t <>= type :: dag_string_t integer :: char_len = 0 type (dag_token_t), dimension(:), allocatable :: t type (dag_string_t), pointer :: next => null () contains <> end type dag_string_t @ %def dag_string_t @ This is the chain of [[dag_strings]]. It allows us to construct a large string by appending new strings to the linked list, which can later be merged to a single string. This is very useful because the file written by O'Mega contains large strings where each string contains all Feynman diagrams in a factorized form, but these large strings are cut into several pieces and distributed over many lines. As the file can become large, rewriting a new [[dag_string]] (or [[iso_varying_string]]) would consume more and more time with each additional line. For recreating a single [[dag_string]] out of this chain, we need the total character length and the sum of all sizes of the [[dag_token]] arrays [[t]]. <>= public :: dag_chain_t <>= type :: dag_chain_t integer :: char_len = 0 integer :: t_size = 0 type (dag_string_t), pointer :: first => null () type (dag_string_t), pointer :: last => null () contains <> end type dag_chain_t @ %def dag_chain_t @ We define two parameters holding the characters corresponding to a backslash and a blanc space. <>= character(len=1), parameter, public :: BACKSLASH_CHAR = "\\" character(len=1), parameter :: BLANC_CHAR = " " @ %def BACKSLASH_CHAR BLANC_CHAR @ These are the parameters which correspond to meaningful types of [[token]]. <>= integer, parameter, public :: NEW_LINE_TK = -2 integer, parameter :: BLANC_SPACE_TK = -1 integer, parameter :: EMPTY_TK = 0 integer, parameter, public :: NODE_TK = 1 integer, parameter, public :: DAG_NODE_TK = 2 integer, parameter, public :: DAG_OPTIONS_TK = 3 integer, parameter, public :: DAG_COMBINATION_TK = 4 integer, parameter, public :: COLON_TK = 11 integer, parameter, public :: COMMA_TK = 12 integer, parameter, public :: VERTICAL_BAR_TK = 13 integer, parameter, public :: OPEN_PAR_TK = 21 integer, parameter, public :: CLOSED_PAR_TK = 22 integer, parameter, public :: OPEN_CURLY_TK = 31 integer, parameter, public :: CLOSED_CURLY_TK = 32 @ %def NEW_LINE_TK BLANC_SPACE_TK EMPTY_TK NODE_TK @ %def COLON_TK COMMA_TK VERTICAL_LINE_TK OPEN_PAR_TK @ %def CLOSED_PAR_TK OPEN_CURLY_TK CLOSED_CURLY_TK @ Different sorts of assignment. This contains the conversion of a [[character]] variable into a [[dag_token]] or [[dag_string]]. <>= public :: assignment (=) <>= interface assignment (=) module procedure dag_token_assign_from_char_string module procedure dag_token_assign_from_dag_token module procedure dag_string_assign_from_dag_token module procedure dag_string_assign_from_char_string module procedure dag_string_assign_from_dag_string module procedure dag_string_assign_from_dag_token_array end interface assignment (=) @ %def interfaces <>= procedure :: init_dag_object_token => dag_token_init_dag_object_token <>= subroutine dag_token_init_dag_object_token (dag_token, type, index) class (dag_token_t), intent (out) :: dag_token integer, intent (in) :: index integer :: type dag_token%type = type dag_token%char_len = integer_n_dec_digits (index) + 3 dag_token%index = index contains function integer_n_dec_digits (number) result (n_digits) integer, intent (in) :: number integer :: n_digits integer :: div_number n_digits = 0 div_number = number do div_number = div_number / 10 n_digits = n_digits + 1 if (div_number == 0) exit enddo end function integer_n_dec_digits end subroutine dag_token_init_dag_object_token @ %def dag_token_init_dag_object_token <>= elemental subroutine dag_token_assign_from_char_string (dag_token, char_string) type (dag_token_t), intent (out) :: dag_token character (len=*), intent (in) :: char_string integer :: i, j logical :: set_bincode integer :: bit_pos character (len=10) :: index_char dag_token%char_len = len (char_string) if (dag_token%char_len == 1) then select case (char_string(1:1)) case (BACKSLASH_CHAR) dag_token%type = NEW_LINE_TK case (" ") dag_token%type = BLANC_SPACE_TK case (":") dag_token%type = COLON_TK case (",") dag_token%type = COMMA_TK case ("|") dag_token%type = VERTICAL_BAR_TK case ("(") dag_token%type = OPEN_PAR_TK case (")") dag_token%type = CLOSED_PAR_TK case ("{") dag_token%type = OPEN_CURLY_TK case ("}") dag_token%type = CLOSED_CURLY_TK end select else if (char_string(1:1) == "<") then select case (char_string(2:2)) case ("N") dag_token%type = DAG_NODE_TK case ("O") dag_token%type = DAG_OPTIONS_TK case ("C") dag_token%type = DAG_COMBINATION_TK end select read(char_string(3:dag_token%char_len-1), fmt="(I10)") dag_token%index else dag_token%bincode = 0 set_bincode = .false. do i=1, dag_token%char_len select case (char_string(i:i)) case ("[") dag_token%type = NODE_TK if (i > 1) then do j = 1, i - 1 dag_token%particle_name(j:j) = char_string(j:j) enddo end if set_bincode = .true. case ("]") set_bincode = .false. case default dag_token%type = NODE_TK if (set_bincode) then select case (char_string(i:i)) case ("1", "2", "3", "4", "5", "6", "7", "8", "9") read (char_string(i:i), fmt="(I1)") bit_pos case ("A") bit_pos = 10 case ("B") bit_pos = 11 case ("C") bit_pos = 12 end select dag_token%bincode = ibset(dag_token%bincode, bit_pos - 1) end if end select if (dag_token%type /= NODE_TK) exit enddo end if end subroutine dag_token_assign_from_char_string @ %def dag_token_assign_from_char_string <>= elemental subroutine dag_token_assign_from_dag_token (token_out, token_in) type (dag_token_t), intent (out) :: token_out type (dag_token_t), intent (in) :: token_in token_out%type = token_in%type token_out%char_len = token_in%char_len token_out%bincode = token_in%bincode token_out%particle_name = token_in%particle_name token_out%index = token_in%index end subroutine dag_token_assign_from_dag_token @ %def dag_token_assign_from_dag_token <>= elemental subroutine dag_string_assign_from_dag_token (dag_string, dag_token) type (dag_string_t), intent (out) :: dag_string type (dag_token_t), intent (in) :: dag_token allocate (dag_string%t(1)) dag_string%t(1) = dag_token dag_string%char_len = dag_token%char_len end subroutine dag_string_assign_from_dag_token @ %def dag_string_assign_from_dag_token <>= subroutine dag_string_assign_from_dag_token_array (dag_string, dag_token) type (dag_string_t), intent (out) :: dag_string type (dag_token_t), dimension(:), intent (in) :: dag_token allocate (dag_string%t(size(dag_token))) dag_string%t = dag_token dag_string%char_len = sum(dag_token%char_len) end subroutine dag_string_assign_from_dag_token_array @ %def dag_string_assign_from_dag_token_array <>= elemental subroutine dag_string_assign_from_char_string (dag_string, char_string) type (dag_string_t), intent (out) :: dag_string character (len=*), intent (in) :: char_string type (dag_token_t), dimension(:), allocatable :: token integer :: token_pos integer :: i character (len=len(char_string)) :: node_char integer :: node_char_len node_char = "" dag_string%char_len = len (char_string) if (dag_string%char_len > 0) then allocate (token(dag_string%char_len)) token_pos = 0 node_char_len = 0 do i=1, dag_string%char_len select case (char_string(i:i)) case (BACKSLASH_CHAR, " ", ":", ",", "|", "(", ")", "{", "}") if (node_char_len > 0) then token_pos = token_pos + 1 token(token_pos) = node_char(:node_char_len) node_char_len = 0 end if token_pos = token_pos + 1 token(token_pos) = char_string(i:i) case default node_char_len = node_char_len + 1 node_char(node_char_len:node_char_len) = char_string(i:i) end select enddo if (node_char_len > 0) then token_pos = token_pos + 1 token(token_pos) = node_char(:node_char_len) end if if (token_pos > 0) then allocate (dag_string%t(token_pos)) dag_string%t = token(:token_pos) deallocate (token) end if end if end subroutine dag_string_assign_from_char_string @ %def dag_string_assign_from_char_string <>= elemental subroutine dag_string_assign_from_dag_string (string_out, string_in) type (dag_string_t), intent (out) :: string_out type (dag_string_t), intent (in) :: string_in if (allocated (string_in%t)) then allocate (string_out%t (size(string_in%t))) string_out%t = string_in%t end if string_out%char_len = string_in%char_len end subroutine dag_string_assign_from_dag_string @ %def dag_string_assign_from_dag_string @ Concatenate strings/tokens. The result is always a [[dag_string]]. <>= public :: operator (//) <>= interface operator (//) module procedure concat_dag_token_dag_token module procedure concat_dag_string_dag_token module procedure concat_dag_token_dag_string module procedure concat_dag_string_dag_string end interface operator (//) @ %def interfaces <>= function concat_dag_token_dag_token (token1, token2) result (res_string) type (dag_token_t), intent (in) :: token1, token2 type (dag_string_t) :: res_string if (token1%type == EMPTY_TK) then res_string = token2 else if (token2%type == EMPTY_TK) then res_string = token1 else allocate (res_string%t(2)) res_string%t(1) = token1 res_string%t(2) = token2 res_string%char_len = token1%char_len + token2%char_len end if end function concat_dag_token_dag_token @ %def concat_dag_token_dag_token <>= function concat_dag_string_dag_token (dag_string, dag_token) result (res_string) type (dag_string_t), intent (in) :: dag_string type (dag_token_t), intent (in) :: dag_token type (dag_string_t) :: res_string integer :: t_size if (dag_string%char_len == 0) then res_string = dag_token else if (dag_token%type == EMPTY_TK) then res_string = dag_string else t_size = size (dag_string%t) allocate (res_string%t(t_size+1)) res_string%t(:t_size) = dag_string%t res_string%t(t_size+1) = dag_token res_string%char_len = dag_string%char_len + dag_token%char_len end if end function concat_dag_string_dag_token @ %def concat_dag_string_dag_token <>= function concat_dag_token_dag_string (dag_token, dag_string) result (res_string) type (dag_token_t), intent (in) :: dag_token type (dag_string_t), intent (in) :: dag_string type (dag_string_t) :: res_string integer :: t_size if (dag_token%type == EMPTY_TK) then res_string = dag_string else if (dag_string%char_len == 0) then res_string = dag_token else t_size = size (dag_string%t) allocate (res_string%t(t_size+1)) res_string%t(2:t_size+1) = dag_string%t res_string%t(1) = dag_token res_string%char_len = dag_token%char_len + dag_string%char_len end if end function concat_dag_token_dag_string @ %def concat_dag_token_dag_string <>= function concat_dag_string_dag_string (string1, string2) result (res_string) type (dag_string_t), intent (in) :: string1, string2 type (dag_string_t) :: res_string integer :: t1_size, t2_size, t_size if (string1%char_len == 0) then res_string = string2 else if (string2%char_len == 0) then res_string = string1 else t1_size = size (string1%t) t2_size = size (string2%t) t_size = t1_size + t2_size if (t_size > 0) then allocate (res_string%t(t_size)) res_string%t(:t1_size) = string1%t res_string%t(t1_size+1:) = string2%t res_string%char_len = string1%char_len + string2%char_len end if end if end function concat_dag_string_dag_string @ %def concat_dag_string_dag_string @ Compare strings/tokens/characters. Each character is relevant, including all blanc spaces. An exception is the [[newline]] character which is not treated by the types used in this module (not to confused with the type parameter [[NEW_LINE_TK]] which corresponds to the backslash character and simply tells us that the string continues on the next line in the file). <>= public :: operator (==) <>= interface operator (==) module procedure dag_token_eq_dag_token module procedure dag_string_eq_dag_string module procedure dag_token_eq_dag_string module procedure dag_string_eq_dag_token module procedure dag_token_eq_char_string module procedure char_string_eq_dag_token module procedure dag_string_eq_char_string module procedure char_string_eq_dag_string end interface operator (==) @ %def interfaces <>= elemental function dag_token_eq_dag_token (token1, token2) result (flag) type (dag_token_t), intent (in) :: token1, token2 logical :: flag flag = (token1%type == token2%type) .and. & (token1%char_len == token2%char_len) .and. & (token1%bincode == token2%bincode) .and. & (token1%index == token2%index) .and. & (token1%particle_name == token2%particle_name) end function dag_token_eq_dag_token @ %def dag_token_eq_dag_token <>= elemental function dag_string_eq_dag_string (string1, string2) result (flag) type (dag_string_t), intent (in) :: string1, string2 logical :: flag flag = (string1%char_len == string2%char_len) .and. & (allocated (string1%t) .eqv. allocated (string2%t)) if (flag) then if (allocated (string1%t)) flag = all (string1%t == string2%t) end if end function dag_string_eq_dag_string @ %def dag_string_eq_dag_string <>= elemental function dag_token_eq_dag_string (dag_token, dag_string) result (flag) type (dag_token_t), intent (in) :: dag_token type (dag_string_t), intent (in) :: dag_string logical :: flag flag = size (dag_string%t) == 1 .and. & dag_string%char_len == dag_token%char_len if (flag) flag = (dag_string%t(1) == dag_token) end function dag_token_eq_dag_string @ %def dag_token_eq_dag_string <>= elemental function dag_string_eq_dag_token (dag_string, dag_token) result (flag) type (dag_token_t), intent (in) :: dag_token type (dag_string_t), intent (in) :: dag_string logical :: flag flag = (dag_token == dag_string) end function dag_string_eq_dag_token @ %def dag_string_eq_dag_token <>= elemental function dag_token_eq_char_string (dag_token, char_string) result (flag) type (dag_token_t), intent (in) :: dag_token character (len=*), intent (in) :: char_string logical :: flag flag = (char (dag_token) == char_string) end function dag_token_eq_char_string @ %def dag_token_eq_char_string <>= elemental function char_string_eq_dag_token (char_string, dag_token) result (flag) type (dag_token_t), intent (in) :: dag_token character (len=*), intent (in) :: char_string logical :: flag flag = (char (dag_token) == char_string) end function char_string_eq_dag_token @ %def char_string_eq_dag_token <>= elemental function dag_string_eq_char_string (dag_string, char_string) result (flag) type (dag_string_t), intent (in) :: dag_string character (len=*), intent (in) :: char_string logical :: flag flag = (char (dag_string) == char_string) end function dag_string_eq_char_string @ %def dag_string_eq_char_string <>= elemental function char_string_eq_dag_string (char_string, dag_string) result (flag) type (dag_string_t), intent (in) :: dag_string character (len=*), intent (in) :: char_string logical :: flag flag = (char (dag_string) == char_string) end function char_string_eq_dag_string @ %def char_string_eq_dag_string <>= public :: operator (/=) <>= interface operator (/=) module procedure dag_token_ne_dag_token module procedure dag_string_ne_dag_string module procedure dag_token_ne_dag_string module procedure dag_string_ne_dag_token module procedure dag_token_ne_char_string module procedure char_string_ne_dag_token module procedure dag_string_ne_char_string module procedure char_string_ne_dag_string end interface operator (/=) @ %def interfaces <>= elemental function dag_token_ne_dag_token (token1, token2) result (flag) type (dag_token_t), intent (in) :: token1, token2 logical :: flag flag = .not. (token1 == token2) end function dag_token_ne_dag_token @ %def dag_token_ne_dag_token <>= elemental function dag_string_ne_dag_string (string1, string2) result (flag) type (dag_string_t), intent (in) :: string1, string2 logical :: flag flag = .not. (string1 == string2) end function dag_string_ne_dag_string @ %def dag_string_ne_dag_string <>= elemental function dag_token_ne_dag_string (dag_token, dag_string) result (flag) type (dag_token_t), intent (in) :: dag_token type (dag_string_t), intent (in) :: dag_string logical :: flag flag = .not. (dag_token == dag_string) end function dag_token_ne_dag_string @ %def dag_token_ne_dag_string <>= elemental function dag_string_ne_dag_token (dag_string, dag_token) result (flag) type (dag_token_t), intent (in) :: dag_token type (dag_string_t), intent (in) :: dag_string logical :: flag flag = .not. (dag_string == dag_token) end function dag_string_ne_dag_token @ %def dag_string_ne_dag_token <>= elemental function dag_token_ne_char_string (dag_token, char_string) result (flag) type (dag_token_t), intent (in) :: dag_token character (len=*), intent (in) :: char_string logical :: flag flag = .not. (dag_token == char_string) end function dag_token_ne_char_string @ %def dag_token_ne_char_string <>= elemental function char_string_ne_dag_token (char_string, dag_token) result (flag) type (dag_token_t), intent (in) :: dag_token character (len=*), intent (in) :: char_string logical :: flag flag = .not. (char_string == dag_token) end function char_string_ne_dag_token @ %def char_string_ne_dag_token <>= elemental function dag_string_ne_char_string (dag_string, char_string) result (flag) type (dag_string_t), intent (in) :: dag_string character (len=*), intent (in) :: char_string logical :: flag flag = .not. (dag_string == char_string) end function dag_string_ne_char_string @ %def dag_string_ne_char_string <>= elemental function char_string_ne_dag_string (char_string, dag_string) result (flag) type (dag_string_t), intent (in) :: dag_string character (len=*), intent (in) :: char_string logical :: flag flag = .not. (char_string == dag_string) end function char_string_ne_dag_string @ %def char_string_ne_dag_string @ Convert a [[dag_token]] or [[dag_string]] to character. <>= public :: char <>= interface char module procedure char_dag_token module procedure char_dag_string end interface char @ %def interfaces <>= pure function char_dag_token (dag_token) result (char_string) type (dag_token_t), intent (in) :: dag_token character (dag_token%char_len) :: char_string integer :: i integer :: name_len integer :: bc_pos integer :: n_digits character (len=9) :: fmt_spec select case (dag_token%type) case (EMPTY_TK) char_string = "" case (NEW_LINE_TK) char_string = BACKSLASH_CHAR case (BLANC_SPACE_TK) char_string = " " case (COLON_TK) char_string = ":" case (COMMA_TK) char_string = "," case (VERTICAL_BAR_TK) char_string = "|" case (OPEN_PAR_TK) char_string = "(" case (CLOSED_PAR_TK) char_string = ")" case (OPEN_CURLY_TK) char_string = "{" case (CLOSED_CURLY_TK) char_string = "}" case (DAG_NODE_TK, DAG_OPTIONS_TK, DAG_COMBINATION_TK) n_digits = dag_token%char_len - 3 fmt_spec = "" if (n_digits > 9) then write (fmt_spec, fmt="(A,I2,A)") "(A,I", n_digits, ",A)" else write (fmt_spec, fmt="(A,I1,A)") "(A,I", n_digits, ",A)" end if select case (dag_token%type) case (DAG_NODE_TK) write (char_string, fmt=fmt_spec) "" case (DAG_OPTIONS_TK) write (char_string, fmt=fmt_spec) "" case (DAG_COMBINATION_TK) write (char_string, fmt=fmt_spec) "" end select case (NODE_TK) name_len = len_trim (dag_token%particle_name) char_string = dag_token%particle_name bc_pos = name_len + 1 char_string(bc_pos:bc_pos) = "[" do i=0, bit_size (dag_token%bincode) - 1 if (btest (dag_token%bincode, i)) then bc_pos = bc_pos + 1 select case (i) case (0, 1, 2, 3, 4, 5, 6, 7, 8) write (char_string(bc_pos:bc_pos), fmt="(I1)") i + 1 case (9) write (char_string(bc_pos:bc_pos), fmt="(A1)") "A" case (10) write (char_string(bc_pos:bc_pos), fmt="(A1)") "B" case (11) write (char_string(bc_pos:bc_pos), fmt="(A1)") "C" end select bc_pos = bc_pos + 1 if (bc_pos == dag_token%char_len) then write (char_string(bc_pos:bc_pos), fmt="(A1)") "]" return else write (char_string(bc_pos:bc_pos), fmt="(A1)") "/" end if end if enddo end select end function char_dag_token @ %def char_dag_token <>= pure function char_dag_string (dag_string) result (char_string) type (dag_string_t), intent (in) :: dag_string character (dag_string%char_len) :: char_string integer :: pos integer :: i char_string = "" pos = 0 do i=1, size(dag_string%t) char_string(pos+1:pos+dag_string%t(i)%char_len) = char (dag_string%t(i)) pos = pos + dag_string%t(i)%char_len enddo end function char_dag_string @ %def char_dag_string @ Remove all tokens which are irrelevant for parsing. These are of type [[NEW_LINE_TK]], [[BLANC_SPACE_TK]] and [[EMTPY_TK]]. <>= procedure :: clean => dag_string_clean <>= subroutine dag_string_clean (dag_string) class (dag_string_t), intent (inout) :: dag_string type (dag_token_t), dimension(:), allocatable :: tmp_token integer :: n_keep integer :: i n_keep = 0 dag_string%char_len = 0 allocate (tmp_token (size(dag_string%t))) do i=1, size (dag_string%t) select case (dag_string%t(i)%type) case(NEW_LINE_TK, BLANC_SPACE_TK, EMPTY_TK) case default n_keep = n_keep + 1 tmp_token(n_keep) = dag_string%t(i) dag_string%char_len = dag_string%char_len + dag_string%t(i)%char_len end select enddo deallocate (dag_string%t) allocate (dag_string%t(n_keep)) dag_string%t = tmp_token(:n_keep) end subroutine dag_string_clean @ %def dag_string_clean @ If we operate explicitly on the [[token]] array [[t]] of a [[dag_string]], the variable [[char_len]] is not automatically modified. It can however be determined afterwards using the following subroutine. <>= procedure :: update_char_len => dag_string_update_char_len <>= subroutine dag_string_update_char_len (dag_string) class (dag_string_t), intent (inout) :: dag_string integer :: char_len integer :: i char_len = 0 if (allocated (dag_string%t)) then do i=1, size (dag_string%t) char_len = char_len + dag_string%t(i)%char_len enddo end if dag_string%char_len = char_len end subroutine dag_string_update_char_len @ %def dag_string_update_char_len @ Append a [[dag_string]] to a [[dag_chain]]. The argument [[char_string]] is of type [[character]] because the subroutine is used for reading from the file produced by O'Mega which is first read line by line to a character variable. <>= procedure :: append => dag_chain_append_string <>= subroutine dag_chain_append_string (dag_chain, char_string) class (dag_chain_t), intent (inout) :: dag_chain character (len=*), intent (in) :: char_string if (.not. associated (dag_chain%first)) then allocate (dag_chain%first) dag_chain%last => dag_chain%first else allocate (dag_chain%last%next) dag_chain%last => dag_chain%last%next end if dag_chain%last = char_string dag_chain%char_len = dag_chain%char_len + dag_chain%last%char_len dag_chain%t_size = dag_chain%t_size + size (dag_chain%last%t) end subroutine dag_chain_append_string @ %def dag_chain_append_string @ Reduce the linked list of [[dag_string]] objects which are attached to a given [[dag_chain]] object to a single [[dag_string]]. <>= procedure :: compress => dag_chain_compress <>= subroutine dag_chain_compress (dag_chain) class (dag_chain_t), intent (inout) :: dag_chain type (dag_string_t), pointer :: current type (dag_string_t), pointer :: remove integer :: filled_t current => dag_chain%first dag_chain%first => null () allocate (dag_chain%first) dag_chain%last => dag_chain%first dag_chain%first%char_len = dag_chain%char_len allocate (dag_chain%first%t (dag_chain%t_size)) filled_t = 0 do while (associated (current)) dag_chain%first%t(filled_t+1:filled_t+size(current%t)) = current%t filled_t = filled_t + size (current%t) remove => current current => current%next deallocate (remove) enddo end subroutine dag_chain_compress @ %def dag_chain_compress @ Finalizer for [[dag_string_t]]. <>= procedure :: final => dag_string_final <>= subroutine dag_string_final (dag_string) class (dag_string_t), intent (inout) :: dag_string if (allocated (dag_string%t)) deallocate (dag_string%t) dag_string%next => null () end subroutine dag_string_final @ %def dag_string_final @ Finalizer for [[dag_chain_t]]. <>= procedure :: final => dag_chain_final <>= subroutine dag_chain_final (dag_chain) class (dag_chain_t), intent (inout) :: dag_chain type (dag_string_t), pointer :: current current => dag_chain%first do while (associated (current)) dag_chain%first => dag_chain%first%next call current%final () deallocate (current) current => dag_chain%first enddo dag_chain%last => null () end subroutine dag_chain_final @ %def dag_chain_final <<[[cascades2_lexer_ut.f90]]>>= <> module cascades2_lexer_ut use unit_tests use cascades2_lexer_uti <> <> contains <> end module cascades2_lexer_ut @ %def cascades2_lexer_ut @ <<[[cascades2_lexer_uti.f90]]>>= <> module cascades2_lexer_uti <> <> use numeric_utils use cascades2_lexer <> <> contains <> end module cascades2_lexer_uti @ %def cascades2_lexer_uti @ API: driver for the unit tests below. <>= public :: cascades2_lexer_test <>= subroutine cascades2_lexer_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine cascades2_lexer_test @ %def cascades2_lexer_test @ <>= call test (cascades2_lexer_1, "cascades2_lexer_1", & "make phase-space", u, results) <>= public :: cascades2_lexer_1 <>= subroutine cascades2_lexer_1 (u) integer, intent(in) :: u integer :: u_in = 8 character (len=300) :: line integer :: stat logical :: fail type (dag_string_t) :: dag_string write (u, "(A)") "* Test output: cascades2_lexer_1" write (u, "(A)") "* Purpose: read lines of O'Mega's phase space output, translate" write (u, "(A)") "* to dag_string, retranslate to character string and" write (u, "(A)") "* compare" write (u, "(A)") open (unit=u_in, file="cascades2_lexer_1.fds", status='old', action='read') stat = 0 fail = .false. read (unit=u_in, fmt="(A)", iostat=stat) line do while (stat == 0 .and. .not. fail) read (unit=u_in, fmt="(A)", iostat=stat) line if (stat /= 0) exit dag_string = line fail = (char(dag_string) /= line) enddo if (fail) then write (u, "(A)") "* Test result: Test failed!" else write (u, "(A)") "* Test result: Test passed" end if close (u_in) write (u, *) write (u, "(A)") "* Test output end: cascades2_lexer_1" end subroutine cascades2_lexer_1 @ %def cascades2_lexer_1 @%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{An alternative cascades module} This module might replace the module [[cascades]], which generates suitable phase space parametrizations and generates the phase space file. The mappings, as well as the criteria to determine these, do not change. The advantage of this module is that it makes use of the [[O'Mega]] matrix element generator which provides the relevant Feynman diagrams (the ones which can be constructed only from 3-vertices). In principle, the construction of these diagrams is also one of the tasks of the existing [[cascades]] module, in which the diagrams would correspond to a set of cascades. It starts by creating cascades which correspond to the outgoing particles. These are combined to a new cascade using the vertices of the model. In this way, since each cascade knows the daughter cascades from which it is built, complete Feynman diagrams are represented by sets of cascades, as soon as the existing cascades can be recombined with the incoming particle(s). In this module, the Feynman diagrams are represented by the type [[feyngraph_t]], which represents the Feynman diagrams as a tree of nodes. The object which contains the necessary kinematical information to determine mappings, and hence sensible phase space parametrizations is of another type, called [[kingraph_t]], which is built from a corresponding [[feyngraph]] object. There are two types of output which can be produced by [[O'Mega]] and are potentially relevant here. The first type contains all tree diagrams for the process under consideration, where each line of the output corresponds to one Feynman diagram. This output is easy to read, but can be very large, depending on the number of particles involved in the process. Moreover, it repeats substructures of the diagrams which are part of more than one diagram. One could in principle work with this output and construct a [[feyngraph]] from each line, if allowed, i.e. if there are only 3-vertices. The other output contains also all of these Feynman diagrams, but in a factorized form. This means that the substructures which appear in several Feynman diagrams, are written only once, if possible. This leads to a much shorter input file, which speeds up the parsing process. Furthermore it makes it possible to reconstruct the [[feyngraphs]] in such a way that the calculations concerning subdiagrams which reappear in other [[feyngraphs]] have to be performed only once. This is already the case in the existing [[cascades]] module but can be exploited more efficiently here because the possible graphs are well known from the input file, whereas the [[cascades]] module would create a large number of [[cascades]] which do not lead to a complete Feynman diagram of the given process. <<[[cascades2.f90]]>>= <> module cascades2 <> use kinds, only: TC, i8 use cascades2_lexer use sorting use flavors use model_data use iso_varying_string, string_t => varying_string use io_units use physics_defs, only: SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR use phs_forests, only: phs_parameters_t use diagnostics use hashes use cascades, only: phase_space_vanishes, MAX_WARN_RESONANCE use, intrinsic :: iso_fortran_env, only : input_unit, output_unit, error_unit use resonances, only: resonance_info_t use resonances, only: resonance_history_t use resonances, only: resonance_history_set_t <> <> <> <> <> contains <> end module cascades2 @ %def cascades2 @ \subsection{Particle properties} We define a type holding the properties of the particles which are needed for parsing and finding the phase space parametrizations and mappings. The properties of all particles which appear in the parsed Feynman diagrams for the given process will be stored in a central place, and only pointers to these objects are used. <>= type :: part_prop_t character (len=LABEL_LEN) :: particle_label integer :: pdg = 0 real(default) :: mass = 0. real :: width = 0. integer :: spin_type = 0 logical :: is_vector = .false. logical :: empty = .true. type (part_prop_t), pointer :: anti => null () type (string_t) :: tex_name contains <> end type part_prop_t @ %def part_prop_t @ The [[particle_label]] in [[part_prop_t]] is simply the particle name (e.g. 'W+'). The corresponding variable in the type [[f_node_t]] contains some additional information related to the external momenta, see below. The length of the [[character]] variable is fixed as: <>= integer, parameter :: LABEL_LEN=30 @ %def LABEL_LEN <>= procedure :: final => part_prop_final <>= subroutine part_prop_final (part) class(part_prop_t), intent(inout) :: part part%anti => null () end subroutine part_prop_final @ %def part_prop_final @ \subsection{The mapping modes} The possible mappings are essentially the same as in [[cascades]], but we introduce in addition the mapping constant [[NON_RESONANT]], which does not refer to a new mapping; it corresponds to the nonresonant version of a potentially resonant particle (or [[k_node]]). This becomes relevant when we compare [[k_nodes]] to eliminate equivalences. <>= integer, parameter :: & & NONRESONANT = -2, EXTERNAL_PRT = -1, & & NO_MAPPING = 0, S_CHANNEL = 1, T_CHANNEL = 2, U_CHANNEL = 3, & & RADIATION = 4, COLLINEAR = 5, INFRARED = 6, & & STEP_MAPPING_E = 11, STEP_MAPPING_H = 12, & & ON_SHELL = 99 @ %def NONRESONANT EXTERNAL_PRT @ %def NO_MAPPING S_CHANNEL T_CHANNEL U_CHANNEL @ %def RADIATION COLLINEAR INFRARED @ %def STEP_MAPPING_E STEP_MAPPING_H @ %def ON_SHELL @ \subsection{Grove properties} The channels or [[kingraphs]] will be grouped in groves, i.e. sets of channels, which share some characteristic numbers. These numbers are stored in the following type: <>= type :: grove_prop_t integer :: multiplicity = 0 integer :: n_resonances = 0 integer :: n_log_enhanced = 0 integer :: n_off_shell = 0 integer :: n_t_channel = 0 integer :: res_hash = 0 end type grove_prop_t @ %def grove_prop_t @ \subsection{The tree type} This type contains all the information which is needed to reconstruct a [[feyngraph]] or [[kingraph]]. We store bincodes, pdg codes and mappings for all nodes of a valid [[kingraph]]. If we label the external particles as given in the process definition with integer numbers representing their position in the process definition, the bincode would be the number that one obtains by setting the bit at the position that is given by this number. If we combine two particles/nodes to a third one (using a three-vertex of the given model), the bincode is the number which one obtains by setting all the bits which are set for the two particles. The [[pdg]] and [[mapping]] are simply the pdg-code and mapping at the position (i.e. propagator or external particle) which is specified by the corresponding bincode. We use [[tree_t]] not only for completed [[kingraphs]], but also for all [[k_nodes]], which are a subtree of a [[kingraph]]. <>= type :: tree_t integer(TC), dimension(:), allocatable :: bc integer, dimension(:), allocatable :: pdg integer, dimension(:), allocatable :: mapping integer :: n_entries = 0 logical :: keep = .true. logical :: empty = .true. contains <> end type tree_t @ %def tree_t <>= procedure :: final => tree_final <>= subroutine tree_final (tree) class (tree_t), intent (inout) :: tree if (allocated (tree%bc)) deallocate (tree%bc) if (allocated (tree%pdg)) deallocate (tree%pdg) if (allocated (tree%mapping)) deallocate (tree%mapping) end subroutine tree_final @ %def tree_final <>= interface assignment (=) module procedure tree_assign end interface assignment (=) <>= subroutine tree_assign (tree1, tree2) type (tree_t), intent (inout) :: tree1 type (tree_t), intent (in) :: tree2 if (allocated (tree2%bc)) then allocate (tree1%bc(size(tree2%bc))) tree1%bc = tree2%bc end if if (allocated (tree2%pdg)) then allocate (tree1%pdg(size(tree2%pdg))) tree1%pdg = tree2%pdg end if if (allocated (tree2%mapping)) then allocate (tree1%mapping(size(tree2%mapping))) tree1%mapping = tree2%mapping end if tree1%n_entries = tree2%n_entries tree1%keep = tree2%keep tree1%empty = tree2%empty end subroutine tree_assign @ %def tree_assign @ \subsection{Add entries to the tree} The following procedures fill the arrays in [[tree_t]] with entries resulting from the bincode and mapping assignment. <>= procedure :: add_entry_from_numbers => tree_add_entry_from_numbers procedure :: add_entry_from_node => tree_add_entry_from_node generic :: add_entry => add_entry_from_numbers, add_entry_from_node @ Here we add a single entry to each of the arrays. This will exclusively be used for external particles. <>= subroutine tree_add_entry_from_numbers (tree, bincode, pdg, mapping) class (tree_t), intent (inout) :: tree integer(TC), intent (in) :: bincode integer, intent (in) :: pdg integer, intent (in) :: mapping integer :: pos if (tree%empty) then allocate (tree%bc(1)) allocate (tree%pdg(1)) allocate (tree%mapping(1)) pos = tree%n_entries + 1 tree%bc(pos) = bincode tree%pdg(pos) = pdg tree%mapping(pos) = mapping tree%n_entries = pos tree%empty = .false. end if end subroutine tree_add_entry_from_numbers @ %def tree_add_entry_from_numbers @ Here we merge two existing subtrees and a single entry (bc, pdg and mapping). <>= subroutine tree_merge (tree, tree1, tree2, bc, pdg, mapping) class (tree_t), intent (inout) :: tree type (tree_t), intent (in) :: tree1, tree2 integer(TC), intent (in) :: bc integer, intent (in) :: pdg, mapping integer :: tree_size integer :: i1, i2 if (tree%empty) then i1 = tree1%n_entries i2 = tree1%n_entries + tree2%n_entries tree_size = tree1%n_entries + tree2%n_entries + 1 allocate (tree%bc (tree_size)) allocate (tree%pdg (tree_size)) allocate (tree%mapping (tree_size)) tree%bc(:i1) = tree1%bc tree%pdg(:i1) = tree1%pdg tree%mapping(:i1) = tree1%mapping tree%bc(i1+1:i2) = tree2%bc tree%pdg(i1+1:i2) = tree2%pdg tree%mapping(i1+1:i2) = tree2%mapping tree%bc(tree_size) = bc tree%pdg(tree_size) = pdg tree%mapping(tree_size) = mapping tree%n_entries = tree_size tree%empty = .false. end if end subroutine tree_merge @ %def tree_merge @ Here we add entries to a tree for a given [[k_node]], which means that we first have to determine whether the node is external or internal. The arrays are sorted after the entries have been added (see below for details). <>= subroutine tree_add_entry_from_node (tree, node) class (tree_t), intent (inout) :: tree type (k_node_t), intent (in) :: node integer :: pdg if (node%t_line) then pdg = abs (node%particle%pdg) else pdg = node%particle%pdg end if if (associated (node%daughter1) .and. & associated (node%daughter2)) then call tree_merge (tree, node%daughter1%subtree, & node%daughter2%subtree, node%bincode, & node%particle%pdg, node%mapping) else call tree_add_entry_from_numbers (tree, node%bincode, & node%particle%pdg, node%mapping) end if call tree%sort () end subroutine tree_add_entry_from_node @ %def tree_add_entry_from_node @ For a well-defined order of the elements of the arrays in [[tree_t]], the elements can be sorted. The bincodes (entries of [[bc]]) are simply ordered by size, the [[pdg]] and [[mapping]] entries go to the positions of the corresponding [[bc]] values. <>= procedure :: sort => tree_sort <>= subroutine tree_sort (tree) class (tree_t), intent (inout) :: tree integer(TC), dimension(size(tree%bc)) :: bc_tmp integer, dimension(size(tree%pdg)) :: pdg_tmp, mapping_tmp integer, dimension(1) :: pos integer :: i bc_tmp = tree%bc pdg_tmp = tree%pdg mapping_tmp = tree%mapping do i = size(tree%bc),1,-1 pos = maxloc (bc_tmp) tree%bc(i) = bc_tmp (pos(1)) tree%pdg(i) = pdg_tmp (pos(1)) tree%mapping(i) = mapping_tmp (pos(1)) bc_tmp(pos(1)) = 0 end do end subroutine tree_sort @ %def tree_sort @ \subsection{Graph types} We define an abstract type which will give rise to two different types: The type [[feyngraph_t]] contains the pure information of the corresponding Feynman diagram, but also a list of objects of the [[kingraph]] type which contain the kinematically relevant data for the mapping calculation as well as the mappings themselves. Every graph should have an index which is unique. Graphs which are not needed any more can be disabled by setting the [[keep]] variable to [[false]]. <>= type, abstract :: graph_t integer :: index = 0 integer :: n_nodes = 0 logical :: keep = .true. end type graph_t @ %def graph_t @ This is the type representing the Feynman diagrams which are read from an input file created by O'Mega. It is a tree of nodes, which we call [[f_nodes]], so that [[feyngraph_t]] contains a pointer to the root of this tree, and each node can have two daughter nodes. The case of only one associated daughter should never appear, because in the method of phase space parametrization which is used here, we combine always two particle momenta to a third one. The [[feyngraphs]] will be arranged in a linked list. This is why we have a pointer to the next graph. The [[kingraphs]] on the other hand are arranged in linked lists which are attached to the corresponding [[feyngraph]]. In general, a [[feyngraph]] can give rise to more than one [[kingraph]] because we make a copy every time a particle can be resonant, so that in the copy we keep the particle nonresonant. <>= type, extends (graph_t) :: feyngraph_t type (string_t) :: omega_feyngraph_output type (f_node_t), pointer :: root => null () type (feyngraph_t), pointer :: next => null() type (kingraph_t), pointer :: kin_first => null () type (kingraph_t), pointer :: kin_last => null () contains <> end type feyngraph_t @ %def feyngraph_t @ A container for a pointer of type [[feyngraph_t]]. This is used to realize arrays of these pointers. <>= type :: feyngraph_ptr_t type (feyngraph_t), pointer :: graph => null () end type feyngraph_ptr_t @ %def feyngraph_ptr_t @ The length of a string describing a Feynman diagram which is produced by O'Mega is fixed by the parameter <>= integer, parameter :: FEYNGRAPH_LEN=300 @ %def feyngraph_len <>= procedure :: final => feyngraph_final <>= subroutine feyngraph_final (graph) class(feyngraph_t), intent(inout) :: graph type (kingraph_t), pointer :: current graph%root => null () graph%kin_last => null () do while (associated (graph%kin_first)) current => graph%kin_first graph%kin_first => graph%kin_first%next call current%final () deallocate (current) enddo end subroutine feyngraph_final @ %def feyngraph_final This is the type of graph which is used to find the phase space channels, or in other words, each kingraph could correspond to a channel, if it is not eliminated for kinematical reasons or due to an equivalence. For the linked list which is attached to the corresponding [[feyngraph]], we need the [[next]] pointer, whereas [[grove_next]] points to the next [[kingraph]] within a grove. The information which is relevant for the specification of a channel is stored in [[tree]]. We use [[grove_prop]] to sort the [[kingraph]] in a grove in which all [[kingraphs]] are characterized by the numbers contained in [[grove_prop]]. Later these groves are further subdevided using the resonance hash. A [[kingraph]] which is constructed directly from the output of O'Mega, is not [[inverse]]. In this case the first incoming particle is the root ofthe tree. In a scattering process, we can also construct a [[kingraph]] where the root of the tree is the second incoming particle. In this case the value of [[inverse]] is [[.true.]]. <>= type, extends (graph_t) :: kingraph_t type (k_node_t), pointer :: root => null () type (kingraph_t), pointer :: next => null() type (kingraph_t), pointer :: grove_next => null () type (tree_t) :: tree type (grove_prop_t) :: grove_prop logical :: inverse = .false. integer :: prc_component = 0 contains <> end type kingraph_t @ %def kingraph_t @ Another container for a pointer to emulate arrays of pointers: <>= type :: kingraph_ptr_t type (kingraph_t), pointer :: graph => null () end type kingraph_ptr_t @ %def kingraph_ptr_t @ <>= procedure :: final => kingraph_final <>= subroutine kingraph_final (graph) class(kingraph_t), intent(inout) :: graph graph%root => null () graph%next => null () graph%grove_next => null () call graph%tree%final () end subroutine kingraph_final @ %def kingraph_final @ \subsection{The node types} We define an abstract type containing variables which are needed for [[f_node_t]] as well as [[k_node_t]]. We say that a node is on the t-line if it lies between the two nodes which correspond to the two incoming particles. [[incoming]] and [[tline]] are used only for scattering processes and remain [[.false.]] in decay processes. The variable [[n_subtree_nodes]] holds the number of nodes (including the node itself) of the subtree of which the node is the root. <>= type, abstract :: node_t type (part_prop_t), pointer :: particle => null () logical :: incoming = .false. logical :: t_line = .false. integer :: index = 0 logical :: keep = .true. integer :: n_subtree_nodes = 1 end type node_t @ %def node_t @ We use two different list types for the different kinds of nodes. We therefore start with an abstract type: <>= type, abstract :: list_t integer :: n_entries = 0 end type list_t @ %def list_t @ Since the contents of the lists are different, we introduce two different entry types. Since the trees of nodes use pointers, the nodes should only be allocated by a type-bound procedure of the corresponding list type, such that we can keep track of all nodes, eventually reuse and in the end deallocate nodes correctly, without forgetting any nodes. Here is the type for the [[k_nodes]]. The list is a linked list. We want to reuse (recycle) the [[k_nodes]] which are neither [[incoming]] nore [[t_line]]. <>= type :: k_node_entry_t type (k_node_t), pointer :: node => null () type (k_node_entry_t), pointer :: next => null () logical :: recycle = .false. contains <> end type k_node_entry_t @ %def k_node_entry_t <>= procedure :: final => k_node_entry_final <>= subroutine k_node_entry_final (entry) class(k_node_entry_t), intent(inout) :: entry if (associated (entry%node)) then call entry%node%final deallocate (entry%node) end if entry%next => null () end subroutine k_node_entry_final @ %def k_node_entry_final <>= procedure :: write => k_node_entry_write <>= subroutine k_node_entry_write (k_node_entry, u) class (k_node_entry_t), intent (in) :: k_node_entry integer, intent (in) :: u end subroutine k_node_entry_write @ %def k_node_entry_write @ Here is the list type for [[k_nodes]]. A [[k_node_list]] can be declared to be an observer. In this case it does not create any nodes by itself, but the entries set their pointers to existing nodes. In this way we can use the list structure and the type bound procedures for existing nodes. <>= type, extends (list_t) :: k_node_list_t type (k_node_entry_t), pointer :: first => null () type (k_node_entry_t), pointer :: last => null () integer :: n_recycle logical :: observer = .false. contains <> end type k_node_list_t @ %def k_node_list_t <>= procedure :: final => k_node_list_final <>= subroutine k_node_list_final (list) class(k_node_list_t), intent(inout) :: list type (k_node_entry_t), pointer :: current do while (associated (list%first)) current => list%first list%first => list%first%next if (list%observer) current%node => null () call current%final () deallocate (current) enddo end subroutine k_node_list_final @ %def k_node_list_final @ The [[f_node_t]] type contains the [[particle_label]] variable which is extracted from the input file. It consists not only of the particle name, but also of some numbers in brackets. These numbers indicate which external particles are part of the subtree of this node. The [[f_node]] contains also a list of [[k_nodes]]. Therefore, if the nodes are not [[incoming]] or [[t_line]], the mapping calculations for these [[k_nodes]] which can appear in several [[kingraphs]] have to be performed only once. <>= type, extends (node_t) :: f_node_t type (f_node_t), pointer :: daughter1 => null () type (f_node_t), pointer :: daughter2 => null () character (len=LABEL_LEN) :: particle_label type (k_node_list_t) :: k_node_list contains <> end type f_node_t @ %def f_node_t @ The finalizer nullifies the daughter pointers, since they are deallocated, like the [[f_node]] itself, with the finalizer of the [[f_node_list]]. <>= procedure :: final => f_node_final <>= recursive subroutine f_node_final (node) class(f_node_t), intent(inout) :: node call node%k_node_list%final () node%daughter1 => null () node%daughter2 => null () end subroutine f_node_final @ %def f_node_final @ Finaliser for [[f_node_entry]]. <>= procedure :: final => f_node_entry_final <>= subroutine f_node_entry_final (entry) class(f_node_entry_t), intent(inout) :: entry if (associated (entry%node)) then call entry%node%final () deallocate (entry%node) end if entry%next => null () end subroutine f_node_entry_final @ %def f_node_entry_final @ Set index if not yet done, i.e. if it is zero. <>= procedure :: set_index => f_node_set_index <>= subroutine f_node_set_index (f_node) class (f_node_t), intent (inout) :: f_node integer, save :: counter = 0 if (f_node%index == 0) then counter = counter + 1 f_node%index = counter end if end subroutine f_node_set_index @ %def f_node_set_index @ Type for the nodes of the tree (lines of the Feynman diagrams). We also need a type containing a pointer to a node, which is needed for creating arrays of pointers. This will be used for scattering processes where we can take either the first or the second particle to be the root of the tree. Since we need both cases for the calculations and O'Mega only gives us one of these, we have to perform a transformation of the graph in which some nodes (on the line which we hereafter call t-line) need to know their mother and sister nodes, which become their daughters within this transformation. <>= type :: f_node_ptr_t type (f_node_t), pointer :: node => null () contains <> end type f_node_ptr_t @ %def f_node_ptr_t <>= procedure :: final => f_node_ptr_final <>= subroutine f_node_ptr_final (f_node_ptr) class (f_node_ptr_t), intent (inout) :: f_node_ptr f_node_ptr%node => null () end subroutine f_node_ptr_final @ %def f_node_ptr_final <>= interface assignment (=) module procedure f_node_ptr_assign end interface assignment (=) <>= subroutine f_node_ptr_assign (ptr1, ptr2) type (f_node_ptr_t), intent (out) :: ptr1 type (f_node_ptr_t), intent (in) :: ptr2 ptr1%node => ptr2%node end subroutine f_node_ptr_assign @ %def f_node_ptr_assign @ <>= type :: k_node_ptr_t type (k_node_t), pointer :: node => null () end type k_node_ptr_t @ %def k_node_ptr_t @ <>= type, extends (node_t) :: k_node_t type (k_node_t), pointer :: daughter1 => null () type (k_node_t), pointer :: daughter2 => null () type (k_node_t), pointer :: inverse_daughter1 => null () type (k_node_t), pointer :: inverse_daughter2 => null () type (f_node_t), pointer :: f_node => null () type (tree_t) :: subtree real (default) :: ext_mass_sum = 0. real (default) :: effective_mass = 0. logical :: resonant = .false. logical :: on_shell = .false. logical :: log_enhanced = .false. integer :: mapping = NO_MAPPING integer(TC) :: bincode = 0 logical :: mapping_assigned = .false. logical :: is_nonresonant_copy = .false. logical :: subtree_checked = .false. integer :: n_off_shell = 0 integer :: n_log_enhanced = 0 integer :: n_resonances = 0 integer :: multiplicity = 0 integer :: n_t_channel = 0 integer :: f_node_index = 0 contains <> end type k_node_t @ %def k_node_t @ Subroutine for [[k_node]] assignment. <>= interface assignment (=) module procedure k_node_assign end interface assignment (=) <>= subroutine k_node_assign (k_node1, k_node2) type (k_node_t), intent (inout) :: k_node1 type (k_node_t), intent (in) :: k_node2 k_node1%f_node => k_node2%f_node k_node1%particle => k_node2%particle k_node1%incoming = k_node2%incoming k_node1%t_line = k_node2%t_line k_node1%keep = k_node2%keep k_node1%n_subtree_nodes = k_node2%n_subtree_nodes k_node1%ext_mass_sum = k_node2%ext_mass_sum k_node1%effective_mass = k_node2%effective_mass k_node1%resonant = k_node2%resonant k_node1%on_shell = k_node2%on_shell k_node1%log_enhanced = k_node2%log_enhanced k_node1%mapping = k_node2%mapping k_node1%bincode = k_node2%bincode k_node1%mapping_assigned = k_node2%mapping_assigned k_node1%is_nonresonant_copy = k_node2%is_nonresonant_copy k_node1%n_off_shell = k_node2%n_off_shell k_node1%n_log_enhanced = k_node2%n_log_enhanced k_node1%n_resonances = k_node2%n_resonances k_node1%multiplicity = k_node2%multiplicity k_node1%n_t_channel = k_node2%n_t_channel k_node1%f_node_index = k_node2%f_node_index end subroutine k_node_assign @ %def k_node_assign @ The finalizer of [[k_node_t]] nullifies all pointers to nodes, since the deallocation of these nodes takes place in the finalizer of the list by which they were created. <>= procedure :: final => k_node_final <>= recursive subroutine k_node_final (k_node) class(k_node_t), intent(inout) :: k_node k_node%daughter1 => null () k_node%daughter2 => null () k_node%inverse_daughter1 => null () k_node%inverse_daughter2 => null () k_node%f_node => null () end subroutine k_node_final @ %def k_node_final @ Set an index to a [[k_node]], if not yet done, i.e. if it is zero. The indices are simply positive integer numbers starting from 1. <>= procedure :: set_index => k_node_set_index <>= subroutine k_node_set_index (k_node) class (k_node_t), intent (inout) :: k_node integer, save :: counter = 0 if (k_node%index == 0) then counter = counter + 1 k_node%index = counter end if end subroutine k_node_set_index @ %def k_node_set_index @ The process type (decay or scattering) is given by an integer which is equal to the number of incoming particles. <>= public :: DECAY, SCATTERING <>= integer, parameter :: DECAY=1, SCATTERING=2 @ %def decay scattering @ The entries of the [[f_node_list]] contain the substring of the input file from which the node's subtree will be constructed (or a modified string containing placeholders for substrings). We use the length of this string for fast comparison to find the nodes in the [[f_node_list]] which we want to reuse. <>= type :: f_node_entry_t character (len=FEYNGRAPH_LEN) :: subtree_string integer :: string_len = 0 type (f_node_t), pointer :: node => null () type (f_node_entry_t), pointer :: next => null () integer :: subtree_size = 0 contains <> end type f_node_entry_t @ %def f_node_entry_t @ A write method for [[f_node_entry]]. <>= procedure :: write => f_node_entry_write <>= subroutine f_node_entry_write (f_node_entry, u) class (f_node_entry_t), intent (in) :: f_node_entry integer, intent (in) :: u write (unit=u, fmt='(A)') trim(f_node_entry%subtree_string) end subroutine f_node_entry_write @ %def f_node_entry_write <>= interface assignment (=) module procedure f_node_entry_assign end interface assignment (=) <>= subroutine f_node_entry_assign (entry1, entry2) type (f_node_entry_t), intent (out) :: entry1 type (f_node_entry_t), intent (in) :: entry2 entry1%node => entry2%node entry1%subtree_string = entry2%subtree_string entry1%string_len = entry2%string_len entry1%subtree_size = entry2%subtree_size end subroutine f_node_entry_assign @ %def f_node_entry_assign @ This is the list type for [[f_nodes]]. The variable [[max_tree_size]] is the number of nodes which appear in a complete graph. <>= type, extends (list_t) :: f_node_list_t type (f_node_entry_t), pointer :: first => null () type (f_node_entry_t), pointer :: last => null () type (k_node_list_t), pointer :: k_node_list => null () integer :: max_tree_size = 0 contains <> end type f_node_list_t @ %def f_node_list_t @ Add an entry to the [[f_node_list]]. If the node might be reused, we check first using the [[subtree_string]] if there is already a node in the list which is the root of exactly the same subtree. Otherwise we add an entry to the list and allocate the node. In both cases we return a pointer to the node which allows to access the node. <>= procedure :: add_entry => f_node_list_add_entry <>= subroutine f_node_list_add_entry (list, subtree_string, ptr_to_node, & recycle, subtree_size) class (f_node_list_t), intent (inout) :: list character (len=*), intent (in) :: subtree_string type (f_node_t), pointer, intent (out) :: ptr_to_node logical, intent (in) :: recycle integer, intent (in), optional :: subtree_size type (f_node_entry_t), pointer :: current type (f_node_entry_t), pointer :: second integer :: subtree_len ptr_to_node => null () if (recycle) then subtree_len = len_trim (subtree_string) current => list%first do while (associated (current)) if (present (subtree_size)) then if (current%subtree_size /= subtree_size) exit end if if (current%string_len == subtree_len) then if (trim (current%subtree_string) == trim (subtree_string)) then ptr_to_node => current%node exit end if end if current => current%next enddo end if if (.not. associated (ptr_to_node)) then if (list%n_entries == 0) then allocate (list%first) list%last => list%first else second => list%first list%first => null () allocate (list%first) list%first%next => second end if list%n_entries = list%n_entries + 1 list%first%subtree_string = trim(subtree_string) list%first%string_len = subtree_len if (present (subtree_size)) list%first%subtree_size = subtree_size allocate (list%first%node) call list%first%node%set_index () ptr_to_node => list%first%node end if end subroutine f_node_list_add_entry @ %def f_node_list_add_entry @ A write method for debugging. <>= procedure :: write => f_node_list_write <>= subroutine f_node_list_write (f_node_list, u) class (f_node_list_t), intent (in) :: f_node_list integer, intent (in) :: u type (f_node_entry_t), pointer :: current integer :: pos = 0 current => f_node_list%first do while (associated (current)) pos = pos + 1 write (unit=u, fmt='(A,I10)') 'entry #: ', pos call current%write (u) write (unit=u, fmt=*) current => current%next enddo end subroutine f_node_list_write @ %def f_node_list_write <>= interface assignment (=) module procedure k_node_entry_assign end interface assignment (=) <>= subroutine k_node_entry_assign (entry1, entry2) type (k_node_entry_t), intent (out) :: entry1 type (k_node_entry_t), intent (in) :: entry2 entry1%node => entry2%node entry1%recycle = entry2%recycle end subroutine k_node_entry_assign @ %def k_node_entry_assign @ Add an entry to the [[k_node_list]]. We have to specify if the node can be reused. The check for existing reusable nodes happens with [[k_node_list_get_nodes]] (see below). <>= procedure :: add_entry => k_node_list_add_entry <>= recursive subroutine k_node_list_add_entry (list, ptr_to_node, recycle) class (k_node_list_t), intent (inout) :: list type (k_node_t), pointer, intent (out) :: ptr_to_node logical, intent (in) :: recycle if (list%n_entries == 0) then allocate (list%first) list%last => list%first else allocate (list%last%next) list%last => list%last%next end if list%n_entries = list%n_entries + 1 list%last%recycle = recycle allocate (list%last%node) call list%last%node%set_index () ptr_to_node => list%last%node end subroutine k_node_list_add_entry @ %def k_node_list_add_entry @ We need a similar subroutine for adding only a pointer to a list. This is needed for a [[k_node_list]] which is only an observer, i.e. it does not create any nodes by itself. <>= procedure :: add_pointer => k_node_list_add_pointer <>= subroutine k_node_list_add_pointer (list, ptr_to_node, recycle) class (k_node_list_t), intent (inout) :: list type (k_node_t), pointer, intent (in) :: ptr_to_node logical, optional, intent (in) :: recycle logical :: rec if (present (recycle)) then rec = recycle else rec = .false. end if if (list%n_entries == 0) then allocate (list%first) list%last => list%first else allocate (list%last%next) list%last => list%last%next end if list%n_entries = list%n_entries + 1 list%last%recycle = rec list%last%node => ptr_to_node end subroutine k_node_list_add_pointer @ %def k_node_list_add_pointer @ The [[k_node_list]] can also be used to collect [[k_nodes]] which belong to different [[f_nodes]] in order to compare these. This is done only for nodes which have the same number of subtree nodes. We compare all nodes of the list with each other (as long as the node is not deactivated, i.e. if the [[keep]] variable is set to [[.true.]]) using the subroutine [[subtree_select]]. If it turns out that two nodes are equivalent, we keep only one of them. The term equivalent in this module refers to trees or subtrees which differ in the pdg codes at positions where the trivial mapping is used ([[NO_MAPPING]] or [[NON_RESONANT]]) so that the mass of the particle does not matter. Depending on the available couplings, two equivalent subtrees could eventually lead to the same phase space channels, which is why only one of them is kept. <>= procedure :: check_subtree_equivalences => k_node_list_check_subtree_equivalences <>= subroutine k_node_list_check_subtree_equivalences (list, model) class (k_node_list_t), intent (inout) :: list type (model_data_t), intent (in) :: model type (k_node_ptr_t), dimension (:), allocatable :: set type (k_node_entry_t), pointer :: current integer :: pos integer :: i,j if (list%n_entries == 0) return allocate (set (list%n_entries)) current => list%first pos = 0 do while (associated (current)) pos = pos + 1 set(pos)%node => current%node current => current%next enddo do i=1, list%n_entries if (set(i)%node%keep) then do j=i+1, list%n_entries if (set(j)%node%keep) then if (set(i)%node%bincode == set(j)%node%bincode) then call subtree_select (set(i)%node%subtree,set(j)%node%subtree, model) if (.not. set(i)%node%subtree%keep) then set(i)%node%keep = .false. exit else if (.not. set(j)%node%subtree%keep) then set(j)%node%keep = .false. end if end if end if enddo end if enddo deallocate (set) end subroutine k_node_list_check_subtree_equivalences @ %def k_node_list_check_subtree_equivalences @ This subroutine is used to obtain all [[k_nodes]] of a [[k_node_list]] which can be recycled and are not disabled for some reason. We pass an allocatable array of the type [[k_node_ptr_t]] which will be allocated if there are any such nodes in the list and the pointers will be associated with these nodes. <>= procedure :: get_nodes => k_node_list_get_nodes <>= subroutine k_node_list_get_nodes (list, nodes) class (k_node_list_t), intent (inout) :: list type (k_node_ptr_t), dimension(:), allocatable, intent (out) :: nodes integer :: n_nodes integer :: pos type (k_node_entry_t), pointer :: current, garbage n_nodes = 0 current => list%first do while (associated (current)) if (current%recycle .and. current%node%keep) n_nodes = n_nodes + 1 current => current%next enddo if (n_nodes /= 0) then pos = 1 allocate (nodes (n_nodes)) do while (associated (list%first) .and. .not. list%first%node%keep) garbage => list%first list%first => list%first%next call garbage%final () deallocate (garbage) enddo current => list%first do while (associated (current)) do while (associated (current%next)) if (.not. current%next%node%keep) then garbage => current%next current%next => current%next%next call garbage%final deallocate (garbage) else exit end if enddo if (current%recycle .and. current%node%keep) then nodes(pos)%node => current%node pos = pos + 1 end if current => current%next enddo end if end subroutine k_node_list_get_nodes @ %def k_node_list_get_nodes <>= procedure :: final => f_node_list_final <>= subroutine f_node_list_final (list) class (f_node_list_t) :: list type (f_node_entry_t), pointer :: current list%k_node_list => null () do while (associated (list%first)) current => list%first list%first => list%first%next call current%final () deallocate (current) enddo end subroutine f_node_list_final @ %def f_node_list_final @ \subsection{The grove list} First a type is introduced in order to speed up the comparison of kingraphs with the purpose to quickly find the graphs that might be equivalent. This is done solely on the basis of a number (which is given by the value of [[depth]] in [[compare_tree_t]]) of bincodes, which are the highest ones that do not belong to external particles. The highest such value determines the index of the element in the [[entry]] array of the [[compare_tree]]. The next lower such value determines the index of the element in the [[entry]] array of this [[entry]], and so on and so forth. This results in a tree structure where the number of levels is given by [[depth]] and should not be too large for reasons of memory. This is the entry type. <>= type :: compare_tree_entry_t type (compare_tree_entry_t), dimension(:), pointer :: entry => null () type (kingraph_ptr_t), dimension(:), allocatable :: graph_entry contains <> end type compare_tree_entry_t @ %def compare_tree_entry_t @ This is the tree type. <>= type :: compare_tree_t integer :: depth = 3 type (compare_tree_entry_t), dimension(:), pointer :: entry => null () contains <> end type compare_tree_t @ %def compare_tree_t @ Finalizers for both types. The one for the entry type has to be recursive. <>= procedure :: final => compare_tree_final <>= subroutine compare_tree_final (ctree) class (compare_tree_t), intent (inout) :: ctree integer :: i if (associated (ctree%entry)) then do i=1, size (ctree%entry) call ctree%entry(i)%final () deallocate (ctree%entry) end do end if end subroutine compare_tree_final @ %def compare_tree_final <>= procedure :: final => compare_tree_entry_final <>= recursive subroutine compare_tree_entry_final (ct_entry) class (compare_tree_entry_t), intent (inout) :: ct_entry integer :: i if (associated (ct_entry%entry)) then do i=1, size (ct_entry%entry) call ct_entry%entry(i)%final () enddo deallocate (ct_entry%entry) else deallocate (ct_entry%graph_entry) end if end subroutine compare_tree_entry_final @ %def compare_tree_entry_final @ Check the presence of a graph which is considered as equivalent and select between the two. If there is no such graph, the current one is added to the list. First the entry has to be found: <>= procedure :: check_kingraph => compare_tree_check_kingraph <>= subroutine compare_tree_check_kingraph (ctree, kingraph, model, preliminary) class (compare_tree_t), intent (inout) :: ctree type (kingraph_t), intent (inout), pointer :: kingraph type (model_data_t), intent (in) :: model logical, intent (in) :: preliminary integer :: i integer :: pos integer(TC) :: sz integer(TC), dimension(:), allocatable :: identifier if (.not. associated (ctree%entry)) then sz = 0_TC do i = size(kingraph%tree%bc), 1, -1 sz = ior (sz, kingraph%tree%bc(i)) enddo if (sz > 0) then allocate (ctree%entry (sz)) else call msg_bug ("Compare tree could not be created") end if end if allocate (identifier (ctree%depth)) pos = 0 do i = size(kingraph%tree%bc), 1, -1 if (popcnt (kingraph%tree%bc(i)) /= 1) then pos = pos + 1 identifier(pos) = kingraph%tree%bc(i) if (pos == ctree%depth) exit end if enddo if (size (identifier) > 1) then call ctree%entry(identifier(1))%check_kingraph (kingraph, model, & preliminary, identifier(1), identifier(2:)) else if (size (identifier) == 1) then call ctree%entry(identifier(1))%check_kingraph (kingraph, model, preliminary) end if deallocate (identifier) end subroutine compare_tree_check_kingraph @ %def compare_tree_check_kingraph @ Then the graphs of the entry are checked. <>= procedure :: check_kingraph => compare_tree_entry_check_kingraph <>= recursive subroutine compare_tree_entry_check_kingraph (ct_entry, kingraph, & model, preliminary, subtree_size, identifier) class (compare_tree_entry_t), intent (inout) :: ct_entry type (kingraph_t), pointer, intent (inout) :: kingraph type (model_data_t), intent (in) :: model logical, intent (in) :: preliminary integer, intent (in), optional :: subtree_size integer, dimension (:), intent (in), optional :: identifier if (present (identifier)) then if (.not. associated (ct_entry%entry)) & allocate (ct_entry%entry(subtree_size)) if (size (identifier) > 1) then call ct_entry%entry(identifier(1))%check_kingraph (kingraph, & model, preliminary, identifier(1), identifier(2:)) else if (size (identifier) == 1) then call ct_entry%entry(identifier(1))%check_kingraph (kingraph, & model, preliminary) end if else if (allocated (ct_entry%graph_entry)) then call perform_check else allocate (ct_entry%graph_entry(1)) ct_entry%graph_entry(1)%graph => kingraph end if end if contains subroutine perform_check integer :: i logical :: rebuild rebuild = .true. do i=1, size(ct_entry%graph_entry) if (ct_entry%graph_entry(i)%graph%keep) then if (preliminary .or. & ct_entry%graph_entry(i)%graph%prc_component /= kingraph%prc_component) then call kingraph_select (ct_entry%graph_entry(i)%graph, kingraph, model, preliminary) if (.not. kingraph%keep) then return else if (rebuild .and. .not. ct_entry%graph_entry(i)%graph%keep) then ct_entry%graph_entry(i)%graph => kingraph rebuild = .false. end if end if end if enddo if (rebuild) call rebuild_graph_entry end subroutine perform_check subroutine rebuild_graph_entry type (kingraph_ptr_t), dimension(:), allocatable :: tmp_ptr integer :: i integer :: pos allocate (tmp_ptr(size(ct_entry%graph_entry)+1)) pos = 0 do i=1, size(ct_entry%graph_entry) pos = pos + 1 tmp_ptr(pos)%graph => ct_entry%graph_entry(i)%graph enddo pos = pos + 1 tmp_ptr(pos)%graph => kingraph deallocate (ct_entry%graph_entry) allocate (ct_entry%graph_entry (pos)) do i=1, pos ct_entry%graph_entry(i)%graph => tmp_ptr(i)%graph enddo deallocate (tmp_ptr) end subroutine rebuild_graph_entry end subroutine compare_tree_entry_check_kingraph @ %def compare_tree_entry_check_kingraph @ The grove to which a completed [[kingraph]] will be added is determined by the entries of [[grove_prop]]. We use another list type (linked list) to arrange the groves. Each [[grove]] contains again a linked list of [[kingraphs]]. <>= type :: grove_t type (grove_prop_t) :: grove_prop type (grove_t), pointer :: next => null () type (kingraph_t), pointer :: first => null () type (kingraph_t), pointer :: last => null () type (compare_tree_t) :: compare_tree contains <> end type grove_t @ %def grove_t @ Container for a pointer of type [[grove_t]]: <>= type :: grove_ptr_t type (grove_t), pointer :: grove => null () end type grove_ptr_t @ %def grove_ptr_t <>= procedure :: final => grove_final <>= subroutine grove_final (grove) class(grove_t), intent(inout) :: grove grove%first => null () grove%last => null () grove%next => null () end subroutine grove_final @ %def grove_final @ This is the list type: <>= type :: grove_list_t type (grove_t), pointer :: first => null () contains <> end type grove_list_t @ %def grove_list_t <>= procedure :: final => grove_list_final <>= subroutine grove_list_final (list) class(grove_list_t), intent(inout) :: list class(grove_t), pointer :: current do while (associated (list%first)) current => list%first list%first => list%first%next call current%final () deallocate (current) end do end subroutine grove_list_final @ %def grove_list_final @ \subsection{The feyngraph set} The fundament of the module is the public type [[feyngraph_set_t]]. It is not only a linked list of all [[feyngraphs]] but contains an array of all particle properties ([[particle]]), an [[f_node_list]] and a pointer of the type [[grove_list_t]], since several [[feyngraph_sets]] can share a common [[grove_list]]. In addition it keeps the data which unambiguously specifies the process, as well as the model which provides information which allows us to choose between equivalent subtrees or complete [[kingraphs]]. <>= public :: feyngraph_set_t <>= type :: feyngraph_set_t type (model_data_t), pointer :: model => null () type(flavor_t), dimension(:,:), allocatable :: flv integer :: n_in = 0 integer :: n_out = 0 integer :: process_type = DECAY type (phs_parameters_t) :: phs_par logical :: fatal_beam_decay = .true. type (part_prop_t), dimension (:), pointer :: particle => null () type (f_node_list_t) :: f_node_list type (feyngraph_t), pointer :: first => null () type (feyngraph_t), pointer :: last => null () integer :: n_graphs = 0 type (grove_list_t), pointer :: grove_list => null () logical :: use_dag = .true. type (dag_t), pointer :: dag => null () type (feyngraph_set_t), dimension (:), pointer :: fset => null () contains <> end type feyngraph_set_t @ %def feyngraph_set_t @ This final procedure contains calls to all other necessary final procedures. <>= procedure :: final => feyngraph_set_final <>= recursive subroutine feyngraph_set_final (set) class(feyngraph_set_t), intent(inout) :: set class(feyngraph_t), pointer :: current integer :: i if (associated (set%fset)) then do i=1, size (set%fset) call set%fset(i)%final () enddo deallocate (set%fset) else set%particle => null () set%grove_list => null () end if set%model => null () if (allocated (set%flv)) deallocate (set%flv) set%last => null () do while (associated (set%first)) current => set%first set%first => set%first%next call current%final () deallocate (current) end do if (associated (set%particle)) then do i = 1, size (set%particle) call set%particle(i)%final () end do deallocate (set%particle) end if if (associated (set%grove_list)) then call msg_debug (D_PHASESPACE, "grove_list: final") call set%grove_list%final () deallocate (set%grove_list) end if call msg_debug (D_PHASESPACE, "f_node_list: final") call set%f_node_list%final () if (associated (set%dag)) then call msg_debug (D_PHASESPACE, "dag: final") if (associated (set%dag)) then call set%dag%final () deallocate (set%dag) end if end if end subroutine feyngraph_set_final @ %def feyngraph_set_final @ \subsection{Construct the feyngraph set} We construct the [[feyngraph_set]] from an input file. Therefore we pass a unit to [[feyngraph_set_build]]. The parsing subroutines are chosen depending on the value of [[use_dag]]. In the DAG output, which is the one that is produced by default, we have to work on a string of one line, where the lenght of this string becomes larger the more particles are involved in the process. The other output (which is now only used in a unit test) contains one Feynman diagram per line and each line starts with an open parenthesis so that we read the file line per line and create a [[feyngraph]] for every line. Only after this, nodes are created. In both decay and scattering processes the diagrams are represented like in a decay process, i.e. in a scattering process one of the incoming particles appears as an outgoing particle. <>= procedure :: build => feyngraph_set_build <>= subroutine feyngraph_set_build (feyngraph_set, u_in) class (feyngraph_set_t), intent (inout) :: feyngraph_set integer, intent (in) :: u_in integer :: stat = 0 character (len=FEYNGRAPH_LEN) :: omega_feyngraph_output type (feyngraph_t), pointer :: current_graph type (feyngraph_t), pointer :: compare_graph logical :: present if (feyngraph_set%use_dag) then allocate (feyngraph_set%dag) if (.not. associated (feyngraph_set%first)) then call feyngraph_set%dag%read_string (u_in, feyngraph_set%flv(:,1)) call feyngraph_set%dag%construct (feyngraph_set) call feyngraph_set%dag%make_feyngraphs (feyngraph_set) end if else if (.not. associated (feyngraph_set%first)) then read (unit=u_in, fmt='(A)', iostat=stat, advance='yes') omega_feyngraph_output if (omega_feyngraph_output(1:1) == '(') then allocate (feyngraph_set%first) feyngraph_set%first%omega_feyngraph_output = trim(omega_feyngraph_output) feyngraph_set%last => feyngraph_set%first feyngraph_set%n_graphs = feyngraph_set%n_graphs + 1 else call msg_fatal ("Invalid input file") end if read (unit=u_in, fmt='(A)', iostat=stat, advance='yes') omega_feyngraph_output do while (stat == 0) if (omega_feyngraph_output(1:1) == '(') then compare_graph => feyngraph_set%first present = .false. do while (associated (compare_graph)) if (len_trim(compare_graph%omega_feyngraph_output) & == len_trim(omega_feyngraph_output)) then if (compare_graph%omega_feyngraph_output == omega_feyngraph_output) then present = .true. exit end if end if compare_graph => compare_graph%next enddo if (.not. present) then allocate (feyngraph_set%last%next) feyngraph_set%last => feyngraph_set%last%next feyngraph_set%last%omega_feyngraph_output = trim(omega_feyngraph_output) feyngraph_set%n_graphs = feyngraph_set%n_graphs + 1 end if read (unit=u_in, fmt='(A)', iostat=stat, advance='yes') omega_feyngraph_output else exit end if enddo current_graph => feyngraph_set%first do while (associated (current_graph)) call feyngraph_construct (feyngraph_set, current_graph) current_graph => current_graph%next enddo feyngraph_set%f_node_list%max_tree_size = feyngraph_set%first%n_nodes end if end if end subroutine feyngraph_set_build @ %def feyngraph_set_build @ Read the string from the file. The output which is produced by O'Mega contains the DAG in a factorised form as a long string, distributed over several lines (in addition, in the case of a scattering process, it contains a similar string for the same process, but with the other incoming particle as the root of the tree structure). In general, such a file can contain many of these strings, belonging to different process components. Therefore we first have to find the correct position of the string for the process in question. Therefore we look for a line containing a pair of colons, in which case the line contains a process string. Then we check if the process string describes the correct process, which is done by checking for all the incoming and outgoing particle names. If the process is correct, the dag output should start in the following line. As long as we do not find the correct process string, we continue searching. If we reach the end of the file, we rewind the unit once, and repeat searching. If the process is still not found, there must be some sort of error. <>= procedure :: read_string => dag_read_string <>= subroutine dag_read_string (dag, u_in, flv) class (dag_t), intent (inout) :: dag integer, intent (in) :: u_in type(flavor_t), dimension(:), intent(in) :: flv character (len=BUFFER_LEN) :: process_string logical :: process_found logical :: rewound !!! find process string in file process_found = .false. rewound = .false. do while (.not. process_found) process_string = "" read (unit=u_in, fmt='(A)') process_string if (len_trim(process_string) /= 0) then if (index (process_string, "::") > 0) then process_found = process_string_match (trim (process_string), flv) end if else if (.not. rewound) then rewind (u_in) rewound = .true. else call msg_bug ("Process string not found in O'Mega input file.") end if enddo call fds_file_get_line (u_in, dag%string) call dag%string%clean () if (.not. allocated (dag%string%t) .or. dag%string%char_len == 0) & call msg_bug ("Process string not found in O'Mega input file.") end subroutine dag_read_string @ %def dag_read_string @ The output of factorized Feynman diagrams which is created by O'Mega for a given process could in principle be written to a single line in the file. This can however lead to different problems with different compilers as soon as such lines become too long. This is the reason why the line is cut into smaller pieces. This means that a new line starts after each vertical bar. For this long string the type [[dag_string_t]] has been introduced. In order to read the file quickly into such a [[dag_string]] we use another type, [[dag_chain_t]] which is a linked list of such [[dag_strings]]. This has the advantage that we do not have to recreate a new [[dag_string]] for every line which has been read from file. Only in the end of this operation we compress the list of strings to a single string, removing useless [[dag_tokens]], such as blanc space tokens. This subroutine reads all lines starting from the position in the file the unit is connected to, until no backslash character is found at the end of a line (the backslash means that the next line also belongs to the current string). <>= integer, parameter :: BUFFER_LEN = 1000 integer, parameter :: STACK_SIZE = 100 @ %def BUFFER_LEN STACK_SIZE <>= subroutine fds_file_get_line (u, string) integer, intent (in) :: u type (dag_string_t), intent (out) :: string type (dag_chain_t) :: chain integer :: string_size, current_len character (len=BUFFER_LEN) :: buffer integer :: fragment_len integer :: stat current_len = 0 stat = 0 string_size = 0 do while (stat == 0) read (unit=u, fmt='(A)', iostat=stat) buffer if (stat /= 0) exit fragment_len = len_trim (buffer) if (fragment_len == 0) then exit else if (buffer (fragment_len:fragment_len) == BACKSLASH_CHAR) then fragment_len = fragment_len - 1 end if call chain%append (buffer(:fragment_len)) if (buffer(fragment_len+1:fragment_len+1) /= BACKSLASH_CHAR) exit enddo if (associated (chain%first)) then call chain%compress () string = chain%first call chain%final () end if end subroutine fds_file_get_line @ %def fds_file_get_line @ We check, if the process string which has been read from file corresponds to the process for which we want to extract the Feynman diagrams. <>= function process_string_match (string, flv) result (match) character (len=*), intent(in) :: string type(flavor_t), dimension(:), intent(in) :: flv logical :: match integer :: pos integer :: occurence integer :: i pos = 1 match = .false. do i=1, size (flv) occurence = index (string(pos:), char(flv(i)%get_name())) if (occurence > 0) then pos = pos + occurence match = .true. else match = .false. exit end if enddo end function process_string_match @ %def process_string_match @ \subsection{Particle properties} This subroutine initializes a model instance with the Standard Model data. It is only relevant for a unit test. We do not have to care about the model initialization in this module because the [[model]] is passed to [[feyngraph_set_generate]] when it is called. <>= public :: init_sm_full_test <>= subroutine init_sm_full_test (model) class(model_data_t), intent(out) :: model type(field_data_t), pointer :: field integer, parameter :: n_real = 17 integer, parameter :: n_field = 21 integer, parameter :: n_vtx = 56 integer :: i call model%init (var_str ("SM_vertex_test"), & n_real, 0, n_field, n_vtx) call model%init_par (1, var_str ("mZ"), 91.1882_default) call model%init_par (2, var_str ("mW"), 80.419_default) call model%init_par (3, var_str ("mH"), 125._default) call model%init_par (4, var_str ("me"), 0.000510997_default) call model%init_par (5, var_str ("mmu"), 0.105658389_default) call model%init_par (6, var_str ("mtau"), 1.77705_default) call model%init_par (7, var_str ("ms"), 0.095_default) call model%init_par (8, var_str ("mc"), 1.2_default) call model%init_par (9, var_str ("mb"), 4.2_default) call model%init_par (10, var_str ("mtop"), 173.1_default) call model%init_par (11, var_str ("wtop"), 1.523_default) call model%init_par (12, var_str ("wZ"), 2.443_default) call model%init_par (13, var_str ("wW"), 2.049_default) call model%init_par (14, var_str ("wH"), 0.004143_default) call model%init_par (15, var_str ("ee"), 0.3079561542961_default) call model%init_par (16, var_str ("cw"), 8.819013863636E-01_default) call model%init_par (17, var_str ("sw"), 4.714339240339E-01_default) i = 0 i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("D_QUARK"), 1) call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2) call field%set (name = [var_str ("d")], anti = [var_str ("dbar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("U_QUARK"), 2) call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2) call field%set (name = [var_str ("u")], anti = [var_str ("ubar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("S_QUARK"), 3) call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2) call field%set (mass_data=model%get_par_real_ptr (7)) call field%set (name = [var_str ("s")], anti = [var_str ("sbar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("C_QUARK"), 4) call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2) call field%set (mass_data=model%get_par_real_ptr (8)) call field%set (name = [var_str ("c")], anti = [var_str ("cbar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("B_QUARK"), 5) call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2) call field%set (mass_data=model%get_par_real_ptr (9)) call field%set (name = [var_str ("b")], anti = [var_str ("bbar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("T_QUARK"), 6) call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2) call field%set (mass_data=model%get_par_real_ptr (10)) call field%set (width_data=model%get_par_real_ptr (11)) call field%set (name = [var_str ("t")], anti = [var_str ("tbar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("E_LEPTON"), 11) call field%set (spin_type=2) call field%set (mass_data=model%get_par_real_ptr (4)) call field%set (name = [var_str ("e-")], anti = [var_str ("e+")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("E_NEUTRINO"), 12) call field%set (spin_type=2, is_left_handed=.true.) call field%set (name = [var_str ("nue")], anti = [var_str ("nuebar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("MU_LEPTON"), 13) call field%set (spin_type=2) call field%set (mass_data=model%get_par_real_ptr (5)) call field%set (name = [var_str ("mu-")], anti = [var_str ("mu+")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("MU_NEUTRINO"), 14) call field%set (spin_type=2, is_left_handed=.true.) call field%set (name = [var_str ("numu")], anti = [var_str ("numubar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("TAU_LEPTON"), 15) call field%set (spin_type=2) call field%set (mass_data=model%get_par_real_ptr (6)) call field%set (name = [var_str ("tau-")], anti = [var_str ("tau+")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("TAU_NEUTRINO"), 16) call field%set (spin_type=2, is_left_handed=.true.) call field%set (name = [var_str ("nutau")], anti = [var_str ("nutaubar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("GLUON"), 21) call field%set (spin_type=3, color_type=8) call field%set (name = [var_str ("gl")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("PHOTON"), 22) call field%set (spin_type=3) call field%set (name = [var_str ("A")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("Z_BOSON"), 23) call field%set (spin_type=3) call field%set (mass_data=model%get_par_real_ptr (1)) call field%set (width_data=model%get_par_real_ptr (12)) call field%set (name = [var_str ("Z")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("W_BOSON"), 24) call field%set (spin_type=3) call field%set (mass_data=model%get_par_real_ptr (2)) call field%set (width_data=model%get_par_real_ptr (13)) call field%set (name = [var_str ("W+")], anti = [var_str ("W-")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("HIGGS"), 25) call field%set (spin_type=1) call field%set (mass_data=model%get_par_real_ptr (3)) call field%set (width_data=model%get_par_real_ptr (14)) call field%set (name = [var_str ("H")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("PROTON"), 2212) call field%set (spin_type=2) call field%set (name = [var_str ("p")], anti = [var_str ("pbar")]) ! call field%set (mass_data=model%get_par_real_ptr (12)) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("HADRON_REMNANT_SINGLET"), 91) call field%set (color_type=1) call field%set (name = [var_str ("hr1")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("HADRON_REMNANT_TRIPLET"), 92) call field%set (color_type=3) call field%set (name = [var_str ("hr3")], anti = [var_str ("hr3bar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("HADRON_REMNANT_OCTET"), 93) call field%set (color_type=8) call field%set (name = [var_str ("hr8")]) call model%freeze_fields () i = 0 i = i + 1 !!! QED call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("A")]) i = i + 1 call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("A")]) i = i + 1 call model%set_vertex (i, [var_str ("sbar"), var_str ("s"), var_str ("A")]) i = i + 1 call model%set_vertex (i, [var_str ("cbar"), var_str ("c"), var_str ("A")]) i = i + 1 call model%set_vertex (i, [var_str ("bbar"), var_str ("b"), var_str ("A")]) i = i + 1 call model%set_vertex (i, [var_str ("tbar"), var_str ("t"), var_str ("A")]) i = i + 1 !!! call model%set_vertex (i, [var_str ("e+"), var_str ("e-"), var_str ("A")]) i = i + 1 call model%set_vertex (i, [var_str ("mu+"), var_str ("mu-"), var_str ("A")]) i = i + 1 call model%set_vertex (i, [var_str ("tau+"), var_str ("tau-"), var_str ("A")]) i = i + 1 !!! QCD call model%set_vertex (i, [var_str ("gl"), var_str ("gl"), var_str ("gl")]) i = i + 1 call model%set_vertex (i, [var_str ("gl"), var_str ("gl"), & var_str ("gl"), var_str ("gl")]) i = i + 1 !!! call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("gl")]) i = i + 1 call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("gl")]) i = i + 1 call model%set_vertex (i, [var_str ("sbar"), var_str ("s"), var_str ("gl")]) i = i + 1 call model%set_vertex (i, [var_str ("cbar"), var_str ("c"), var_str ("gl")]) i = i + 1 call model%set_vertex (i, [var_str ("bbar"), var_str ("b"), var_str ("gl")]) i = i + 1 call model%set_vertex (i, [var_str ("tbar"), var_str ("t"), var_str ("gl")]) i = i + 1 !!! Neutral currents call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("Z")]) i = i + 1 call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("Z")]) i = i + 1 call model%set_vertex (i, [var_str ("sbar"), var_str ("s"), var_str ("Z")]) i = i + 1 call model%set_vertex (i, [var_str ("cbar"), var_str ("c"), var_str ("Z")]) i = i + 1 call model%set_vertex (i, [var_str ("bbar"), var_str ("b"), var_str ("Z")]) i = i + 1 call model%set_vertex (i, [var_str ("tbar"), var_str ("t"), var_str ("Z")]) i = i + 1 !!! call model%set_vertex (i, [var_str ("e+"), var_str ("e-"), var_str ("Z")]) i = i + 1 call model%set_vertex (i, [var_str ("mu+"), var_str ("muu-"), var_str ("Z")]) i = i + 1 call model%set_vertex (i, [var_str ("tau+"), var_str ("tau-"), var_str ("Z")]) i = i + 1 call model%set_vertex (i, [var_str ("nuebar"), var_str ("nue"), var_str ("Z")]) i = i + 1 call model%set_vertex (i, [var_str ("numubar"), var_str ("numu"), var_str ("Z")]) i = i + 1 call model%set_vertex (i, [var_str ("nutaubar"), var_str ("nutau"), & var_str ("Z")]) i = i + 1 !!! Charged currents call model%set_vertex (i, [var_str ("ubar"), var_str ("d"), var_str ("W+")]) i = i + 1 call model%set_vertex (i, [var_str ("cbar"), var_str ("s"), var_str ("W+")]) i = i + 1 call model%set_vertex (i, [var_str ("tbar"), var_str ("b"), var_str ("W+")]) i = i + 1 call model%set_vertex (i, [var_str ("dbar"), var_str ("u"), var_str ("W-")]) i = i + 1 call model%set_vertex (i, [var_str ("sbar"), var_str ("c"), var_str ("W-")]) i = i + 1 call model%set_vertex (i, [var_str ("bbar"), var_str ("t"), var_str ("W-")]) i = i + 1 !!! call model%set_vertex (i, [var_str ("nuebar"), var_str ("e-"), var_str ("W+")]) i = i + 1 call model%set_vertex (i, [var_str ("numubar"), var_str ("mu-"), var_str ("W+")]) i = i + 1 call model%set_vertex (i, [var_str ("nutaubar"), var_str ("tau-"), var_str ("W+")]) i = i + 1 call model%set_vertex (i, [var_str ("e+"), var_str ("nue"), var_str ("W-")]) i = i + 1 call model%set_vertex (i, [var_str ("mu+"), var_str ("numu"), var_str ("W-")]) i = i + 1 call model%set_vertex (i, [var_str ("tau+"), var_str ("nutau"), var_str ("W-")]) i = i + 1 !!! Yukawa !!! keeping only 3rd generation for the moment ! call model%set_vertex (i, [var_str ("sbar"), var_str ("s"), var_str ("H")]) ! i = i + 1 ! call model%set_vertex (i, [var_str ("cbar"), var_str ("c"), var_str ("H")]) ! i = i + 1 call model%set_vertex (i, [var_str ("bbar"), var_str ("b"), var_str ("H")]) i = i + 1 call model%set_vertex (i, [var_str ("tbar"), var_str ("t"), var_str ("H")]) i = i + 1 ! call model%set_vertex (i, [var_str ("mubar"), var_str ("mu"), var_str ("H")]) ! i = i + 1 call model%set_vertex (i, [var_str ("taubar"), var_str ("tau"), var_str ("H")]) i = i + 1 !!! Vector-boson self-interactions call model%set_vertex (i, [var_str ("W+"), var_str ("W-"), var_str ("A")]) i = i + 1 call model%set_vertex (i, [var_str ("W+"), var_str ("W-"), var_str ("Z")]) i = i + 1 !!! call model%set_vertex (i, [var_str ("W+"), var_str ("W-"), var_str ("Z"), var_str ("Z")]) i = i + 1 call model%set_vertex (i, [var_str ("W+"), var_str ("W+"), var_str ("W-"), var_str ("W-")]) i = i + 1 call model%set_vertex (i, [var_str ("W+"), var_str ("W-"), var_str ("Z"), var_str ("A")]) i = i + 1 call model%set_vertex (i, [var_str ("W+"), var_str ("W-"), var_str ("A"), var_str ("A")]) i = i + 1 !!! Higgs - vector boson ! call model%set_vertex (i, [var_str ("H"), var_str ("Z"), var_str ("A")]) ! i = i + 1 ! call model%set_vertex (i, [var_str ("H"), var_str ("A"), var_str ("A")]) ! i = i + 1 ! call model%set_vertex (i, [var_str ("H"), var_str ("gl"), var_str ("gl")]) ! i = i + 1 !!! call model%set_vertex (i, [var_str ("H"), var_str ("W+"), var_str ("W-")]) i = i + 1 call model%set_vertex (i, [var_str ("H"), var_str ("Z"), var_str ("Z")]) i = i + 1 call model%set_vertex (i, [var_str ("H"), var_str ("H"), var_str ("W+"), var_str ("W-")]) i = i + 1 call model%set_vertex (i, [var_str ("H"), var_str ("H"), var_str ("Z"), var_str ("Z")]) i = i + 1 !!! Higgs self-interactions call model%set_vertex (i, [var_str ("H"), var_str ("H"), var_str ("H")]) i = i + 1 call model%set_vertex (i, [var_str ("H"), var_str ("H"), var_str ("H"), var_str ("H")]) i = i + 1 call model%freeze_vertices () end subroutine init_sm_full_test @ %def init_sm_full_test @ Initialize a [[part_prop]] object by passing a [[particle_label]], which is simply the particle name. [[part_prop]] should be part of the [[particle]] array of [[feyngraph_set]]. We use the [[model]] of [[feyngraph_set]] to obtain the relevant data of the particle which is needed to find [[phase_space]] parametrizations. When a [[part_prop]] is initialized, we add and initialize also the corresponding anti- particle [[part_prop]] if it is not yet in the array. <>= procedure :: init => part_prop_init <>= recursive subroutine part_prop_init (part_prop, feyngraph_set, particle_label) class (part_prop_t), intent (out), target :: part_prop type (feyngraph_set_t), intent (inout) :: feyngraph_set character (len=*), intent (in) :: particle_label type (flavor_t) :: flv, anti type (string_t) :: name integer :: i name = particle_label call flv%init (name, feyngraph_set%model) part_prop%particle_label = particle_label part_prop%pdg = flv%get_pdg () part_prop%mass = flv%get_mass () part_prop%width = flv%get_width() part_prop%spin_type = flv%get_spin_type () part_prop%is_vector = flv%get_spin_type () == VECTOR part_prop%empty = .false. part_prop%tex_name = flv%get_tex_name () anti = flv%anti () if (flv%get_pdg() == anti%get_pdg()) then select type (part_prop) type is (part_prop_t) part_prop%anti => part_prop end select else do i=1, size (feyngraph_set%particle) if (feyngraph_set%particle(i)%pdg == (- part_prop%pdg)) then part_prop%anti => feyngraph_set%particle(i) exit else if (feyngraph_set%particle(i)%empty) then part_prop%anti => feyngraph_set%particle(i) call feyngraph_set%particle(i)%init (feyngraph_set, char(anti%get_name())) exit end if enddo end if end subroutine part_prop_init @ %def part_prop_init @ This subroutine assigns to a node the particle properties. Since these properties do not change and are simply read from the model file, we use pointers to the elements of the [[particle]] array of the [[feyngraph_set]]. If there is no corresponding array element, we have to initialize the first empty element of the array. <>= integer, parameter :: PRT_ARRAY_SIZE = 200 <>= procedure :: assign_particle_properties => f_node_assign_particle_properties <>= subroutine f_node_assign_particle_properties (node, feyngraph_set) class (f_node_t), intent (inout ) :: node type (feyngraph_set_t), intent (inout) :: feyngraph_set character (len=LABEL_LEN) :: particle_label integer :: i particle_label = node%particle_label(1:index (node%particle_label, '[')-1) if (.not. associated (feyngraph_set%particle)) then allocate (feyngraph_set%particle (PRT_ARRAY_SIZE)) end if do i = 1, size (feyngraph_set%particle) if (particle_label == feyngraph_set%particle(i)%particle_label) then node%particle => feyngraph_set%particle(i) exit else if (feyngraph_set%particle(i)%empty) then call feyngraph_set%particle(i)%init (feyngraph_set, particle_label) node%particle => feyngraph_set%particle(i) exit end if enddo !!! Since the O'Mega output uses the anti-particles instead of the particles specified !!! in the process definition, we revert this here. An exception is the first particle !!! in the parsable DAG output node%particle => node%particle%anti end subroutine f_node_assign_particle_properties @ %def f_node_assign_particle_properties @ From the output of a Feynman diagram (in the non-factorized output) we need to find out how many daughter nodes would be required to reconstruct it correctly, to make sure that we keep only those [[feyngraphs]] which are constructed solely on the basis of the 3-vertices which are provided by the model. The number of daughter particles can easily be determined from the syntax of O'Mega's output: The particle which appears before the colon ':' is the mother particle. The particles or subtrees (i.e. whole parentheses) follow after the colon and are separated by commas. <>= function get_n_daughters (subtree_string, pos_first_colon) & result (n_daughters) character (len=*), intent (in) :: subtree_string integer, intent (in) :: pos_first_colon integer :: n_daughters integer :: n_open_par integer :: i n_open_par = 1 n_daughters = 0 if (len_trim(subtree_string) > 0) then if (pos_first_colon > 0) then do i=pos_first_colon, len_trim(subtree_string) if (subtree_string(i:i) == ',') then if (n_open_par == 1) n_daughters = n_daughters + 1 else if (subtree_string(i:i) == '(') then n_open_par = n_open_par + 1 else if (subtree_string(i:i) == ')') then n_open_par = n_open_par - 1 end if end do if (n_open_par == 0) then n_daughters = n_daughters + 1 end if end if end if end function get_n_daughters @ %def get_n_daughters @ \subsection{Reconstruction of trees} The reconstruction of a tree or subtree with the non-factorized input can be done recursively, i.e. we first find the root of the tree in the string and create an [[f_node]]. Then we look for daughters, which in the string appear either as single particles or subtrees (which are of the same form as the tree which we want to reconstruct. Therefore the subroutine can simply be called again and again until there are no more daughter nodes to create. When we meet a vertex which requires more than two daughter particles, we stop the recursion and disable the node using its [[keep]] variable. Whenever a daughter node is not kept, we do not keep the mother node as well. <>= recursive subroutine node_construct_subtree_rec (feyngraph_set, & feyngraph, subtree_string, mother_node) type (feyngraph_set_t), intent (inout) :: feyngraph_set type (feyngraph_t), intent (inout) :: feyngraph character (len=*), intent (in) :: subtree_string type (f_node_t), pointer, intent (inout) :: mother_node integer :: n_daughters integer :: pos_first_colon integer :: current_daughter integer :: pos_subtree_begin, pos_subtree_end integer :: i integer :: n_open_par if (.not. associated (mother_node)) then call feyngraph_set%f_node_list%add_entry (subtree_string, mother_node, .true.) current_daughter = 1 n_open_par = 1 pos_first_colon = index (subtree_string, ':') n_daughters = get_n_daughters (subtree_string, pos_first_colon) if (pos_first_colon == 0) then mother_node%particle_label = subtree_string else mother_node%particle_label = subtree_string(2:pos_first_colon-1) end if if (.not. associated (mother_node%particle)) then call mother_node%assign_particle_properties (feyngraph_set) end if if (n_daughters /= 2 .and. n_daughters /= 0) then mother_node%keep = .false. feyngraph%keep = .false. return end if pos_subtree_begin = pos_first_colon + 1 do i = pos_first_colon + 1, len(trim(subtree_string)) if (current_daughter == 2) then pos_subtree_end = len(trim(subtree_string)) - 1 call node_construct_subtree_rec (feyngraph_set, feyngraph, & subtree_string(pos_subtree_begin:pos_subtree_end), & mother_node%daughter2) exit else if (subtree_string(i:i) == ',') then if (n_open_par == 1) then pos_subtree_end = i - 1 call node_construct_subtree_rec (feyngraph_set, feyngraph, & subtree_string(pos_subtree_begin:pos_subtree_end), & mother_node%daughter1) current_daughter = 2 pos_subtree_begin = i + 1 end if else if (subtree_string(i:i) == '(') then n_open_par = n_open_par + 1 else if (subtree_string(i:i) == ')') then n_open_par = n_open_par - 1 end if end do end if if (associated (mother_node%daughter1)) then if (.not. mother_node%daughter1%keep) then mother_node%keep = .false. end if end if if (associated (mother_node%daughter2)) then if (.not. mother_node%daughter2%keep) then mother_node%keep = .false. end if end if if (associated (mother_node%daughter1) .and. & associated (mother_node%daughter2)) then mother_node%n_subtree_nodes = & mother_node%daughter1%n_subtree_nodes & + mother_node%daughter2%n_subtree_nodes + 1 end if if (.not. mother_node%keep) then feyngraph%keep = .false. end if end subroutine node_construct_subtree_rec @ %def node_construct_subtree_rec @ When the non-factorized version of the O'Mega output is used, the [[feyngraph]] is reconstructed from the contents of its [[string_t]] variable [[omega_feyngraph_output]]. This can be used for the recursive reconstruction of the tree of [[k_nodes]] with [[node_construct_subtree_rec]]. <>= subroutine feyngraph_construct (feyngraph_set, feyngraph) type (feyngraph_set_t), intent (inout) :: feyngraph_set type (feyngraph_t), pointer, intent (inout) :: feyngraph call node_construct_subtree_rec (feyngraph_set, feyngraph, & char(feyngraph%omega_feyngraph_output), feyngraph%root) feyngraph%n_nodes = feyngraph%root%n_subtree_nodes end subroutine feyngraph_construct @ %def feyngraph_construct @ We introduce another node type, which is called [[dag_node_t]] and is used to reproduce the dag structure which is represented by the input. The [[dag_nodes]] can have several combinations of daughters 1 and 2. The [[dag]] type contains an array of [[dag_nodes]] and is only used for the reconstruction of [[feyngraphs]] which are factorized as well, but in the other direction as the original output. This means in particular that the outgoing particles in the output file (which there can appear many times) exist only once as [[f_nodes]]. To represent combinations of daughters and alternatives (options), we further use the types [[dag_options_t]] and [[dag_combination_t]]. The [[dag_nodes]], [[dag_options]] and [[dag_combinations]] correspond to a substring of the string which has been read from file (and transformed into an object of type [[dag_string_t]], which is simply another compact representation of this string), or a modified version of this substring. The aim is to create only one object for a given substring, even if it appears several times in the original string and then create trees of [[f_nodes]], which build up the [[feyngraph]], such that as many [[f_nodes]] as possible can be reused. An outgoing particle (always interpreting the input as a decay) is called a [[leaf]] in the context of a [[dag]]. <>= type :: dag_node_t integer :: string_len type (dag_string_t) :: string logical :: leaf = .false. type (f_node_ptr_t), dimension (:), allocatable :: f_node integer :: subtree_size = 0 contains <> end type dag_node_t @ %def dag_node_t <>= procedure :: final => dag_node_final <>= subroutine dag_node_final (dag_node) class (dag_node_t), intent (inout) :: dag_node integer :: i call dag_node%string%final () if (allocated (dag_node%f_node)) then do i=1, size (dag_node%f_node) if (associated (dag_node%f_node(i)%node)) then call dag_node%f_node(i)%node%final () deallocate (dag_node%f_node(i)%node) end if enddo deallocate (dag_node%f_node) end if end subroutine dag_node_final @ %def dag_node_final @ Whenever there are more than one possible subtrees (represented by a [[dag_node]]) or combinations of subtrees to daughters (represented by [[dag_combination_t]]), we use the type [[dag_options_t]]. In the syntax of the factorized output, options are listed within curly braces, separated by horizontal bars. <>= type :: dag_options_t integer :: string_len type (dag_string_t) :: string type (f_node_ptr_t), dimension (:), allocatable :: f_node_ptr1 type (f_node_ptr_t), dimension (:), allocatable :: f_node_ptr2 contains <> end type dag_options_t @ %def dag_node_options_t <>= procedure :: final => dag_options_final <>= subroutine dag_options_final (dag_options) class (dag_options_t), intent (inout) :: dag_options integer :: i call dag_options%string%final () if (allocated (dag_options%f_node_ptr1)) then do i=1, size (dag_options%f_node_ptr1) dag_options%f_node_ptr1(i)%node => null () enddo deallocate (dag_options%f_node_ptr1) end if if (allocated (dag_options%f_node_ptr2)) then do i=1, size (dag_options%f_node_ptr2) dag_options%f_node_ptr2(i)%node => null () enddo deallocate (dag_options%f_node_ptr2) end if end subroutine dag_options_final @ %def dag_options_final @ A pair of two daughters (which can be [[dag_nodes]] or [[dag_options]]) is represented by the type [[dag_combination_t]]. In the original string, a [[dag_combination]] appears between parentheses, which contain a comma, but not a colon. If we find a colon between these parentheses, it is a a [[dag_node]] instead. <>= type :: dag_combination_t integer :: string_len type (dag_string_t) :: string integer, dimension (2) :: combination type (f_node_ptr_t), dimension (:), allocatable :: f_node_ptr1 type (f_node_ptr_t), dimension (:), allocatable :: f_node_ptr2 contains <> end type dag_combination_t @ %def dag_combination_t <>= procedure :: final => dag_combination_final <>= subroutine dag_combination_final (dag_combination) class (dag_combination_t), intent (inout) :: dag_combination integer :: i call dag_combination%string%final () if (allocated (dag_combination%f_node_ptr1)) then do i=1, size (dag_combination%f_node_ptr1) dag_combination%f_node_ptr1(i)%node => null () enddo deallocate (dag_combination%f_node_ptr1) end if if (allocated (dag_combination%f_node_ptr2)) then do i=1, size (dag_combination%f_node_ptr2) dag_combination%f_node_ptr2(i)%node => null () enddo deallocate (dag_combination%f_node_ptr2) end if end subroutine dag_combination_final @ %def dag_combination_final @ Here is the type representing the DAG, i.e. it holds arrays of the [[dag_nodes]], [[dag_options]] and [[dag_combinations]]. The root node of the [[dag]] is the last filled element of the [[node]] array. <>= type :: dag_t type (dag_string_t) :: string type (dag_node_t), dimension (:), allocatable :: node type (dag_options_t), dimension (:), allocatable :: options type (dag_combination_t), dimension (:), allocatable :: combination integer :: n_nodes = 0 integer :: n_options = 0 integer :: n_combinations = 0 contains <> end type dag_t @ %def dag_t <>= procedure :: final => dag_final <>= subroutine dag_final (dag) class (dag_t), intent (inout) :: dag integer :: i call dag%string%final () if (allocated (dag%node)) then do i=1, size (dag%node) call dag%node(i)%final () enddo deallocate (dag%node) end if if (allocated (dag%options)) then do i=1, size (dag%options) call dag%options(i)%final () enddo deallocate (dag%options) end if if (allocated (dag%combination)) then do i=1, size (dag%combination) call dag%combination(i)%final () enddo deallocate (dag%combination) end if end subroutine dag_final @ %def dag_final @ We construct the DAG from the given [[dag_string]] which is modified several times so that in the end the remaining string corresponds to a simple [[dag_node]], the root of the factorized tree. This means that we first identify the leaves, i.e. outgoing particles. Then we identify [[dag_nodes]], [[dag_combinations]] and [[options]] until the number of these objects does not change any more. Identifying means that we add a corresponding object to the array (if not yet present), which can be identified with the corresponding substring, and replace the substring in the original [[dag_string]] by a [[dag_token]] of the corresponding type (in the char output of this token, this corresponds to a place holder like e.g. '' which in this particular case corresponds to an option and can be found at the position 23 in the array). The character output of the substrings turns out to be very useful for debugging. <>= procedure :: construct => dag_construct <>= subroutine dag_construct (dag, feyngraph_set) class (dag_t), intent (inout) :: dag type (feyngraph_set_t), intent (inout) :: feyngraph_set integer :: n_nodes integer :: n_options integer :: n_combinations logical :: continue_loop integer :: subtree_size integer :: i,j subtree_size = 1 call dag%get_nodes_and_combinations (leaves = .true.) do i=1, dag%n_nodes call dag%node(i)%make_f_nodes (feyngraph_set, dag) enddo continue_loop = .true. subtree_size = subtree_size + 2 do while (continue_loop) n_nodes = dag%n_nodes n_options = dag%n_options n_combinations = dag%n_combinations call dag%get_nodes_and_combinations (leaves = .false.) if (n_nodes /= dag%n_nodes) then dag%node(n_nodes+1:dag%n_nodes)%subtree_size = subtree_size do i = n_nodes+1, dag%n_nodes call dag%node(i)%make_f_nodes (feyngraph_set, dag) enddo subtree_size = subtree_size + 2 end if if (n_combinations /= dag%n_combinations) then !$OMP PARALLEL DO do i = n_combinations+1, dag%n_combinations call dag%combination(i)%make_f_nodes (feyngraph_set, dag) enddo !$OMP END PARALLEL DO end if call dag%get_options () if (n_options /= dag%n_options) then !$OMP PARALLEL DO do i = n_options+1, dag%n_options call dag%options(i)%make_f_nodes (feyngraph_set, dag) enddo !$OMP END PARALLEL DO end if if (n_nodes == dag%n_nodes .and. n_options == dag%n_options & .and. n_combinations == dag%n_combinations) then continue_loop = .false. end if enddo !!! add root node to dag call dag%add_node (dag%string%t, leaf = .false.) dag%node(dag%n_nodes)%subtree_size = subtree_size call dag%node(dag%n_nodes)%make_f_nodes (feyngraph_set, dag) if (debug2_active (D_PHASESPACE)) then call dag%write (output_unit) end if !!! set indices for all f_nodes do i=1, dag%n_nodes if (allocated (dag%node(i)%f_node)) then do j=1, size (dag%node(i)%f_node) if (associated (dag%node(i)%f_node(j)%node)) & call dag%node(i)%f_node(j)%node%set_index () enddo end if enddo end subroutine dag_construct @ %def dag_construct @ Identify [[dag_nodes]] and [[dag_combinations]]. Leaves are simply nodes (i.e. of type [[NODE_TK]]) where only one bit in the bincode is set. The [[dag_nodes]] and [[dag_combinations]] have in common that they are surrounded by parentheses. There is however a way to distinguish between them because the corresponding substring contains a colon (or [[dag_token]] with type [[COLON_TK]]) if it is a [[dag_node]]. Otherwise it is a [[dag_combination]]. The string of the [[dag_node]] or [[dag_combination]] should not contain curly braces, because these correspond to [[dag_options]] and should be identified before. <>= procedure :: get_nodes_and_combinations => dag_get_nodes_and_combinations <>= subroutine dag_get_nodes_and_combinations (dag, leaves) class (dag_t), intent (inout) :: dag logical, intent (in) :: leaves type (dag_string_t) :: new_string integer :: i, j, k integer :: i_node integer :: new_size integer :: first_colon logical :: combination !!! Create nodes also for external particles, except for the incoming one which !!! appears as the root of the tree. These can easily be identified by their !!! bincodes, since they should contain only one bit which is set. if (leaves) then first_colon = minloc (dag%string%t%type, 1, dag%string%t%type == COLON_TK) do i = first_colon + 1, size (dag%string%t) if (dag%string%t(i)%type == NODE_TK) then if (popcnt(dag%string%t(i)%bincode) == 1) then call dag%add_node (dag%string%t(i:i), .true., i_node) call dag%string%t(i)%init_dag_object_token (DAG_NODE_TK, i_node) end if end if enddo call dag%string%update_char_len () else !!! Create a node or combination for every closed pair of parentheses !!! which do not contain any other parentheses or curly braces. !!! A node (not outgoing) contains a colon. This is not the case !!! for combinations, which we use as the criteria to distinguish !!! between both. allocate (new_string%t (size (dag%string%t))) i = 1 new_size = 0 do while (i <= size(dag%string%t)) if (dag%string%t(i)%type == OPEN_PAR_TK) then combination = .true. do j = i+1, size (dag%string%t) select case (dag%string%t(j)%type) case (CLOSED_PAR_TK) new_size = new_size + 1 if (combination) then call dag%add_combination (dag%string%t(i:j), i_node) call new_string%t(new_size)%init_dag_object_token (DAG_COMBINATION_TK, i_node) else call dag%add_node (dag%string%t(i:j), leaves, i_node) call new_string%t(new_size)%init_dag_object_token (DAG_NODE_TK, i_node) end if i = j + 1 exit case (OPEN_PAR_TK, OPEN_CURLY_TK, CLOSED_CURLY_TK) new_size = new_size + 1 new_string%t(new_size) = dag%string%t(i) i = i + 1 exit case (COLON_TK) combination = .false. end select enddo else new_size = new_size + 1 new_string%t(new_size) = dag%string%t(i) i = i + 1 end if enddo dag%string = new_string%t(:new_size) call dag%string%update_char_len () end if end subroutine dag_get_nodes_and_combinations @ %def dag_get_nodes_and_combinations @ Identify [[dag_options]], i.e. lists of rival nodes or combinations of nodes. These are identified by the surrounding curly braces. They should not contain any parentheses any more, because these correspond either to nodes or to combinations and should be identified before. <>= procedure :: get_options => dag_get_options <>= subroutine dag_get_options (dag) class (dag_t), intent (inout) :: dag type (dag_string_t) :: new_string integer :: i, j, k integer :: new_size integer :: i_options character (len=10) :: index_char integer :: index_start, index_end !!! Create a node or combination for every closed pair of parentheses !!! which do not contain any other parentheses or curly braces. !!! A node (not outgoing) contains a colon. This is not the case !!! for combinations, which we use as the criteria to distinguish !!! between both. allocate (new_string%t (size (dag%string%t))) i = 1 new_size = 0 do while (i <= size(dag%string%t)) if (dag%string%t(i)%type == OPEN_CURLY_TK) then do j = i+1, size (dag%string%t) select case (dag%string%t(j)%type) case (CLOSED_CURLY_TK) new_size = new_size + 1 call dag%add_options (dag%string%t(i:j), i_options) call new_string%t(new_size)%init_dag_object_token (DAG_OPTIONS_TK, i_options) i = j + 1 exit case (OPEN_PAR_TK, CLOSED_PAR_TK, OPEN_CURLY_TK) new_size = new_size + 1 new_string%t(new_size) = dag%string%t(i) i = i + 1 exit end select enddo else new_size = new_size + 1 new_string%t(new_size) = dag%string%t(i) i = i + 1 end if enddo dag%string = new_string%t(:new_size) call dag%string%update_char_len () end subroutine dag_get_options @ %def dag_get_options @ Add a [[dag_node]] to the list. The optional argument returns the index of the node. The node might already exist. In this case we only return the index. <>= procedure :: add_node => dag_add_node <>= integer, parameter :: DAG_STACK_SIZE = 1000 <>= subroutine dag_add_node (dag, string, leaf, i_node) class (dag_t), intent (inout) :: dag type (dag_token_t), dimension (:), intent (in) :: string logical, intent (in) :: leaf integer, intent (out), optional :: i_node type (dag_node_t), dimension (:), allocatable :: tmp_node integer :: string_len integer :: i string_len = sum (string%char_len) if (.not. allocated (dag%node)) then allocate (dag%node (DAG_STACK_SIZE)) else if (dag%n_nodes == size (dag%node)) then allocate (tmp_node (dag%n_nodes)) tmp_node = dag%node deallocate (dag%node) allocate (dag%node (dag%n_nodes+DAG_STACK_SIZE)) dag%node(:dag%n_nodes) = tmp_node deallocate (tmp_node) end if do i = 1, dag%n_nodes if (dag%node(i)%string_len == string_len) then if (size (dag%node(i)%string%t) == size (string)) then if (all(dag%node(i)%string%t == string)) then if (present (i_node)) i_node = i return end if end if end if enddo dag%n_nodes = dag%n_nodes + 1 dag%node(dag%n_nodes)%string = string dag%node(dag%n_nodes)%string_len = string_len if (present (i_node)) i_node = dag%n_nodes dag%node(dag%n_nodes)%leaf = leaf end subroutine dag_add_node @ %def dag_add_node @ A similar subroutine for options. <>= procedure :: add_options => dag_add_options <>= subroutine dag_add_options (dag, string, i_options) class (dag_t), intent (inout) :: dag type (dag_token_t), dimension (:), intent (in) :: string integer, intent (out), optional :: i_options type (dag_options_t), dimension (:), allocatable :: tmp_options integer :: string_len integer :: i string_len = sum (string%char_len) if (.not. allocated (dag%options)) then allocate (dag%options (DAG_STACK_SIZE)) else if (dag%n_options == size (dag%options)) then allocate (tmp_options (dag%n_options)) tmp_options = dag%options deallocate (dag%options) allocate (dag%options (dag%n_options+DAG_STACK_SIZE)) dag%options(:dag%n_options) = tmp_options deallocate (tmp_options) end if do i = 1, dag%n_options if (dag%options(i)%string_len == string_len) then if (size (dag%options(i)%string%t) == size (string)) then if (all(dag%options(i)%string%t == string)) then if (present (i_options)) i_options = i return end if end if end if enddo dag%n_options = dag%n_options + 1 dag%options(dag%n_options)%string = string dag%options(dag%n_options)%string_len = string_len if (present (i_options)) i_options = dag%n_options end subroutine dag_add_options @ %def dag_add_options @ A similar subroutine for combinations. <>= procedure :: add_combination => dag_add_combination <>= subroutine dag_add_combination (dag, string, i_combination) class (dag_t), intent (inout) :: dag type (dag_token_t), dimension (:), intent (in) :: string integer, intent (out), optional :: i_combination type (dag_combination_t), dimension (:), allocatable :: tmp_combination integer :: string_len integer :: i string_len = sum (string%char_len) if (.not. allocated (dag%combination)) then allocate (dag%combination (DAG_STACK_SIZE)) else if (dag%n_combinations == size (dag%combination)) then allocate (tmp_combination (dag%n_combinations)) tmp_combination = dag%combination deallocate (dag%combination) allocate (dag%combination (dag%n_combinations+DAG_STACK_SIZE)) dag%combination(:dag%n_combinations) = tmp_combination deallocate (tmp_combination) end if do i = 1, dag%n_combinations if (dag%combination(i)%string_len == string_len) then if (size (dag%combination(i)%string%t) == size (string)) then if (all(dag%combination(i)%string%t == string)) then i_combination = i return end if end if end if enddo dag%n_combinations = dag%n_combinations + 1 dag%combination(dag%n_combinations)%string = string dag%combination(dag%n_combinations)%string_len = string_len if (present (i_combination)) i_combination = dag%n_combinations end subroutine dag_add_combination @ %def dag_add_combination @ For a given [[dag_node]] we want to create all [[f_nodes]]. If the node is not a leaf, it contains in its string placeholders for options or combinations. For these objects there are similar subroutines which are needed here to obtain the sets of daughter nodes. If the [[dag_node]] is a leaf, it corresponds to an external particle and the token contains the particle name. <>= procedure :: make_f_nodes => dag_node_make_f_nodes <>= subroutine dag_node_make_f_nodes (dag_node, feyngraph_set, dag) class (dag_node_t), intent (inout) :: dag_node type (feyngraph_set_t), intent (inout) :: feyngraph_set type (dag_t), intent (inout) :: dag character (len=LABEL_LEN) :: particle_label integer :: i, j integer, dimension (2) :: obj integer, dimension (2) :: i_obj integer :: n_obj integer :: pos integer :: new_size, size1, size2 integer, dimension(:), allocatable :: match if (allocated (dag_node%f_node)) return pos = minloc (dag_node%string%t%type, 1,dag_node%string%t%type == NODE_TK) particle_label = char (dag_node%string%t(pos)) if (dag_node%leaf) then !!! construct subtree with procedure similar to the one for the old output allocate (dag_node%f_node(1)) allocate (dag_node%f_node(1)%node) dag_node%f_node(1)%node%particle_label = particle_label call dag_node%f_node(1)%node%assign_particle_properties (feyngraph_set) if (.not. dag_node%f_node(1)%node%keep) then deallocate (dag_node%f_node) return end if else n_obj = 0 do i = 1, size (dag_node%string%t) select case (dag_node%string%t(i)%type) case (DAG_NODE_TK, DAG_OPTIONS_TK, DAG_COMBINATION_TK) n_obj = n_obj + 1 if (n_obj > 2) return obj(n_obj) = dag_node%string%t(i)%type i_obj(n_obj) = dag_node%string%t(i)%index end select enddo if (n_obj == 1) then if (obj(1) == DAG_OPTIONS_TK) then if (allocated (dag%options(i_obj(1))%f_node_ptr1)) then size1 = size(dag%options(i_obj(1))%f_node_ptr1) allocate (dag_node%f_node(size1)) do i=1, size1 allocate (dag_node%f_node(i)%node) dag_node%f_node(i)%node%particle_label = particle_label call dag_node%f_node(i)%node%assign_particle_properties (feyngraph_set) dag_node%f_node(i)%node%daughter1 => dag%options(i_obj(1))%f_node_ptr1(i)%node dag_node%f_node(i)%node%daughter2 => dag%options(i_obj(1))%f_node_ptr2(i)%node dag_node%f_node(i)%node%n_subtree_nodes = & dag%options(i_obj(1))%f_node_ptr1(i)%node%n_subtree_nodes & + dag%options(i_obj(1))%f_node_ptr2(i)%node%n_subtree_nodes + 1 enddo end if else if (obj(1) == DAG_COMBINATION_TK) then if (allocated (dag%combination(i_obj(1))%f_node_ptr1)) then size1 = size(dag%combination(i_obj(1))%f_node_ptr1) allocate (dag_node%f_node(size1)) do i=1, size1 allocate (dag_node%f_node(i)%node) dag_node%f_node(i)%node%particle_label = particle_label call dag_node%f_node(i)%node%assign_particle_properties (feyngraph_set) dag_node%f_node(i)%node%daughter1 => dag%combination(i_obj(1))%f_node_ptr1(i)%node dag_node%f_node(i)%node%daughter2 => dag%combination(i_obj(1))%f_node_ptr2(i)%node dag_node%f_node(i)%node%n_subtree_nodes = & dag%combination(i_obj(1))%f_node_ptr1(i)%node%n_subtree_nodes & + dag%combination(i_obj(1))%f_node_ptr2(i)%node%n_subtree_nodes + 1 enddo end if end if !!! simply set daughter pointers, daughters are already combined correctly else if (n_obj == 2) then size1 = 0 size2 = 0 if (obj(1) == DAG_NODE_TK) then if (allocated (dag%node(i_obj(1))%f_node)) then do i=1, size (dag%node(i_obj(1))%f_node) if (dag%node(i_obj(1))%f_node(i)%node%keep) size1 = size1 + 1 enddo end if else if (obj(1) == DAG_OPTIONS_TK) then if (allocated (dag%options(i_obj(1))%f_node_ptr1)) then do i=1, size (dag%options(i_obj(1))%f_node_ptr1) if (dag%options(i_obj(1))%f_node_ptr1(i)%node%keep) size1 = size1 + 1 enddo end if end if if (obj(2) == DAG_NODE_TK) then if (allocated (dag%node(i_obj(2))%f_node)) then do i=1, size (dag%node(i_obj(2))%f_node) if (dag%node(i_obj(2))%f_node(i)%node%keep) size2 = size2 + 1 enddo end if else if (obj(2) == DAG_OPTIONS_TK) then if (allocated (dag%options(i_obj(2))%f_node_ptr1)) then do i=1, size (dag%options(i_obj(2))%f_node_ptr1) if (dag%options(i_obj(2))%f_node_ptr1(i)%node%keep) size2 = size2 + 1 enddo end if end if !!! make all combinations of daughters select case (obj(1)) case (DAG_NODE_TK) select case (obj(2)) case (DAG_NODE_TK) call combine_all_daughters(dag%node(i_obj(1))%f_node, & dag%node(i_obj(2))%f_node) case (DAG_OPTIONS_TK) call combine_all_daughters(dag%node(i_obj(1))%f_node, & dag%options(i_obj(2))%f_node_ptr1) end select case (DAG_OPTIONS_TK) select case (obj(2)) case (DAG_NODE_TK) call combine_all_daughters(dag%options(i_obj(1))%f_node_ptr1, & dag%node(i_obj(2))%f_node) case (DAG_OPTIONS_TK) call combine_all_daughters(dag%options(i_obj(1))%f_node_ptr1, & dag%options(i_obj(2))%f_node_ptr1) end select end select end if end if contains subroutine combine_all_daughters (daughter1_ptr, daughter2_ptr) type (f_node_ptr_t), dimension (:), intent (in) :: daughter1_ptr type (f_node_ptr_t), dimension (:), intent (in) :: daughter2_ptr integer :: i, j integer :: pos new_size = size1*size2 allocate (dag_node%f_node(new_size)) pos = 0 do i = 1, size (daughter1_ptr) if (daughter1_ptr(i)%node%keep) then do j = 1, size (daughter2_ptr) if (daughter2_ptr(j)%node%keep) then pos = pos + 1 allocate (dag_node%f_node(pos)%node) dag_node%f_node(pos)%node%particle_label = particle_label call dag_node%f_node(pos)%node%assign_particle_properties (feyngraph_set) dag_node%f_node(pos)%node%daughter1 => daughter1_ptr(i)%node dag_node%f_node(pos)%node%daughter2 => daughter2_ptr(j)%node dag_node%f_node(pos)%node%n_subtree_nodes = daughter1_ptr(i)%node%n_subtree_nodes & + daughter2_ptr(j)%node%n_subtree_nodes + 1 call feyngraph_set%model%match_vertex (daughter1_ptr(i)%node%particle%pdg, & daughter2_ptr(j)%node%particle%pdg, match) if (allocated (match)) then if (any (abs(match) == abs(dag_node%f_node(pos)%node%particle%pdg))) then dag_node%f_node(pos)%node%keep = .true. else dag_node%f_node(pos)%node%keep = .false. end if deallocate (match) else dag_node%f_node(pos)%node%keep = .false. end if end if enddo end if enddo end subroutine combine_all_daughters end subroutine dag_node_make_f_nodes @ %def dag_node_make_f_nodes @ In [[dag_options_make_f_nodes_single]] we obtain all [[f_nodes]] for [[dag_nodes]] which correspond to a set of rival subtrees or nodes, which is the first possibility for which [[dag_options]] can appear. In [[dag_options_make_f_nodes_pair]] the options are rival pairs ([[daughter1]], [[daughter2]]). Therefore we have to pass two allocatable arrays of type [[f_node_ptr_t]] to the subroutine. <>= procedure :: make_f_nodes => dag_options_make_f_nodes <>= subroutine dag_options_make_f_nodes (dag_options, & feyngraph_set, dag) class (dag_options_t), intent (inout) :: dag_options type (feyngraph_set_t), intent (inout) :: feyngraph_set type (dag_t), intent (inout) :: dag integer, dimension (:), allocatable :: obj, i_obj integer :: n_obj integer :: i integer :: pos !!! read options if (allocated (dag_options%f_node_ptr1)) return n_obj = count ((dag_options%string%t%type == DAG_NODE_TK) .or. & (dag_options%string%t%type == DAG_OPTIONS_TK) .or. & (dag_options%string%t%type == DAG_COMBINATION_TK), 1) allocate (obj(n_obj)); allocate (i_obj(n_obj)) pos = 0 do i = 1, size (dag_options%string%t) select case (dag_options%string%t(i)%type) case (DAG_NODE_TK, DAG_OPTIONS_TK, DAG_COMBINATION_TK) pos = pos + 1 obj(pos) = dag_options%string%t(i)%type i_obj(pos) = dag_options%string%t(i)%index end select enddo if (any (dag_options%string%t%type == DAG_NODE_TK)) then call dag_options_make_f_nodes_single else if (any (dag_options%string%t%type == DAG_COMBINATION_TK)) then call dag_options_make_f_nodes_pair end if deallocate (obj, i_obj) contains subroutine dag_options_make_f_nodes_single integer :: i_start, i_end integer :: n_nodes n_nodes = 0 do i=1, n_obj if (allocated (dag%node(i_obj(i))%f_node)) then n_nodes = n_nodes + size (dag%node(i_obj(i))%f_node) end if enddo if (n_nodes /= 0) then allocate (dag_options%f_node_ptr1 (n_nodes)) i_end = 0 do i = 1, n_obj if (allocated (dag%node(i_obj(i))%f_node)) then i_start = i_end + 1 i_end = i_end + size (dag%node(i_obj(i))%f_node) dag_options%f_node_ptr1(i_start:i_end) = dag%node(i_obj(i))%f_node end if enddo end if end subroutine dag_options_make_f_nodes_single subroutine dag_options_make_f_nodes_pair integer :: i_start, i_end integer :: n_nodes !!! get f_nodes from each combination n_nodes = 0 do i=1, n_obj if (allocated (dag%combination(i_obj(i))%f_node_ptr1)) then n_nodes = n_nodes + size (dag%combination(i_obj(i))%f_node_ptr1) end if enddo if (n_nodes /= 0) then allocate (dag_options%f_node_ptr1 (n_nodes)) allocate (dag_options%f_node_ptr2 (n_nodes)) i_end = 0 do i=1, n_obj if (allocated (dag%combination(i_obj(i))%f_node_ptr1)) then i_start = i_end + 1 i_end = i_end + size (dag%combination(i_obj(i))%f_node_ptr1) dag_options%f_node_ptr1(i_start:i_end) = dag%combination(i_obj(i))%f_node_ptr1 dag_options%f_node_ptr2(i_start:i_end) = dag%combination(i_obj(i))%f_node_ptr2 end if enddo end if end subroutine dag_options_make_f_nodes_pair end subroutine dag_options_make_f_nodes @ %def dag_options_make_f_nodes @ We create all combinations of daughter [[f_nodes]] for a combination. In the combination each daughter can be either a single [[dag_node]] or [[dag_options]] which are a set of single [[dag_nodes]]. Therefore, we first create all possible [[f_nodes]] for daughter1, then all possible [[f_nodes]] for daughter2. In the end we combine all [[daughter1]] nodes with all [[daughter2]] nodes. <>= procedure :: make_f_nodes => dag_combination_make_f_nodes <>= subroutine dag_combination_make_f_nodes (dag_combination, & feyngraph_set, dag) class (dag_combination_t), intent (inout) :: dag_combination type (feyngraph_set_t), intent (inout) :: feyngraph_set type (dag_t), intent (inout) :: dag integer, dimension (2) :: obj, i_obj integer :: n_obj integer :: new_size, size1, size2 integer :: i, j, pos if (allocated (dag_combination%f_node_ptr1)) return n_obj = 0 do i = 1, size (dag_combination%string%t) select case (dag_combination%string%t(i)%type) case (DAG_NODE_TK, DAG_OPTIONS_TK, DAG_COMBINATION_TK) n_obj = n_obj + 1 if (n_obj > 2) return obj(n_obj) = dag_combination%string%t(i)%type i_obj(n_obj) = dag_combination%string%t(i)%index end select enddo size1 = 0 size2 = 0 if (obj(1) == DAG_NODE_TK) then if (allocated (dag%node(i_obj(1))%f_node)) & size1 = size (dag%node(i_obj(1))%f_node) else if (obj(1) == DAG_OPTIONS_TK) then if (allocated (dag%options(i_obj(1))%f_node_ptr1)) & size1 = size (dag%options(i_obj(1))%f_node_ptr1) end if if (obj(2) == DAG_NODE_TK) then if (allocated (dag%node(i_obj(2))%f_node)) & size2 = size (dag%node(i_obj(2))%f_node) else if (obj(2) == DAG_OPTIONS_TK) then if (allocated (dag%options(i_obj(2))%f_node_ptr1)) & size2 = size (dag%options(i_obj(2))%f_node_ptr1) end if !!! combine the 2 arrays of f_nodes new_size = size1*size2 if (new_size /= 0) then allocate (dag_combination%f_node_ptr1 (new_size)) allocate (dag_combination%f_node_ptr2 (new_size)) pos = 0 select case (obj(1)) case (DAG_NODE_TK) select case (obj(2)) case (DAG_NODE_TK) do i = 1, size1 do j = 1, size2 pos = pos + 1 dag_combination%f_node_ptr1(pos) = dag%node(i_obj(1))%f_node(i) dag_combination%f_node_ptr2(pos) = dag%node(i_obj(2))%f_node(j) enddo enddo case (DAG_OPTIONS_TK) do i = 1, size1 do j = 1, size2 pos = pos + 1 dag_combination%f_node_ptr1(pos) = dag%node(i_obj(1))%f_node(i) dag_combination%f_node_ptr2(pos) = dag%options(i_obj(2))%f_node_ptr1(j) enddo enddo end select case (DAG_OPTIONS_TK) select case (obj(2)) case (DAG_NODE_TK) do i = 1, size1 do j = 1, size2 pos = pos + 1 dag_combination%f_node_ptr1(pos) = dag%options(i_obj(1))%f_node_ptr1(i) dag_combination%f_node_ptr2(pos) = dag%node(i_obj(2))%f_node(j) enddo enddo case (DAG_OPTIONS_TK) do i = 1, size1 do j = 1, size2 pos = pos + 1 dag_combination%f_node_ptr1(pos) = dag%options(i_obj(1))%f_node_ptr1(i) dag_combination%f_node_ptr2(pos) = dag%options(i_obj(2))%f_node_ptr1(j) enddo enddo end select end select end if end subroutine dag_combination_make_f_nodes @ %def dag_combination_make_f_nodes @ Here we create the [[feyngraphs]]. After the construction of the [[dag]] the remaining [[dag_string]] should contain a token for a single [[dag_node]] which corresponds to the roots of the [[feyngraphs]]. Therefore we make all [[f_nodes]] for this [[dag_node]] and create a [[feyngraph]] for each [[f_node]]. Note that only 3-vertices are accepted. All other vertices are rejected. The starting point is the last dag node which has been added to the list, since this corresponds to the root of the tree. Is is important to understand that the structure of feyngraphs is not the same as the structure of the dag which is read from file, because for the calculations which are performed in this module we want to reuse the nodes for the outgoing particles, which means that they appear only once. In O'Mega's output, it is the first incoming particle which appears only once and the outgoing particles appear many times. This transition is incorporated in the subroutines which create [[f_nodes]] from the different dag objects. <>= procedure :: make_feyngraphs => dag_make_feyngraphs <>= subroutine dag_make_feyngraphs (dag, feyngraph_set) class (dag_t), intent (inout) :: dag type (feyngraph_set_t), intent (inout) :: feyngraph_set integer :: i integer :: max_subtree_size max_subtree_size = dag%node(dag%n_nodes)%subtree_size if (allocated (dag%node(dag%n_nodes)%f_node)) then do i = 1, size (dag%node(dag%n_nodes)%f_node) if (.not. associated (feyngraph_set%first)) then allocate (feyngraph_set%last) feyngraph_set%first => feyngraph_set%last else allocate (feyngraph_set%last%next) feyngraph_set%last => feyngraph_set%last%next end if feyngraph_set%last%root => dag%node(dag%n_nodes)%f_node(i)%node !!! The first particle was correct in the O'Mega parsable DAG output. It was however !!! changed to its anti-particle in f_node_assign_particle_properties, which we revert here. feyngraph_set%last%root%particle => feyngraph_set%last%root%particle%anti feyngraph_set%last%n_nodes = feyngraph_set%last%root%n_subtree_nodes feyngraph_set%n_graphs = feyngraph_set%n_graphs + 1 enddo feyngraph_set%f_node_list%max_tree_size = feyngraph_set%first%n_nodes end if end subroutine dag_make_feyngraphs @ %def dag_make_feyngraphs @ A write procedure of the [[dag]] for debugging. <>= procedure :: write => dag_write <>= subroutine dag_write (dag, u) class (dag_t), intent (in) :: dag integer, intent(in) :: u integer :: i write (u,fmt='(A)') 'nodes' do i=1, dag%n_nodes write (u,fmt='(I5,3X,A)') i, char (dag%node(i)%string) enddo write (u,fmt='(A)') 'options' do i=1, dag%n_options write (u,fmt='(I5,3X,A)') i, char (dag%options(i)%string) enddo write (u,fmt='(A)') 'combination' do i=1, dag%n_combinations write (u,fmt='(I5,3X,A)') i, char (dag%combination(i)%string) enddo end subroutine dag_write @ %def dag_write @ Make a copy of a resonant [[k_node]], where the copy is kept nonresonant. <>= subroutine k_node_make_nonresonant_copy (k_node) type (k_node_t), intent (in) :: k_node type (k_node_t), pointer :: copy call k_node%f_node%k_node_list%add_entry (copy, recycle=.true.) copy%daughter1 => k_node%daughter1 copy%daughter2 => k_node%daughter2 copy = k_node copy%mapping = NONRESONANT copy%resonant = .false. copy%on_shell = .false. copy%mapping_assigned = .true. copy%is_nonresonant_copy = .true. end subroutine k_node_make_nonresonant_copy @ %def k_node_make_nonresonant_copy @ For a given [[feyngraph]] we create all possible [[kingraphs]]. Here we use existing [[k_nodes]] which have already been created when the mapping calculations of the pure s-channel subgraphs are performed. The nodes for the incoming particles or the nodes on the t-line will have to be created in all cases because they are not used in several graphs. To obtain the existing [[k_nodes]], we use the subroutine [[k_node_init_from_f_node]] which itself uses [[f_node_list_get_nodes]] to obtain all active [[k_nodes]] in the [[k_node_list]] of the [[f_node]]. The created [[kingraphs]] are attached to the linked list of the [[feyngraph]]. For scattering processes we have to split up the t-line, because since all graphs are represented as a decay, different nodes can share daughter nodes. This happens also for the t-line or the incoming particle which appears as an outgoing particle. For the [[t_line]] or [[incoming]] nodes we do not want to recycle nodes but rather create a copy of this line for each [[kingraph]]. <>= procedure :: make_kingraphs => feyngraph_make_kingraphs <>= subroutine feyngraph_make_kingraphs (feyngraph, feyngraph_set) class (feyngraph_t), intent (inout) :: feyngraph type (feyngraph_set_t), intent (in) :: feyngraph_set type (k_node_ptr_t), dimension (:), allocatable :: kingraph_root integer :: i if (.not. associated (feyngraph%kin_first)) then call k_node_init_from_f_node (feyngraph%root, & kingraph_root, feyngraph_set) if (.not. feyngraph%root%keep) return if (feyngraph_set%process_type == SCATTERING) then call split_up_t_lines (kingraph_root) end if do i=1, size (kingraph_root) if (associated (feyngraph%kin_last)) then allocate (feyngraph%kin_last%next) feyngraph%kin_last => feyngraph%kin_last%next else allocate (feyngraph%kin_last) feyngraph%kin_first => feyngraph%kin_last end if feyngraph%kin_last%root => kingraph_root(i)%node feyngraph%kin_last%n_nodes = feyngraph%n_nodes feyngraph%kin_last%keep = feyngraph%keep if (feyngraph_set%process_type == SCATTERING) then feyngraph%kin_last%root%bincode = & f_node_get_external_bincode (feyngraph_set, feyngraph%root) end if enddo deallocate (kingraph_root) end if end subroutine feyngraph_make_kingraphs @ %def feyngraph_make_kingraphs @ Create all [[k_nodes]] for a given [[f_node]]. We return these nodes using [[k_node_ptr]]. If the node is external, we assign also the bincode to the [[k_nodes]] because this is determined from substrings of the input file which belong to the [[feyngraphs]] and [[f_nodes]]. <>= recursive subroutine k_node_init_from_f_node (f_node, k_node_ptr, feyngraph_set) type (f_node_t), target, intent (inout) :: f_node type (k_node_ptr_t), allocatable, dimension (:), intent (out) :: k_node_ptr type (feyngraph_set_t), intent (in) :: feyngraph_set type (k_node_ptr_t), allocatable, dimension(:) :: daughter_ptr1, daughter_ptr2 integer :: n_nodes integer :: i, j integer :: pos integer, save :: counter = 0 if (.not. (f_node%incoming .or. f_node%t_line)) then call f_node%k_node_list%get_nodes (k_node_ptr) if (.not. allocated (k_node_ptr) .and. f_node%k_node_list%n_entries > 0) then f_node%keep = .false. return end if end if if (.not. allocated (k_node_ptr)) then if (associated (f_node%daughter1) .and. associated (f_node%daughter2)) then call k_node_init_from_f_node (f_node%daughter1, daughter_ptr1, & feyngraph_set) call k_node_init_from_f_node (f_node%daughter2, daughter_ptr2, & feyngraph_set) if (.not. (f_node%daughter1%keep .and. f_node%daughter2%keep)) then f_node%keep = .false. return end if n_nodes = size (daughter_ptr1) * size (daughter_ptr2) allocate (k_node_ptr (n_nodes)) pos = 1 do i=1, size (daughter_ptr1) do j=1, size (daughter_ptr2) if (f_node%incoming .or. f_node%t_line) then call f_node%k_node_list%add_entry (k_node_ptr(pos)%node, recycle = .false.) else call f_node%k_node_list%add_entry (k_node_ptr(pos)%node, recycle = .true.) end if k_node_ptr(pos)%node%f_node => f_node k_node_ptr(pos)%node%daughter1 => daughter_ptr1(i)%node k_node_ptr(pos)%node%daughter2 => daughter_ptr2(j)%node k_node_ptr(pos)%node%f_node_index = f_node%index k_node_ptr(pos)%node%incoming = f_node%incoming k_node_ptr(pos)%node%t_line = f_node%t_line k_node_ptr(pos)%node%particle => f_node%particle pos = pos + 1 enddo enddo deallocate (daughter_ptr1, daughter_ptr2) else allocate (k_node_ptr(1)) if (f_node%incoming .or. f_node%t_line) then call f_node%k_node_list%add_entry (k_node_ptr(1)%node, recycle=.false.) else call f_node%k_node_list%add_entry (k_node_ptr(1)%node, recycle=.true.) end if k_node_ptr(1)%node%f_node => f_node k_node_ptr(1)%node%f_node_index = f_node%index k_node_ptr(1)%node%incoming = f_node%incoming k_node_ptr(1)%node%t_line = f_node%t_line k_node_ptr(1)%node%particle => f_node%particle k_node_ptr(1)%node%bincode = f_node_get_external_bincode (feyngraph_set, & f_node) end if end if end subroutine k_node_init_from_f_node @ %def k_node_init_from_f_node @ The graphs resulting from [[k_node_init_from_f_node]] are fine if they are used only in one direction. This is however not the case when one wants to invert the graphs, i.e. take the other incoming particle of a scattering process as the decaying particle, because the outgoing [[f_nodes]] (and hence also the [[k_nodes]]) exist only once. This problem is solved here by creating a distinct t-line for each of the graphs. The following subroutine disentangles the data structure by creating new nodes such that the different t-lines are not connected any more. <>= recursive subroutine split_up_t_lines (t_node) type (k_node_ptr_t), dimension(:), intent (inout) :: t_node type (k_node_t), pointer :: ref_node => null () type (k_node_t), pointer :: ref_daughter => null () type (k_node_t), pointer :: new_daughter => null () type (k_node_ptr_t), dimension(:), allocatable :: t_daughter integer :: ref_daughter_index integer :: i, j allocate (t_daughter (size (t_node))) do i=1, size (t_node) ref_node => t_node(i)%node if (associated (ref_node%daughter1) .and. associated (ref_node%daughter2)) then ref_daughter => null () if (ref_node%daughter1%incoming .or. ref_node%daughter1%t_line) then ref_daughter => ref_node%daughter1 ref_daughter_index = 1 else if (ref_node%daughter2%incoming .or. ref_node%daughter2%t_line) then ref_daughter => ref_node%daughter2 ref_daughter_index = 2 end if do j=1, size (t_daughter) if (.not. associated (t_daughter(j)%node)) then t_daughter(j)%node => ref_daughter exit else if (t_daughter(j)%node%index == ref_daughter%index) then new_daughter => null () call ref_daughter%f_node%k_node_list%add_entry (new_daughter, recycle=.false.) new_daughter = ref_daughter new_daughter%daughter1 => ref_daughter%daughter1 new_daughter%daughter2 => ref_daughter%daughter2 if (ref_daughter_index == 1) then ref_node%daughter1 => new_daughter else if (ref_daughter_index == 2) then ref_node%daughter2 => new_daughter end if ref_daughter => new_daughter end if enddo else return end if enddo call split_up_t_lines (t_daughter) deallocate (t_daughter) end subroutine split_up_t_lines @ %def split_up_t_lines @ This subroutine sets the [[inverse_daughters]] of a [[k_node]]. If we invert a [[kingraph]] such that not the first but the second incoming particle appears as the root of the tree, the [[incoming]] and [[t_line]] particles obtain other daughters. These are the former mother node and the sister node [[s_daughter]]. Here we set only the pointers for the [[inverse_daughters]]. The inversion happens in [[kingraph_make_inverse_copy]] and [[node_inverse_deep_copy]]. <>= subroutine kingraph_set_inverse_daughters (kingraph) type (kingraph_t), intent (inout) :: kingraph type (k_node_t), pointer :: mother type (k_node_t), pointer :: t_daughter type (k_node_t), pointer :: s_daughter mother => kingraph%root do while (associated (mother)) if (associated (mother%daughter1) .and. & associated (mother%daughter2)) then if (mother%daughter1%t_line .or. mother%daughter1%incoming) then t_daughter => mother%daughter1; s_daughter => mother%daughter2 else if (mother%daughter2%t_line .or. mother%daughter2%incoming) then t_daughter => mother%daughter2; s_daughter => mother%daughter1 else exit end if t_daughter%inverse_daughter1 => mother t_daughter%inverse_daughter2 => s_daughter mother => t_daughter else exit end if enddo end subroutine kingraph_set_inverse_daughters @ %def kingraph_set_inverse_daughters @ Set the bincode of an [[f_node]] which corresponds to an external particle. This is done on the basis of the [[particle_label]] which is a substring of the input file. Here it is not the particle name which is important, but the number(s) in brackets which in general indicate the external particles which are connected to the current node. This function is however only used for external particles, so there can either be one or [[n_out + 1]] particles in the brackets (in the DAG input file always one, because also for the root there is only a single number). In all cases we check the number of particles (in the DAG input the numbers are separated by a slash). <>= function f_node_get_external_bincode (feyngraph_set, f_node) result (bincode) type (feyngraph_set_t), intent (in) :: feyngraph_set type (f_node_t), intent (in) :: f_node integer (TC) :: bincode character (len=LABEL_LEN) :: particle_label integer :: start_pos, end_pos, n_out_decay integer :: n_prt ! for DAG integer :: i bincode = 0 if (feyngraph_set%process_type == DECAY) then n_out_decay = feyngraph_set%n_out else n_out_decay = feyngraph_set%n_out + 1 end if particle_label = f_node%particle_label start_pos = index (particle_label, '[') + 1 end_pos = index (particle_label, ']') - 1 particle_label = particle_label(start_pos:end_pos) !!! n_out_decay is the number of outgoing particles in the !!! O'Mega output, which is always represented as a decay if (feyngraph_set%use_dag) then n_prt = 1 do i=1, len(particle_label) if (particle_label(i:i) == '/') n_prt = n_prt + 1 enddo else n_prt = end_pos - start_pos + 1 end if if (n_prt == 1) then bincode = calculate_external_bincode (particle_label, & feyngraph_set%process_type, n_out_decay) else if (n_prt == n_out_decay) then bincode = ibset (0, n_out_decay) end if end function f_node_get_external_bincode @ %def f_node_get_external_bincode @ Assign a bincode to an internal node, which is calculated from the bincodes of [[daughter1]] and [[daughter2]]. <>= subroutine node_assign_bincode (node) type (k_node_t), intent (inout) :: node if (associated (node%daughter1) .and. associated (node%daughter2) & .and. .not. node%incoming) then node%bincode = ior(node%daughter1%bincode, node%daughter2%bincode) end if end subroutine node_assign_bincode @ %def node_assign_bincode @ Calculate the [[bincode]] from the number in the brackets of the [[particle_label]], if the node is external. For the root in the non-factorized output, this is calculated directly in [[f_node_get_external_bincode]] because in this case all the other external particle numbers appear between the brackets. <>= function calculate_external_bincode (label_number_string, process_type, n_out_decay) result (bincode) character (len=*), intent (in) :: label_number_string integer, intent (in) :: process_type integer, intent (in) :: n_out_decay character :: number_char integer :: number_int integer (kind=TC) :: bincode bincode = 0 read (label_number_string, fmt='(A)') number_char !!! check if the character is a letter (A,B,C,...) or a number (1...9) !!! numbers 1 and 2 are special cases select case (number_char) case ('1') if (process_type == SCATTERING) then number_int = n_out_decay + 3 else number_int = n_out_decay + 2 end if case ('2') if (process_type == SCATTERING) then number_int = n_out_decay + 2 else number_int = 2 end if case ('A') number_int = 10 case ('B') number_int = 11 case ('C') number_int = 12 case ('D') number_int = 13 case default read (number_char, fmt='(I1)') number_int end select bincode = ibset (bincode, number_int - process_type - 1) end function calculate_external_bincode @ %def calculate_external_bincode @ \subsection{Mapping calculations} Once a [[k_node]] and its subtree nodes have been created, we can perform the kinematical calculations and assign mappings, depending on the particle properties and the results for the subtree nodes. This could in principle be done recursively, calling the procedure first for the daughter nodes and then perform the calculations for the actual node. But for parallization and comparing the nodes, this will be done simultaneously for all nodes with the same number of subtree nodes, and the number of subtree nodes increases, starting from one, in steps of two. The actual mapping calculations are done in complete analogy to cascades. <>= subroutine node_assign_mapping_s (feyngraph, node, feyngraph_set) type (feyngraph_t), intent (inout) :: feyngraph type (k_node_t), intent (inout) :: node type (feyngraph_set_t), intent (inout) :: feyngraph_set real(default) :: eff_mass_sum logical :: keep if (.not. node%mapping_assigned) then if (node%particle%mass > feyngraph_set%phs_par%m_threshold_s) then node%effective_mass = node%particle%mass end if if (associated (node%daughter1) .and. associated (node%daughter2)) then if (.not. (node%daughter1%keep .and. node%daughter2%keep)) then node%keep = .false.; return end if node%ext_mass_sum = node%daughter1%ext_mass_sum & + node%daughter2%ext_mass_sum keep = .false. !!! Potentially resonant cases [sqrts = m_rea for on-shell decay] if (node%particle%mass > node%ext_mass_sum & .and. node%particle%mass <= feyngraph_set%phs_par%sqrts) then if (node%particle%width /= 0) then if (node%daughter1%on_shell .or. node%daughter2%on_shell) then keep = .true. node%mapping = S_CHANNEL node%resonant = .true. end if else call warn_decay (node%particle) end if !!! Collinear and IR singular cases else if (node%particle%mass < feyngraph_set%phs_par%sqrts) then !!! Massless splitting if (node%daughter1%effective_mass == 0 & .and. node%daughter2%effective_mass == 0 & .and. .not. associated (node%daughter1%daughter1) & .and. .not. associated (node%daughter1%daughter2) & .and. .not. associated (node%daughter2%daughter1) & .and. .not. associated (node%daughter2%daughter2)) then keep = .true. node%log_enhanced = .true. if (node%particle%is_vector) then if (node%daughter1%particle%is_vector & .and. node%daughter2%particle%is_vector) then node%mapping = COLLINEAR !!! three-vector-splitting else node%mapping = INFRARED !!! vector spliiting into matter end if else if (node%daughter1%particle%is_vector & .or. node%daughter2%particle%is_vector) then node%mapping = COLLINEAR !!! vector radiation off matter else node%mapping = INFRARED !!! scalar radiation/splitting end if end if !!! IR radiation off massive particle [cascades] else if (node%effective_mass > 0 .and. & node%daughter1%effective_mass > 0 .and. & node%daughter2%effective_mass == 0 .and. & (node%daughter1%on_shell .or. & node%daughter1%mapping == RADIATION) .and. & abs (node%effective_mass - & node%daughter1%effective_mass) < feyngraph_set%phs_par%m_threshold_s) & then keep = .true. node%log_enhanced = .true. node%mapping = RADIATION else if (node%effective_mass > 0 .and. & node%daughter2%effective_mass > 0 .and. & node%daughter1%effective_mass == 0 .and. & (node%daughter2%on_shell .or. & node%daughter2%mapping == RADIATION) .and. & abs (node%effective_mass - & node%daughter2%effective_mass) < feyngraph_set%phs_par%m_threshold_s) & then keep = .true. node%log_enhanced = .true. node%mapping = RADIATION end if end if !!! Non-singular cases, including failed resonances [from cascades] if (.not. keep) then !!! Two on-shell particles from a virtual mother [from cascades, here eventually more than 2] if (node%daughter1%on_shell .or. node%daughter2%on_shell) then keep = .true. eff_mass_sum = node%daughter1%effective_mass & + node%daughter2%effective_mass node%effective_mass = max (node%ext_mass_sum, eff_mass_sum) if (node%effective_mass < feyngraph_set%phs_par%m_threshold_s) then node%effective_mass = 0 end if end if end if !!! Complete and register feyngraph (make copy in case of resonance) if (keep) then node%on_shell = node%resonant .or. node%log_enhanced if (node%resonant) then if (feyngraph_set%phs_par%keep_nonresonant) then call k_node_make_nonresonant_copy (node) end if node%ext_mass_sum = node%particle%mass end if end if node%mapping_assigned = .true. call node_assign_bincode (node) call node%subtree%add_entry (node) else !!! external (outgoing) particle node%ext_mass_sum = node%particle%mass node%mapping = EXTERNAL_PRT node%multiplicity = 1 node%mapping_assigned = .true. call node%subtree%add_entry (node) node%on_shell = .true. if (node%particle%mass >= feyngraph_set%phs_par%m_threshold_s) then node%effective_mass = node%particle%mass end if end if else if (node%is_nonresonant_copy) then call node_assign_bincode (node) call node%subtree%add_entry (node) node%is_nonresonant_copy = .false. end if call node_count_specific_properties (node) if (node%n_off_shell > feyngraph_set%phs_par%off_shell) then node%keep = .false. end if contains subroutine warn_decay (particle) type(part_prop_t), intent(in) :: particle integer :: i integer, dimension(MAX_WARN_RESONANCE), save :: warned_code = 0 LOOP_WARNED: do i = 1, MAX_WARN_RESONANCE if (warned_code(i) == 0) then warned_code(i) = particle%pdg write (msg_buffer, "(A)") & & " Intermediate decay of zero-width particle " & & // trim(particle%particle_label) & & // " may be possible." call msg_warning exit LOOP_WARNED else if (warned_code(i) == particle%pdg) then exit LOOP_WARNED end if end do LOOP_WARNED end subroutine warn_decay end subroutine node_assign_mapping_s @ %def node_assign_mapping_s @ We determine the numbers [[n_resonances]], [[multiplicity]], [[n_off_shell]] and [[n_log_enhanced]] for a given node. <>= subroutine node_count_specific_properties (node) type (k_node_t), intent (inout) :: node if (associated (node%daughter1) .and. associated(node%daughter2)) then if (node%resonant) then node%multiplicity = 1 node%n_resonances & = node%daughter1%n_resonances & + node%daughter2%n_resonances + 1 else node%multiplicity & = node%daughter1%multiplicity & + node%daughter2%multiplicity node%n_resonances & = node%daughter1%n_resonances & + node%daughter2%n_resonances end if if (node%log_enhanced) then node%n_log_enhanced & = node%daughter1%n_log_enhanced & + node%daughter2%n_log_enhanced + 1 else node%n_log_enhanced & = node%daughter1%n_log_enhanced & + node%daughter2%n_log_enhanced end if if (node%resonant) then node%n_off_shell = 0 else if (node%log_enhanced) then node%n_off_shell & = node%daughter1%n_off_shell & + node%daughter2%n_off_shell else node%n_off_shell & = node%daughter1%n_off_shell & + node%daughter2%n_off_shell + 1 end if if (node%t_line) then if (node%daughter1%t_line .or. node%daughter1%incoming) then node%n_t_channel = node%daughter1%n_t_channel + 1 else if (node%daughter2%t_line .or. node%daughter2%incoming) then node%n_t_channel = node%daughter2%n_t_channel + 1 end if end if end if end subroutine node_count_specific_properties @ %def node_count_specific_properties @ The subroutine [[kingraph_assign_mappings_s]] completes kinematical calculations for a decay process, considering the [[root]] node. <>= subroutine kingraph_assign_mappings_s (feyngraph, kingraph, feyngraph_set) type (feyngraph_t), intent (inout) :: feyngraph type (kingraph_t), pointer, intent (inout) :: kingraph type (feyngraph_set_t), intent (inout) :: feyngraph_set if (.not. (kingraph%root%daughter1%keep .and. kingraph%root%daughter2%keep)) then kingraph%keep = .false. call kingraph%tree%final () end if if (kingraph%keep) then kingraph%root%on_shell = .true. kingraph%root%mapping = EXTERNAL_PRT kingraph%root%mapping_assigned = .true. call node_assign_bincode (kingraph%root) kingraph%root%ext_mass_sum = & kingraph%root%daughter1%ext_mass_sum + & kingraph%root%daughter2%ext_mass_sum if (kingraph%root%ext_mass_sum >= feyngraph_set%phs_par%sqrts) then kingraph%root%keep = .false. kingraph%keep = .false.; call kingraph%tree%final (); return end if call kingraph%root%subtree%add_entry (kingraph%root) kingraph%root%multiplicity & = kingraph%root%daughter1%multiplicity & + kingraph%root%daughter2%multiplicity kingraph%root%n_resonances & = kingraph%root%daughter1%n_resonances & + kingraph%root%daughter2%n_resonances kingraph%root%n_off_shell & = kingraph%root%daughter1%n_off_shell & + kingraph%root%daughter2%n_off_shell kingraph%root%n_log_enhanced & = kingraph%root%daughter1%n_log_enhanced & + kingraph%root%daughter2%n_log_enhanced if (kingraph%root%n_off_shell > feyngraph_set%phs_par%off_shell) then kingraph%root%keep = .false. kingraph%keep = .false.; call kingraph%tree%final (); return else kingraph%grove_prop%multiplicity = & kingraph%root%multiplicity kingraph%grove_prop%n_resonances = & kingraph%root%n_resonances kingraph%grove_prop%n_off_shell = & kingraph%root%n_off_shell kingraph%grove_prop%n_log_enhanced = & kingraph%root%n_log_enhanced end if kingraph%tree = kingraph%root%subtree end if end subroutine kingraph_assign_mappings_s @ %def kingraph_assign_mappings_s @ Compute mappings for the [[t_line]] and [[incoming]] nodes. This is done recursively using [[node_compute_t_line]]. <>= subroutine kingraph_compute_mappings_t_line (feyngraph, kingraph, feyngraph_set) type (feyngraph_t), intent (inout) :: feyngraph type (kingraph_t), pointer, intent (inout) :: kingraph type (feyngraph_set_t), intent (inout) :: feyngraph_set call node_compute_t_line (feyngraph, kingraph, kingraph%root, feyngraph_set) if (.not. kingraph%root%keep) then kingraph%keep = .false. call kingraph%tree%final () end if if (kingraph%keep) kingraph%tree = kingraph%root%subtree end subroutine kingraph_compute_mappings_t_line @ %def kingraph_compute_mappings_t_line @ Perform the kinematical calculations and mapping assignment for a node which is either [[incoming]] or [[t_line]]. This is done recursively, going first to the daughter node which has this property. Therefore we first set the pointer [[t_node]] to this daughter node and [[s_node]] to the other one. The mapping determination happens again in the same way as in [[cascades]]. <>= recursive subroutine node_compute_t_line (feyngraph, kingraph, node, feyngraph_set) type (feyngraph_t), intent (inout) :: feyngraph type (kingraph_t), intent (inout) :: kingraph type (k_node_t), intent (inout) :: node type (feyngraph_set_t), intent (inout) :: feyngraph_set type (k_node_t), pointer :: s_node type (k_node_t), pointer :: t_node type (k_node_t), pointer :: new_s_node if (.not. (node%daughter1%keep .and. node%daughter2%keep)) then node%keep = .false. return end if s_node => null () t_node => null () new_s_node => null () if (associated (node%daughter1) .and. associated (node%daughter2)) then if (node%daughter1%t_line .or. node%daughter1%incoming) then t_node => node%daughter1; s_node => node%daughter2 else if (node%daughter2%t_line .or. node%daughter2%incoming) then t_node => node%daughter2; s_node => node%daughter1 end if if (t_node%t_line) then call node_compute_t_line (feyngraph, kingraph, t_node, feyngraph_set) if (.not. t_node%keep) then node%keep = .false. return end if else if (t_node%incoming) then t_node%mapping = EXTERNAL_PRT t_node%on_shell = .true. t_node%ext_mass_sum = t_node%particle%mass if (t_node%particle%mass >= feyngraph_set%phs_par%m_threshold_t) then t_node%effective_mass = t_node%particle%mass end if call t_node%subtree%add_entry (t_node) end if !!! root: if (.not. node%incoming) then if (t_node%incoming) then node%ext_mass_sum = s_node%ext_mass_sum else node%ext_mass_sum & = node%daughter1%ext_mass_sum & + node%daughter2%ext_mass_sum end if if (node%particle%mass > feyngraph_set%phs_par%m_threshold_t) then node%effective_mass = max (node%particle%mass, & s_node%effective_mass) else if (s_node%effective_mass > feyngraph_set%phs_par%m_threshold_t) then node%effective_mass = s_node%effective_mass else node%effective_mass = 0 end if !!! Allowed decay of beam particle if (t_node%incoming & .and. t_node%particle%mass > s_node%particle%mass & + node%particle%mass) then call beam_decay (feyngraph_set%fatal_beam_decay) !!! Massless splitting else if (t_node%effective_mass == 0 & .and. s_node%effective_mass < feyngraph_set%phs_par%m_threshold_t & .and. node%effective_mass == 0) then node%mapping = U_CHANNEL node%log_enhanced = .true. !!! IR radiation off massive particle else if (t_node%effective_mass /= 0 & .and. s_node%effective_mass == 0 & .and. node%effective_mass /= 0 & .and. (t_node%on_shell & .or. t_node%mapping == RADIATION) & .and. abs (t_node%effective_mass - node%effective_mass) & < feyngraph_set%phs_par%m_threshold_t) then node%log_enhanced = .true. node%mapping = RADIATION end if node%mapping_assigned = .true. call node_assign_bincode (node) call node%subtree%add_entry (node) call node_count_specific_properties (node) if (node%n_off_shell > feyngraph_set%phs_par%off_shell) then node%keep = .false. kingraph%keep = .false.; call kingraph%tree%final (); return else if (node%n_t_channel > feyngraph_set%phs_par%t_channel) then node%keep = .false.; kingraph%keep = .false.; call kingraph%tree%final (); return end if else node%mapping = EXTERNAL_PRT node%on_shell = .true. node%ext_mass_sum & = t_node%ext_mass_sum & + s_node%ext_mass_sum node%effective_mass = node%particle%mass if (.not. (node%ext_mass_sum < feyngraph_set%phs_par%sqrts)) then node%keep = .false. kingraph%keep = .false.; call kingraph%tree%final (); return end if if (kingraph%keep) then if (t_node%incoming .and. s_node%log_enhanced) then call s_node%f_node%k_node_list%add_entry (new_s_node, recycle=.false.) new_s_node = s_node new_s_node%daughter1 => s_node%daughter1 new_s_node%daughter2 => s_node%daughter2 if (s_node%index == node%daughter1%index) then node%daughter1 => new_s_node else if (s_node%index == node%daughter2%index) then node%daughter2 => new_s_node end if new_s_node%subtree = s_node%subtree new_s_node%mapping = NO_MAPPING new_s_node%log_enhanced = .false. new_s_node%n_log_enhanced & = new_s_node%n_log_enhanced - 1 new_s_node%log_enhanced = .false. where (new_s_node%subtree%bc == new_s_node%bincode) new_s_node%subtree%mapping = NO_MAPPING endwhere else if ((t_node%t_line .or. t_node%incoming) .and. & t_node%mapping == U_CHANNEL) then t_node%mapping = T_CHANNEL where (t_node%subtree%bc == t_node%bincode) t_node%subtree%mapping = T_CHANNEL endwhere else if (t_node%incoming .and. & .not. associated (s_node%daughter1) .and. & .not. associated (s_node%daughter2)) then call s_node%f_node%k_node_list%add_entry (new_s_node, recycle=.false.) new_s_node = s_node new_s_node%mapping = ON_SHELL new_s_node%daughter1 => s_node%daughter1 new_s_node%daughter2 => s_node%daughter2 new_s_node%subtree = s_node%subtree if (s_node%index == node%daughter1%index) then node%daughter1 => new_s_node else if (s_node%index == node%daughter2%index) then node%daughter2 => new_s_node end if where (new_s_node%subtree%bc == new_s_node%bincode) new_s_node%subtree%mapping = ON_SHELL endwhere end if end if call node%subtree%add_entry (node) node%multiplicity & = node%daughter1%multiplicity & + node%daughter2%multiplicity node%n_resonances & = node%daughter1%n_resonances & + node%daughter2%n_resonances node%n_off_shell & = node%daughter1%n_off_shell & + node%daughter2%n_off_shell node%n_log_enhanced & = node%daughter1%n_log_enhanced & + node%daughter2%n_log_enhanced node%n_t_channel & = node%daughter1%n_t_channel & + node%daughter2%n_t_channel if (node%n_off_shell > feyngraph_set%phs_par%off_shell) then node%keep = .false. kingraph%keep = .false.; call kingraph%tree%final (); return else if (node%n_t_channel > feyngraph_set%phs_par%t_channel) then node%keep = .false. kingraph%keep = .false.; call kingraph%tree%final (); return else kingraph%grove_prop%multiplicity = node%multiplicity kingraph%grove_prop%n_resonances = node%n_resonances kingraph%grove_prop%n_off_shell = node%n_off_shell kingraph%grove_prop%n_log_enhanced = node%n_log_enhanced kingraph%grove_prop%n_t_channel = node%n_t_channel end if end if end if contains subroutine beam_decay (fatal_beam_decay) logical, intent(in) :: fatal_beam_decay write (msg_buffer, "(1x,A,1x,'->',1x,A,1x,A)") & t_node%particle%particle_label, & node%particle%particle_label, & s_node%particle%particle_label call msg_message write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") & t_node%particle%particle_label, t_node%particle%mass call msg_message write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") & node%particle%particle_label, node%particle%mass call msg_message write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") & s_node%particle%particle_label, s_node%particle%mass call msg_message if (fatal_beam_decay) then call msg_fatal (" Phase space: Initial beam particle can decay") else call msg_warning (" Phase space: Initial beam particle can decay") end if end subroutine beam_decay end subroutine node_compute_t_line @ %def node_compute_t_line @ After all pure s-channel subdiagrams have already been created from the corresponding [[f_nodes]] and mappings have been determined for their nodes, we complete the calculations here. In a first step, the [[kingraphs]] have to be created on the basis of the existing [[k_nodes]], which means in particular that a [[feyngraph]] can give rise to several [[kingraphs]] which will all be attached to the linked list of the [[feyngraph]]. The calculations which remain are of different kinds for decay and scattering processes. In a decay process the kinematical calculations have to be done for the [[root]] node. In a scattering process, after the creation of [[kingraphs]] in the first step, there will be only [[kingraphs]] with the first incoming particle as the [[root]] of the tree. For these graphs the [[inverse]] variable has the value [[.false.]]. Before performing any calculations on these graphs we make a so-called inverse copy of the graph (see below), which will also be attached to the linked list. Since the s-channel subgraph calculations have already been completed, only the t-line computations remain. <>= procedure :: make_inverse_kingraphs => feyngraph_make_inverse_kingraphs <>= subroutine feyngraph_make_inverse_kingraphs (feyngraph) class (feyngraph_t), intent (inout) :: feyngraph type (kingraph_t), pointer :: current current => feyngraph%kin_first do while (associated (current)) if (current%inverse) exit call current%make_inverse_copy (feyngraph) current => current%next enddo end subroutine feyngraph_make_inverse_kingraphs @ %def feyngraph_make_inverse_kingraphs <>= procedure :: compute_mappings => feyngraph_compute_mappings <>= subroutine feyngraph_compute_mappings (feyngraph, feyngraph_set) class (feyngraph_t), intent (inout) :: feyngraph type (feyngraph_set_t), intent (inout) :: feyngraph_set type (kingraph_t), pointer :: current current => feyngraph%kin_first do while (associated (current)) if (feyngraph_set%process_type == DECAY) then call kingraph_assign_mappings_s (feyngraph, current, feyngraph_set) else if (feyngraph_set%process_type == SCATTERING) then call kingraph_compute_mappings_t_line (feyngraph, current, feyngraph_set) end if current => current%next enddo end subroutine feyngraph_compute_mappings @ %def feyngraph_compute_mappings @ Here we control the mapping calculations for the nodes of s-channel subgraphs. We start with the nodes with the smallest number of subtree nodes and always increase this number by two because nodes have exactly zero or two daughter nodes. We create the [[k_nodes]] using the [[k_node_list]] of each [[f_node]]. The number of nodes which have to be created depends of the number of existing daughter nodes, which means that we have to create a node for each combination of existing and valid (the ones which we [[keep]]) daughter nodes. If the node corresponds to an external particle, we create only one node, since there are no daughter nodes. If the particle is not external and the daughter [[f_nodes]] do not contain any valid [[k_nodes]], we do not create a new [[k_nodes]] either. When the calculations for all nodes with the same number of subtree nodes have been completed, we compare the valid nodes to eliminate equivalences (see below). <>= subroutine f_node_list_compute_mappings_s (feyngraph_set) type (feyngraph_set_t), intent (inout) :: feyngraph_set type (f_node_ptr_t), dimension(:), allocatable :: set type (k_node_ptr_t), dimension(:), allocatable :: k_set type (k_node_entry_t), pointer :: k_entry type (f_node_entry_t), pointer :: current type (k_node_list_t), allocatable :: compare_list integer :: n_entries integer :: pos integer :: i, j, k do i = 1, feyngraph_set%f_node_list%max_tree_size - 2, 2 !!! Counter number of f_nodes with subtree size i for s channel calculations n_entries = 0 if (feyngraph_set%use_dag) then do j=1, feyngraph_set%dag%n_nodes if (allocated (feyngraph_set%dag%node(j)%f_node)) then do k=1, size(feyngraph_set%dag%node(j)%f_node) if (associated (feyngraph_set%dag%node(j)%f_node(k)%node)) then if (.not. (feyngraph_set%dag%node(j)%f_node(k)%node%incoming & .or. feyngraph_set%dag%node(j)%f_node(k)%node%t_line) & .and. feyngraph_set%dag%node(j)%f_node(k)%node%n_subtree_nodes == i) then n_entries = n_entries + 1 end if end if enddo end if enddo else current => feyngraph_set%f_node_list%first do while (associated (current)) if (.not. (current%node%incoming .or. current%node%t_line) & .and. current%node%n_subtree_nodes == i) then n_entries = n_entries + 1 end if current => current%next enddo end if if (n_entries == 0) exit !!! Create a temporary k node list for comparison allocate (set(n_entries)) pos = 0 if (feyngraph_set%use_dag) then do j=1, feyngraph_set%dag%n_nodes if (allocated (feyngraph_set%dag%node(j)%f_node)) then do k=1, size(feyngraph_set%dag%node(j)%f_node) if (associated (feyngraph_set%dag%node(j)%f_node(k)%node)) then if (.not. (feyngraph_set%dag%node(j)%f_node(k)%node%incoming & .or. feyngraph_set%dag%node(j)%f_node(k)%node%t_line) & .and. feyngraph_set%dag%node(j)%f_node(k)%node%n_subtree_nodes == i) then pos = pos + 1 set(pos)%node => feyngraph_set%dag%node(j)%f_node(k)%node end if end if enddo end if enddo else current => feyngraph_set%f_node_list%first do while (associated (current)) if (.not. (current%node%incoming .or. current%node%t_line) & .and. current%node%n_subtree_nodes == i) then pos = pos + 1 set(pos)%node => current%node end if current => current%next enddo end if allocate (compare_list) compare_list%observer = .true. do j = 1, n_entries call k_node_init_from_f_node (set(j)%node, k_set, & feyngraph_set) if (allocated (k_set)) deallocate (k_set) enddo !$OMP PARALLEL DO PRIVATE (k_entry) do j = 1, n_entries k_entry => set(j)%node%k_node_list%first do while (associated (k_entry)) call node_assign_mapping_s(feyngraph_set%first, k_entry%node, feyngraph_set) k_entry => k_entry%next enddo enddo !$OMP END PARALLEL DO do j = 1, size (set) k_entry => set(j)%node%k_node_list%first do while (associated (k_entry)) if (k_entry%node%keep) then if (k_entry%node%mapping == NO_MAPPING .or. k_entry%node%mapping == NONRESONANT) then call compare_list%add_pointer (k_entry%node) end if end if k_entry => k_entry%next enddo enddo deallocate (set) call compare_list%check_subtree_equivalences(feyngraph_set%model) call compare_list%final deallocate (compare_list) enddo end subroutine f_node_list_compute_mappings_s @ %def f_node_list_compute_mappings_s @ \subsection{Fill the grove list} Find the [[grove]] within the [[grove_list]] for a [[kingraph]] for which the kinematical calculations and mapping assignments have been completed. The [[groves]] are defined by the [[grove_prop]] entries and the value of the resonance hash ([[res_hash]]). Whenever a matching grove does not exist, we create one. In a first step we consider only part of the grove properties (see [[grove_prop_match]]) and the resonance hash is ignored, which leads to a preliminary grove list. In the end all numbers in [[grove_prop]] as well as the resonance hash are compared, i.e. we create a new [[grove_list]]. <>= procedure :: get_grove => grove_list_get_grove <>= subroutine grove_list_get_grove (grove_list, kingraph, return_grove, preliminary) class (grove_list_t), intent (inout) :: grove_list type (kingraph_t), intent (in), pointer :: kingraph type (grove_t), intent (inout), pointer :: return_grove logical, intent (in) :: preliminary type (grove_t), pointer :: current_grove return_grove => null () if (.not. associated(grove_list%first)) then allocate (grove_list%first) grove_list%first%grove_prop = kingraph%grove_prop return_grove => grove_list%first return end if current_grove => grove_list%first do while (associated (current_grove)) if ((preliminary .and. (current_grove%grove_prop .match. kingraph%grove_prop)) .or. & (.not. preliminary .and. current_grove%grove_prop == kingraph%grove_prop)) then return_grove => current_grove exit else if (.not. associated (current_grove%next)) then allocate (current_grove%next) current_grove%next%grove_prop = kingraph%grove_prop if (size (kingraph%tree%bc) < 9) & current_grove%compare_tree%depth = 1 return_grove => current_grove%next exit end if if (associated (current_grove%next)) then current_grove => current_grove%next end if enddo end subroutine grove_list_get_grove @ %def grove_list_get_grove @ Add a valid [[kingraph]] to a [[grove_list]]. We first look for the [[grove]] which has the grove properties of the [[kingraph]]. If no such [[grove]] exists so far, it is created. <>= procedure :: add_kingraph => grove_list_add_kingraph <>= subroutine grove_list_add_kingraph (grove_list, kingraph, preliminary, check, model) class (grove_list_t), intent (inout) :: grove_list type (kingraph_t), pointer, intent (inout) :: kingraph logical, intent (in) :: preliminary logical, intent (in) :: check type (model_data_t), optional, intent (in) :: model type (grove_t), pointer :: grove type (kingraph_t), pointer :: current integer, save :: index = 0 grove => null () current => null () if (preliminary) then if (kingraph%index == 0) then index = index + 1 kingraph%index = index end if end if call grove_list%get_grove (kingraph, grove, preliminary) if (check) then call grove%compare_tree%check_kingraph (kingraph, model, preliminary) end if if (kingraph%keep) then if (associated (grove%first)) then grove%last%grove_next => kingraph grove%last => kingraph else grove%first => kingraph grove%last => kingraph end if end if end subroutine grove_list_add_kingraph @ %ref grove_list_add_kingraph @ For a given [[feyngraph]] we store all valid [[kingraphs]] in the [[grove_list]]. <>= procedure :: add_feyngraph => grove_list_add_feyngraph <>= subroutine grove_list_add_feyngraph (grove_list, feyngraph, model) class (grove_list_t), intent (inout) :: grove_list type (feyngraph_t), intent (inout) :: feyngraph type (model_data_t), intent (in) :: model type (kingraph_t), pointer :: current_kingraph, add_kingraph do while (associated (feyngraph%kin_first)) if (feyngraph%kin_first%keep) then add_kingraph => feyngraph%kin_first feyngraph%kin_first => feyngraph%kin_first%next add_kingraph%next => null () call grove_list%add_kingraph (kingraph=add_kingraph, & preliminary=.true., check=.true., model=model) else exit end if enddo if (associated (feyngraph%kin_first)) then current_kingraph => feyngraph%kin_first do while (associated (current_kingraph%next)) if (current_kingraph%next%keep) then add_kingraph => current_kingraph%next current_kingraph%next => current_kingraph%next%next add_kingraph%next => null () call grove_list%add_kingraph (kingraph=add_kingraph, & preliminary=.true., check=.true., model=model) else current_kingraph => current_kingraph%next end if enddo end if end subroutine grove_list_add_feyngraph @ %def grove_list_add_feyngraph @ Compare two [[grove_prop]] objects. The [[.match.]] operator is used for preliminary groves in which the [[kingraphs]] share only the 3 numbers [[n_resonances]], [[n_log_enhanced]] and [[n_t_channel]]. These groves are only used for comparing the kingraphs, because only graphs within these preliminary groves can be equivalent (the numbers which are compared here are unambigously fixed by the combination of mappings in these channels). <>= interface operator (.match.) module procedure grove_prop_match end interface operator (.match.) <>= function grove_prop_match (grove_prop1, grove_prop2) result (gp_match) type (grove_prop_t), intent (in) :: grove_prop1 type (grove_prop_t), intent (in) :: grove_prop2 logical :: gp_match gp_match = (grove_prop1%n_resonances == grove_prop2%n_resonances) & .and. (grove_prop1%n_log_enhanced == grove_prop2%n_log_enhanced) & .and. (grove_prop1%n_t_channel == grove_prop2%n_t_channel) end function grove_prop_match @ %def grove_prop_match @ The equal operator on the other hand will be used when all valid [[kingraphs]] have been created and mappings have been determined, to split up the existing (preliminary) grove list, i.e. to create new groves which are determined by all entries in [[grove_prop_t]]. <>= interface operator (==) module procedure grove_prop_equal end interface operator (==) <>= function grove_prop_equal (grove_prop1, grove_prop2) result (gp_equal) type (grove_prop_t), intent (in) :: grove_prop1 type (grove_prop_t), intent (in) :: grove_prop2 logical :: gp_equal gp_equal = (grove_prop1%res_hash == grove_prop2%res_hash) & .and. (grove_prop1%n_resonances == grove_prop2%n_resonances) & .and. (grove_prop1%n_log_enhanced == grove_prop2%n_log_enhanced) & .and. (grove_prop1%n_off_shell == grove_prop2%n_off_shell) & .and. (grove_prop1%multiplicity == grove_prop2%multiplicity) & .and. (grove_prop1%n_t_channel == grove_prop2%n_t_channel) end function grove_prop_equal @ %def grove_prop_equal @ \subsection{Remove equivalent channels} Here we define the equivalence condition for completed [[kingraphs]]. The aim is to keep those [[kingraphs]] which describe the strongest peaks of the amplitude. The [[bincodes]] and [[mappings]] have to be the same for an equivalence, but the [[pdgs]] can be different. At the same time we check if the trees are exacly the same (up to the sign of pdg codes) in which case we do not keep both of them. This can be the case when the incoming particles are the same or their mutual anti-particles and there are no t-channel lines in the Feynman diagram to which the kingraph belongs. <>= integer, parameter :: EMPTY = -999 <>= function kingraph_eqv (kingraph1, kingraph2) result (eqv) type (kingraph_t), intent (in) :: kingraph1 type (kingraph_t), intent (inout) :: kingraph2 logical :: eqv integer :: i logical :: equal eqv = .false. do i = kingraph1%tree%n_entries, 1, -1 if (kingraph1%tree%bc(i) /= kingraph2%tree%bc(i)) return enddo do i = kingraph1%tree%n_entries, 1, -1 if ( .not. (kingraph1%tree%mapping(i) == kingraph2%tree%mapping(i) & .or. ((kingraph1%tree%mapping(i) == NO_MAPPING .or. & kingraph1%tree%mapping(i) == NONRESONANT) .and. & (kingraph2%tree%mapping(i) == NO_MAPPING .or. & kingraph2%tree%mapping(i) == NONRESONANT)))) return enddo equal = .true. do i = kingraph1%tree%n_entries, 1, -1 if (abs(kingraph1%tree%pdg(i)) /= abs(kingraph2%tree%pdg(i))) then equal = .false.; select case (kingraph1%tree%mapping(i)) case (S_CHANNEL, RADIATION) select case (kingraph2%tree%mapping(i)) case (S_CHANNEL, RADIATION) return end select end select end if enddo if (equal) then kingraph2%keep = .false. call kingraph2%tree%final () else eqv = .true. end if end function kingraph_eqv @ %def kingraph_eqv @ Select between two [[kingraphs]] which fulfill the equivalence condition above. This is done by comparing the [[pdg]] values of the [[tree]] for increasing bincode. If the particles are different at some place, we usually choose the one which would be returned first by the subroutine [[match_vertex]] of the model for the daughter [[pdg]] codes. Since we work here only on the basis of the the [[trees]] of the completed [[kingraphs]], we have to use the [[bc]] array to determine the positions of the daughter nodes' entries in the array. The graph which has to be kept should correspond to the stronger peak at the place which is compared. <>= subroutine kingraph_select (kingraph1, kingraph2, model, preliminary) type (kingraph_t), intent (inout) :: kingraph1 type (kingraph_t), intent (inout) :: kingraph2 type (model_data_t), intent (in) :: model logical, intent (in) :: preliminary integer(TC), dimension(:), allocatable :: tmp_bc, daughter_bc integer, dimension(:), allocatable :: tmp_pdg, daughter_pdg integer, dimension (:), allocatable :: pdg_match integer :: i, j integer :: n_ext1, n_ext2 if (kingraph_eqv (kingraph1, kingraph2)) then if (.not. preliminary) then kingraph2%keep = .false.; call kingraph2%tree%final () return end if do i=1, size (kingraph1%tree%bc) if (abs(kingraph1%tree%pdg(i)) /= abs(kingraph2%tree%pdg(i))) then if (kingraph1%tree%mapping(i) /= EXTERNAL_PRT) then n_ext1 = popcnt (kingraph1%tree%bc(i)) n_ext2 = n_ext1 do j=i+1, size (kingraph1%tree%bc) if (abs(kingraph1%tree%pdg(j)) /= abs(kingraph2%tree%pdg(j))) then n_ext2 = popcnt (kingraph1%tree%bc(j)) if (n_ext2 < n_ext1) exit end if enddo if (n_ext2 < n_ext1) cycle allocate (tmp_bc(i-1)) tmp_bc = kingraph1%tree%bc(:i-1) allocate (tmp_pdg(i-1)) tmp_pdg = kingraph1%tree%pdg(:i-1) do j=i-1, 1, - 1 where (iand (tmp_bc(:j-1),tmp_bc(j)) /= 0 & .or. iand(tmp_bc(:j-1),kingraph1%tree%bc(i)) == 0) tmp_bc(:j-1) = 0 tmp_pdg(:j-1) = 0 endwhere enddo allocate (daughter_bc(size(pack(tmp_bc, tmp_bc /= 0)))) daughter_bc = pack (tmp_bc, tmp_bc /= 0) allocate (daughter_pdg(size(pack(tmp_pdg, tmp_pdg /= 0)))) daughter_pdg = pack (tmp_pdg, tmp_pdg /= 0) if (size (daughter_pdg) == 2) then call model%match_vertex(daughter_pdg(1), daughter_pdg(2), pdg_match) end if do j=1, size (pdg_match) if (abs(pdg_match(j)) == abs(kingraph1%tree%pdg(i))) then kingraph2%keep = .false.; call kingraph2%tree%final () exit else if (abs(pdg_match(j)) == abs(kingraph2%tree%pdg(i))) then kingraph1%keep = .false.; call kingraph1%tree%final () exit end if enddo deallocate (tmp_bc, tmp_pdg, daughter_bc, daughter_pdg, pdg_match) if (.not. (kingraph1%keep .and. kingraph2%keep)) exit end if end if enddo end if end subroutine kingraph_select @ %def kingraph_select @ At the beginning we do not care about the resonance hash, but only about part of the grove properties, which is defined in [[grove_prop_match]]. In these resulting preliminary groves the kingraphs can be equivalent, i.e. we do not have to compare all graphs with each other but only all graphs within each of these preliminary groves. In the end we create a new grove list where the grove properties of the [[kingraphs]] within a [[grove]] have to be exactly the same and in addition the groves are distinguished by the resonance hash values. Here the kingraphs are not compared any more, which means that the number of channels is not reduced any more. <>= procedure :: merge => grove_list_merge <>= subroutine grove_list_merge (target_list, grove_list, model, prc_component) class (grove_list_t), intent (inout) :: target_list type (grove_list_t), intent (inout) :: grove_list type (model_data_t), intent (in) :: model integer, intent (in) :: prc_component type (grove_t), pointer :: current_grove type (kingraph_t), pointer :: current_graph current_grove => grove_list%first do while (associated (current_grove)) do while (associated (current_grove%first)) current_graph => current_grove%first current_grove%first => current_grove%first%grove_next current_graph%grove_next => null () if (current_graph%keep) then current_graph%prc_component = prc_component call target_list%add_kingraph(kingraph=current_graph, & preliminary=.false., check=.true., model=model) else call current_graph%final () deallocate (current_graph) end if enddo current_grove => current_grove%next enddo end subroutine grove_list_merge @ %def grove_list_merge @ Recreate a grove list where we have different groves for different resonance hashes. <>= procedure :: rebuild => grove_list_rebuild <>= subroutine grove_list_rebuild (grove_list) class (grove_list_t), intent (inout) :: grove_list type (grove_list_t) :: tmp_list type (grove_t), pointer :: current_grove type (grove_t), pointer :: remove_grove type (kingraph_t), pointer :: current_graph type (kingraph_t), pointer :: next_graph tmp_list%first => grove_list%first grove_list%first => null () current_grove => tmp_list%first do while (associated (current_grove)) current_graph => current_grove%first do while (associated (current_graph)) call current_graph%assign_resonance_hash () next_graph => current_graph%grove_next current_graph%grove_next => null () if (current_graph%keep) then call grove_list%add_kingraph (kingraph=current_graph, & preliminary=.false., check=.false.) end if current_graph => next_graph enddo current_grove => current_grove%next enddo call tmp_list%final end subroutine grove_list_rebuild @ %def grove_list_rebuild @ \subsection{Write the phase-space file} The phase-space file is written from the graphs which survive the calculations and equivalence checks and are in the grove list. It is written grove by grove. The output should be the same as in the corresponding procedure [[cascade_set_write_file_format]] of [[cascades]], up to the order of groves and channels. <>= public :: feyngraph_set_write_file_format <>= subroutine feyngraph_set_write_file_format (feyngraph_set, u) type (feyngraph_set_t), intent (in) :: feyngraph_set integer, intent (in) :: u type (grove_t), pointer :: grove integer :: channel_number integer :: grove_number channel_number = 0 grove_number = 0 grove => feyngraph_set%grove_list%first do while (associated (grove)) grove_number = grove_number + 1 call grove%write_file_format (feyngraph_set, grove_number, channel_number, u) grove => grove%next enddo end subroutine feyngraph_set_write_file_format @ %def feyngraph_set_write_file_format @ Write the relevant information of the [[kingraphs]] of a [[grove]] and the grove properties in the file format. <>= procedure :: write_file_format => grove_write_file_format <>= recursive subroutine grove_write_file_format (grove, feyngraph_set, gr_number, ch_number, u) class (grove_t), intent (in) :: grove type (feyngraph_set_t), intent (in) :: feyngraph_set integer, intent (in) :: u integer, intent (inout) :: gr_number integer, intent (inout) :: ch_number type (kingraph_t), pointer :: current 1 format(3x,A,1x,40(1x,I4)) write (u, "(A)") write (u, "(1x,'!',1x,A,1x,I0,A)", advance='no') & 'Multiplicity =', grove%grove_prop%multiplicity, "," select case (grove%grove_prop%n_resonances) case (0) write (u, '(1x,A)', advance='no') 'no resonances, ' case (1) write (u, '(1x,A)', advance='no') '1 resonance, ' case default write (u, '(1x,I0,1x,A)', advance='no') & grove%grove_prop%n_resonances, 'resonances, ' end select write (u, '(1x,I0,1x,A)', advance='no') & grove%grove_prop%n_log_enhanced, 'logs, ' write (u, '(1x,I0,1x,A)', advance='no') & grove%grove_prop%n_off_shell, 'off-shell, ' select case (grove%grove_prop%n_t_channel) case (0); write (u, '(1x,A)') 's-channel graph' case (1); write (u, '(1x,A)') '1 t-channel line' case default write(u,'(1x,I0,1x,A)') & grove%grove_prop%n_t_channel, 't-channel lines' end select write (u, '(1x,A,I0)') 'grove #', gr_number current => grove%first do while (associated (current)) if (current%keep) then ch_number = ch_number + 1 call current%write_file_format (feyngraph_set, ch_number, u) end if current => current%grove_next enddo end subroutine grove_write_file_format @ %def grove_write_file_format @ Write the relevant information of a valid [[kingraph]] in the file format. The information is extracted from the [[tree]]. <>= procedure :: write_file_format => kingraph_write_file_format <>= subroutine kingraph_write_file_format (kingraph, feyngraph_set, ch_number, u) class (kingraph_t), intent (in) :: kingraph type (feyngraph_set_t), intent (in) :: feyngraph_set integer, intent (in) :: ch_number integer, intent (in) :: u integer :: i integer(TC) :: bincode_incoming 2 format(3X,'map',1X,I3,1X,A,1X,I9,1X,'!',1X,A) !!! determine bincode of incoming particle from tree bincode_incoming = maxval (kingraph%tree%bc) write (unit=u, fmt='(1X,A,I0)') '! Channel #', ch_number write (unit=u, fmt='(3X,A,1X)', advance='no') 'tree' do i=1, size (kingraph%tree%bc) if (kingraph%tree%mapping(i) >=0 .or. kingraph%tree%mapping(i) == NONRESONANT & .or. (kingraph%tree%bc(i) == bincode_incoming & .and. feyngraph_set%process_type == DECAY)) then write (unit=u, fmt='(1X,I0)', advance='no') kingraph%tree%bc(i) end if enddo write (unit=u, fmt='(A)', advance='yes') do i=1, size(kingraph%tree%bc) select case (kingraph%tree%mapping(i)) case (NO_MAPPING, NONRESONANT, EXTERNAL_PRT) case (S_CHANNEL) write (unit=u, fmt=2) kingraph%tree%bc(i), 's_channel', & kingraph%tree%pdg(i), & trim(get_particle_name (feyngraph_set, kingraph%tree%pdg(i))) case (T_CHANNEL) write (unit=u, fmt=2) kingraph%tree%bc(i), 't_channel', & abs (kingraph%tree%pdg(i)), & trim(get_particle_name (feyngraph_set, abs(kingraph%tree%pdg(i)))) case (U_CHANNEL) write (unit=u, fmt=2) kingraph%tree%bc(i), 'u_channel', & abs (kingraph%tree%pdg(i)), & trim(get_particle_name (feyngraph_set, abs(kingraph%tree%pdg(i)))) case (RADIATION) write (unit=u, fmt=2) kingraph%tree%bc(i), 'radiation', & kingraph%tree%pdg(i), & trim(get_particle_name (feyngraph_set, kingraph%tree%pdg(i))) case (COLLINEAR) write (unit=u, fmt=2) kingraph%tree%bc(i), 'collinear', & kingraph%tree%pdg(i), & trim(get_particle_name (feyngraph_set, kingraph%tree%pdg(i))) case (INFRARED) write (unit=u, fmt=2) kingraph%tree%bc(i), 'infrared ', & kingraph%tree%pdg(i), & trim(get_particle_name (feyngraph_set, kingraph%tree%pdg(i))) case (ON_SHELL) write (unit=u, fmt=2) kingraph%tree%bc(i), 'on_shell ', & kingraph%tree%pdg(i), & trim(get_particle_name (feyngraph_set, kingraph%tree%pdg(i))) case default call msg_bug (" Impossible mapping mode encountered") end select enddo end subroutine kingraph_write_file_format @ %def kingraph_write_file_format @ Get the particle name from the [[particle]] array of the [[feyngraph_set]]. This is needed for the phs file creation. <>= function get_particle_name (feyngraph_set, pdg) result (particle_name) type (feyngraph_set_t), intent (in) :: feyngraph_set integer, intent (in) :: pdg character (len=LABEL_LEN) :: particle_name integer :: i do i=1, size (feyngraph_set%particle) if (feyngraph_set%particle(i)%pdg == pdg) then particle_name = feyngraph_set%particle(i)%particle_label exit end if enddo end function get_particle_name @ %def get_particle_name @ \subsection{Invert a graph} All Feynman diagrams given by O'Mega look like a decay. The [[feyngraph]] which is constructed from this output also looks like a decay, where one of the incoming particles is the decaying particle (or the root of the tree). The calculations can in principle be done on this data structure. However, it is also performed with the other incoming particle as the root. The first part of the calculation is the same for both cases. For the second part we need to transform/turn the graphs such that the other incoming particle becomes the root. This is done by identifying the incoming particles from the O'Mega output (the first one is simply the root of the existing tree, the second contains [2] in the [[particle_label]]) and the nodes/particles which connect both incoming particles (here we set [[t_line = .true.]]). At the same time we set the pointers [[inverse_daughter1]] and [[inverse_daughter2]] for the corresponding node, which point to the mother node and the other daughter of the mother node; these will be the daughters of the node in the inverted [[feyngraph]]. <>= procedure :: make_invertible => feyngraph_make_invertible <>= subroutine feyngraph_make_invertible (feyngraph) class (feyngraph_t), intent (inout) :: feyngraph logical :: t_line_found feyngraph%root%incoming = .true. t_line_found = .false. if (associated (feyngraph%root%daughter1)) then call f_node_t_line_check (feyngraph%root%daughter1, t_line_found) if (.not. t_line_found) then if (associated (feyngraph%root%daughter2)) then call f_node_t_line_check (feyngraph%root%daughter2, t_line_found) end if end if end if contains <> end subroutine feyngraph_make_invertible @ %def feyngraph_make_invertible @ Check if a node has to be [[t_line]] or [[incoming]] and assign inverse daughter pointers. <>= recursive subroutine f_node_t_line_check (node, t_line_found) type (f_node_t), target, intent (inout) :: node integer :: pos logical, intent (inout) :: t_line_found if (associated (node%daughter1)) then call f_node_t_line_check (node%daughter1, t_line_found) if (node%daughter1%incoming .or. node%daughter1%t_line) then node%t_line = .true. else if (associated (node%daughter2)) then call f_node_t_line_check (node%daughter2, t_line_found) if (node%daughter2%incoming .or. node%daughter2%t_line) then node%t_line = .true. end if end if else pos = index (node%particle_label, '[') + 1 if (node%particle_label(pos:pos) == '2') then node%incoming = .true. t_line_found = .true. end if end if end subroutine f_node_t_line_check @ %def k_node_t_line_check @ Make an inverted copy of a [[kingraph]] using the inverse daughter pointers. <>= procedure :: make_inverse_copy => kingraph_make_inverse_copy <>= subroutine kingraph_make_inverse_copy (original_kingraph, feyngraph) class (kingraph_t), intent (inout) :: original_kingraph type (feyngraph_t), intent (inout) :: feyngraph type (kingraph_t), pointer :: kingraph_copy type (k_node_t), pointer :: potential_root allocate (kingraph_copy) if (associated (feyngraph%kin_last)) then allocate (feyngraph%kin_last%next) feyngraph%kin_last => feyngraph%kin_last%next else allocate(feyngraph%kin_first) feyngraph%kin_last => feyngraph%kin_first end if kingraph_copy => feyngraph%kin_last call kingraph_set_inverse_daughters (original_kingraph) kingraph_copy%inverse = .true. kingraph_copy%n_nodes = original_kingraph%n_nodes kingraph_copy%keep = original_kingraph%keep potential_root => original_kingraph%root do while (.not. potential_root%incoming .or. & (associated (potential_root%daughter1) .and. associated (potential_root%daughter2))) if (potential_root%daughter1%incoming .or. potential_root%daughter1%t_line) then potential_root => potential_root%daughter1 else if (potential_root%daughter2%incoming .or. potential_root%daughter2%t_line) then potential_root => potential_root%daughter2 end if enddo call node_inverse_deep_copy (potential_root, kingraph_copy%root) end subroutine kingraph_make_inverse_copy @ %def kingraph_make_inverse_copy @ Recursively deep-copy nodes, but along the t-line the inverse daughters become the new daughters. We need a deep copy only for the [[incoming]] or [[t_line]] nodes. For the other nodes (of s-channel subgraphs) we set only pointers to the existing nodes of the non-inverted graph. <>= recursive subroutine node_inverse_deep_copy (original_node, node_copy) type (k_node_t), intent (in) :: original_node type (k_node_t), pointer, intent (out) :: node_copy call original_node%f_node%k_node_list%add_entry(node_copy, recycle=.false.) node_copy = original_node if (node_copy%t_line .or. node_copy%incoming) then node_copy%particle => original_node%particle%anti else node_copy%particle => original_node%particle end if if (associated (original_node%inverse_daughter1) .and. associated (original_node%inverse_daughter2)) then if (original_node%inverse_daughter1%incoming .or. original_node%inverse_daughter1%t_line) then node_copy%daughter2 => original_node%inverse_daughter2 call node_inverse_deep_copy (original_node%inverse_daughter1, & node_copy%daughter1) else if (original_node%inverse_daughter2%incoming .or. original_node%inverse_daughter2%t_line) then node_copy%daughter1 => original_node%inverse_daughter1 call node_inverse_deep_copy (original_node%inverse_daughter2, & node_copy%daughter2) end if end if end subroutine node_inverse_deep_copy @ %def node_inverse_deep_copy @ \subsection{Find phase-space parametrizations} Perform all mapping calculations for a single process and store valid [[kingraphs]] (channels) into the grove list, without caring for instance about the resonance hash values. <>= public :: feyngraph_set_generate_single <>= subroutine feyngraph_set_generate_single (feyngraph_set, model, n_in, n_out, & phs_par, fatal_beam_decay, u_in) type(feyngraph_set_t), intent(inout) :: feyngraph_set type(model_data_t), target, intent(in) :: model integer, intent(in) :: n_in, n_out type(phs_parameters_t), intent(in) :: phs_par logical, intent(in) :: fatal_beam_decay integer, intent(in) :: u_in feyngraph_set%n_in = n_in feyngraph_set%n_out = n_out feyngraph_set%process_type = n_in feyngraph_set%phs_par = phs_par feyngraph_set%model => model call msg_debug (D_PHASESPACE, "Construct relevant Feynman diagrams from Omega output") call feyngraph_set%build (u_in) call msg_debug (D_PHASESPACE, "Find phase-space parametrizations") call feyngraph_set_find_phs_parametrizations(feyngraph_set) end subroutine feyngraph_set_generate_single @ %def feyngraph_set_generate_single @ Find the phase space parametrizations. We start with the computation of pure s-channel subtrees, i.e. we determine mappings and compare subtrees in order to reduce the number of channels. This can be parallelized easily. When all s-channel [[k_nodes]] exist, the possible [[kingraphs]] are created using these nodes and we determine mappings for t-channel nodes. <>= subroutine feyngraph_set_find_phs_parametrizations (feyngraph_set) class (feyngraph_set_t), intent (inout) :: feyngraph_set type (feyngraph_t), pointer :: current => null () type (feyngraph_ptr_t), dimension (:), allocatable :: set integer :: pos integer :: i allocate (set (feyngraph_set%n_graphs)) pos = 0 current => feyngraph_set%first do while (associated (current)) pos = pos + 1 set(pos)%graph => current current => current%next enddo if (feyngraph_set%process_type == SCATTERING) then !$OMP PARALLEL DO do i=1, feyngraph_set%n_graphs if (set(i)%graph%keep) then call set(i)%graph%make_invertible () end if enddo !$OMP END PARALLEL DO end if call f_node_list_compute_mappings_s (feyngraph_set) do i=1, feyngraph_set%n_graphs if (set(i)%graph%keep) then call set(i)%graph%make_kingraphs (feyngraph_set) end if enddo if (feyngraph_set%process_type == SCATTERING) then do i=1, feyngraph_set%n_graphs if (set(i)%graph%keep) then call set(i)%graph%make_inverse_kingraphs () end if enddo end if do i=1, feyngraph_set%n_graphs if (set(i)%graph%keep) then call set(i)%graph%compute_mappings (feyngraph_set) end if enddo do i=1, feyngraph_set%n_graphs if (set(i)%graph%keep) then call feyngraph_set%grove_list%add_feyngraph (set(i)%graph, & feyngraph_set%model) end if enddo end subroutine feyngraph_set_find_phs_parametrizations @ %def feyngraph_set_find_phs_parametrizations @ Compare objects of type [[tree_t]]. <>= interface operator (==) module procedure tree_equal end interface operator (==) <>= elemental function tree_equal (tree1, tree2) result (flag) type (tree_t), intent (in) :: tree1, tree2 logical :: flag if (tree1%n_entries == tree2%n_entries) then if (tree1%bc(size(tree1%bc)) == tree2%bc(size(tree2%bc))) then flag = all (tree1%mapping == tree2%mapping) .and. & all (tree1%bc == tree2%bc) .and. & all (abs(tree1%pdg) == abs(tree2%pdg)) else flag = .false. end if else flag = .false. end if end function tree_equal @ %def tree_equal @ Select between equivalent subtrees (type [[tree_t]]). This is similar to [[kingraph_select]], but we compare only positions with mappings [[NONRESONANT]] and [[NO_MAPPING]]. <>= interface operator (.eqv.) module procedure subtree_eqv end interface operator (.eqv.) <>= pure function subtree_eqv (subtree1, subtree2) result (eqv) type (tree_t), intent (in) :: subtree1, subtree2 logical :: eqv integer :: root_pos integer :: i logical :: equal eqv = .false. if (subtree1%n_entries /= subtree2%n_entries) return root_pos = subtree1%n_entries if (subtree1%mapping(root_pos) == NONRESONANT .or. & subtree2%mapping(root_pos) == NONRESONANT .or. & (subtree1%mapping(root_pos) == NO_MAPPING .and. & subtree2%mapping(root_pos) == NO_MAPPING .and. & abs(subtree1%pdg(root_pos)) == abs(subtree2%pdg(root_pos)))) then do i = subtree1%n_entries, 1, -1 if (subtree1%bc(i) /= subtree2%bc(i)) return enddo equal = .true. do i = subtree1%n_entries, 1, -1 if (abs(subtree1%pdg(i)) /= abs (subtree2%pdg(i))) then select case (subtree1%mapping(i)) case (NO_MAPPING, NONRESONANT) select case (subtree2%mapping(i)) case (NO_MAPPING, NONRESONANT) equal = .false. case default return end select case default return end select end if enddo do i = subtree1%n_entries, 1, -1 if (subtree1%mapping(i) /= subtree2%mapping(i)) then select case (subtree1%mapping(i)) case (NO_MAPPING, NONRESONANT) select case (subtree2%mapping(i)) case (NO_MAPPING, NONRESONANT) case default return end select case default return end select end if enddo if (.not. equal) eqv = .true. end if end function subtree_eqv @ %def subtree_eqv <>= subroutine subtree_select (subtree1, subtree2, model) type (tree_t), intent (inout) :: subtree1, subtree2 type (model_data_t), intent (in) :: model integer :: j, k integer(TC), dimension(:), allocatable :: tmp_bc, daughter_bc integer, dimension(:), allocatable :: tmp_pdg, daughter_pdg integer, dimension (:), allocatable :: pdg_match if (subtree1 .eqv. subtree2) then do j=1, subtree1%n_entries if (abs(subtree1%pdg(j)) /= abs(subtree2%pdg(j))) then tmp_bc = subtree1%bc(:j-1); tmp_pdg = subtree1%pdg(:j-1) do k=j-1, 1, - 1 where (iand (tmp_bc(:k-1),tmp_bc(k)) /= 0 & .or. iand(tmp_bc(:k-1),subtree1%bc(j)) == 0) tmp_bc(:k-1) = 0 tmp_pdg(:k-1) = 0 endwhere enddo daughter_bc = pack (tmp_bc, tmp_bc /= 0) daughter_pdg = pack (tmp_pdg, tmp_pdg /= 0) if (size (daughter_pdg) == 2) then call model%match_vertex(daughter_pdg(1), daughter_pdg(2), pdg_match) if (.not. allocated (pdg_match)) then !!! Relevant if tree contains only abs (pdg). In this case, changing the !!! sign of one of the pdg codes should give a result. call model%match_vertex(-daughter_pdg(1), daughter_pdg(2), pdg_match) end if end if do k=1, size (pdg_match) if (abs(pdg_match(k)) == abs(subtree1%pdg(j))) then if (subtree1%keep) subtree2%keep = .false. exit else if (abs(pdg_match(k)) == abs(subtree2%pdg(j))) then if (subtree2%keep) subtree1%keep = .false. exit end if enddo deallocate (tmp_bc, tmp_pdg, daughter_bc, daughter_pdg, pdg_match) if (.not. (subtree1%keep .and. subtree2%keep)) exit end if enddo end if end subroutine subtree_select @ %def subtree_select @ Assign a resonance hash value to a [[kingraph]], like in [[cascades]], but here without the array [[tree_resonant]]. <>= procedure :: assign_resonance_hash => kingraph_assign_resonance_hash <>= subroutine kingraph_assign_resonance_hash (kingraph) class (kingraph_t), intent (inout) :: kingraph logical, dimension (:), allocatable :: tree_resonant integer(i8), dimension(1) :: mold allocate (tree_resonant (kingraph%tree%n_entries)) tree_resonant = (kingraph%tree%mapping == S_CHANNEL) kingraph%grove_prop%res_hash = hash (transfer & ([sort (pack (kingraph%tree%pdg, tree_resonant)), & sort (pack (abs (kingraph%tree%pdg), & kingraph%tree%mapping == T_CHANNEL .or. & kingraph%tree%mapping == U_CHANNEL))], mold)) deallocate (tree_resonant) end subroutine kingraph_assign_resonance_hash @ %def kingraph_assign_resonance_hash @ Write the process in the bincode format. This is again a copy of the corresponding procedure in [[cascades]], using [[feyngraph_set]] instead of [[cascade_set]] as an argument. <>= public :: feyngraph_set_write_process_bincode_format <>= subroutine feyngraph_set_write_process_bincode_format (feyngraph_set, unit) type(feyngraph_set_t), intent(in), target :: feyngraph_set integer, intent(in), optional :: unit integer, dimension(:), allocatable :: bincode, field_width integer :: n_in, n_out, n_tot, n_flv integer :: u, f, i, bc character(20) :: str type(string_t) :: fmt_head type(string_t), dimension(:), allocatable :: fmt_proc u = given_output_unit (unit); if (u < 0) return if (.not. allocated (feyngraph_set%flv)) return write (u, "('!',1x,A)") "List of subprocesses with particle bincodes:" n_in = feyngraph_set%n_in n_out = feyngraph_set%n_out n_tot = n_in + n_out n_flv = size (feyngraph_set%flv, 2) allocate (bincode (n_tot), field_width (n_tot), fmt_proc (n_tot)) bc = 1 do i = 1, n_out bincode(n_in + i) = bc bc = 2 * bc end do do i = n_in, 1, -1 bincode(i) = bc bc = 2 * bc end do do i = 1, n_tot write (str, "(I0)") bincode(i) field_width(i) = len_trim (str) do f = 1, n_flv field_width(i) = max (field_width(i), & len (feyngraph_set%flv(i,f)%get_name ())) end do end do fmt_head = "('!'" do i = 1, n_tot fmt_head = fmt_head // ",1x," fmt_proc(i) = "(1x," write (str, "(I0)") field_width(i) fmt_head = fmt_head // "I" // trim(str) fmt_proc(i) = fmt_proc(i) // "A" // trim(str) if (i == n_in) then fmt_head = fmt_head // ",1x,' '" end if end do do i = 1, n_tot fmt_proc(i) = fmt_proc(i) // ")" end do fmt_head = fmt_head // ")" write (u, char (fmt_head)) bincode do f = 1, n_flv write (u, "('!')", advance="no") do i = 1, n_tot write (u, char (fmt_proc(i)), advance="no") & char (feyngraph_set%flv(i,f)%get_name ()) if (i == n_in) write (u, "(1x,'=>')", advance="no") end do write (u, *) end do write (u, char (fmt_head)) bincode end subroutine feyngraph_set_write_process_bincode_format @ %def feyngraph_set_write_process_bincode_format @ Write tex file for graphical display of channels. <>= public :: feyngraph_set_write_graph_format <>= subroutine feyngraph_set_write_graph_format (feyngraph_set, filename, process_id, unit) type(feyngraph_set_t), intent(in), target :: feyngraph_set type(string_t), intent(in) :: filename, process_id integer, intent(in), optional :: unit type(kingraph_t), pointer :: kingraph type(grove_t), pointer :: grove integer :: u, n_grove, count, pgcount logical :: first_in_grove u = given_output_unit (unit); if (u < 0) return write (u, '(A)') "\documentclass[10pt]{article}" write (u, '(A)') "\usepackage{amsmath}" write (u, '(A)') "\usepackage{feynmp}" write (u, '(A)') "\usepackage{url}" write (u, '(A)') "\usepackage{color}" write (u, *) write (u, '(A)') "\textwidth 18.5cm" write (u, '(A)') "\evensidemargin -1.5cm" write (u, '(A)') "\oddsidemargin -1.5cm" write (u, *) write (u, '(A)') "\newcommand{\blue}{\color{blue}}" write (u, '(A)') "\newcommand{\green}{\color{green}}" write (u, '(A)') "\newcommand{\red}{\color{red}}" write (u, '(A)') "\newcommand{\magenta}{\color{magenta}}" write (u, '(A)') "\newcommand{\cyan}{\color{cyan}}" write (u, '(A)') "\newcommand{\sm}{\footnotesize}" write (u, '(A)') "\setlength{\parindent}{0pt}" write (u, '(A)') "\setlength{\parsep}{20pt}" write (u, *) write (u, '(A)') "\begin{document}" write (u, '(A)') "\begin{fmffile}{" // char (filename) // "}" write (u, '(A)') "\fmfcmd{color magenta; magenta = red + blue;}" write (u, '(A)') "\fmfcmd{color cyan; cyan = green + blue;}" write (u, '(A)') "\begin{fmfshrink}{0.5}" write (u, '(A)') "\begin{flushleft}" write (u, *) write (u, '(A)') "\noindent" // & & "\textbf{\large\texttt{WHIZARD} phase space channels}" // & & "\hfill\today" write (u, *) write (u, '(A)') "\vspace{10pt}" write (u, '(A)') "\noindent" // & & "\textbf{Process:} \url{" // char (process_id) // "}" call feyngraph_set_write_process_tex_format (feyngraph_set, u) write (u, *) write (u, '(A)') "\noindent" // & & "\textbf{Note:} These are pseudo Feynman graphs that " write (u, '(A)') "visualize phase-space parameterizations " // & & "(``integration channels''). " write (u, '(A)') "They do \emph{not} indicate Feynman graphs used for the " // & & "matrix element." write (u, *) write (u, '(A)') "\textbf{Color code:} " // & & "{\blue resonance,} " // & & "{\cyan t-channel,} " // & & "{\green radiation,} " write (u, '(A)') "{\red infrared,} " // & & "{\magenta collinear,} " // & & "external/off-shell" write (u, *) write (u, '(A)') "\noindent" // & & "\textbf{Black square:} Keystone, indicates ordering of " // & & "phase space parameters." write (u, *) write (u, '(A)') "\vspace{-20pt}" count = 0 pgcount = 0 n_grove = 0 grove => feyngraph_set%grove_list%first do while (associated (grove)) n_grove = n_grove + 1 write (u, *) write (u, '(A)') "\vspace{20pt}" write (u, '(A)') "\begin{tabular}{l}" write (u, '(A,I5,A)') & & "\fbox{\bf Grove \boldmath$", n_grove, "$} \\[10pt]" write (u, '(A,I1,A)') "Multiplicity: ", & grove%grove_prop%multiplicity, "\\" write (u, '(A,I1,A)') "Resonances: ", & grove%grove_prop%n_resonances, "\\" write (u, '(A,I1,A)') "Log-enhanced: ", & grove%grove_prop%n_log_enhanced, "\\" write (u, '(A,I1,A)') "Off-shell: ", & grove%grove_prop%n_off_shell, "\\" write (u, '(A,I1,A)') "t-channel: ", & grove%grove_prop%n_t_channel, "" write (u, '(A)') "\end{tabular}" kingraph => grove%first do while (associated (kingraph)) count = count + 1 call kingraph_write_graph_format (kingraph, count, unit) kingraph => kingraph%grove_next enddo grove => grove%next enddo write (u, '(A)') "\end{flushleft}" write (u, '(A)') "\end{fmfshrink}" write (u, '(A)') "\end{fmffile}" write (u, '(A)') "\end{document}" end subroutine feyngraph_set_write_graph_format @ %def feyngraph_set_write_graph_format @ Write the process as a \LaTeX\ expression. This is a slightly modified copy of [[cascade_set_write_process_tex_format]] which has only been adapted to the types which are used here. <>= subroutine feyngraph_set_write_process_tex_format (feyngraph_set, unit) type(feyngraph_set_t), intent(in), target :: feyngraph_set integer, intent(in), optional :: unit integer :: n_tot integer :: u, f, i n_tot = feyngraph_set%n_in + feyngraph_set%n_out u = given_output_unit (unit); if (u < 0) return if (.not. allocated (feyngraph_set%flv)) return write (u, "(A)") "\begin{align*}" do f = 1, size (feyngraph_set%flv, 2) do i = 1, feyngraph_set%n_in if (i > 1) write (u, "(A)", advance="no") "\quad " write (u, "(A)", advance="no") & char (feyngraph_set%flv(i,f)%get_tex_name ()) end do write (u, "(A)", advance="no") "\quad &\to\quad " do i = feyngraph_set%n_in + 1, n_tot if (i > feyngraph_set%n_in + 1) write (u, "(A)", advance="no") "\quad " write (u, "(A)", advance="no") & char (feyngraph_set%flv(i,f)%get_tex_name ()) end do if (f < size (feyngraph_set%flv, 2)) then write (u, "(A)") "\\" else write (u, "(A)") "" end if end do write (u, "(A)") "\end{align*}" end subroutine feyngraph_set_write_process_tex_format @ %def feyngraph_set_write_process_tex_format @ This creates metapost source for graphical display for a given [[kingraph]]. It is the analogon to [[cascade_write_graph_format]] (a modified copy). <>= subroutine kingraph_write_graph_format (kingraph, count, unit) type(kingraph_t), intent(in) :: kingraph integer, intent(in) :: count integer, intent(in), optional :: unit integer :: u type(string_t) :: left_str, right_str u = given_output_unit (unit); if (u < 0) return left_str = "" right_str = "" write (u, '(A)') "\begin{minipage}{105pt}" write (u, '(A)') "\vspace{30pt}" write (u, '(A)') "\begin{center}" write (u, '(A)') "\begin{fmfgraph*}(55,55)" call graph_write_node (kingraph%root) write (u, '(A)') "\fmfleft{" // char (extract (left_str, 2)) // "}" write (u, '(A)') "\fmfright{" // char (extract (right_str, 2)) // "}" write (u, '(A)') "\end{fmfgraph*}\\" write (u, '(A,I5,A)') "\fbox{$", count, "$}" write (u, '(A)') "\end{center}" write (u, '(A)') "\end{minipage}" write (u, '(A)') "%" contains recursive subroutine graph_write_node (node) type(k_node_t), intent(in) :: node if (associated (node%daughter1) .or. associated (node%daughter2)) then if (node%daughter2%t_line .or. node%daughter2%incoming) then call vertex_write (node, node%daughter2) call vertex_write (node, node%daughter1) else call vertex_write (node, node%daughter1) call vertex_write (node, node%daughter2) end if if (node%mapping == EXTERNAL_PRT) then call line_write (node%bincode, 0, node%particle) call external_write (node%bincode, node%particle%tex_name, & left_str) write (u, '(A,I0,A)') "\fmfv{d.shape=square}{v0}" end if else if (node%incoming) then call external_write (node%bincode, node%particle%anti%tex_name, & left_str) else call external_write (node%bincode, node%particle%tex_name, & right_str) end if end if end subroutine graph_write_node recursive subroutine vertex_write (node, daughter) type(k_node_t), intent(in) :: node, daughter integer :: bincode if (associated (node%daughter1) .and. associated (node%daughter2) & .and. node%mapping == EXTERNAL_PRT) then bincode = 0 else bincode = node%bincode end if call graph_write_node (daughter) if (associated (node%daughter1) .or. associated (node%daughter2)) then call line_write (bincode, daughter%bincode, daughter%particle, & mapping=daughter%mapping) else call line_write (bincode, daughter%bincode, daughter%particle) end if end subroutine vertex_write subroutine line_write (i1, i2, particle, mapping) integer(TC), intent(in) :: i1, i2 type(part_prop_t), intent(in) :: particle integer, intent(in), optional :: mapping integer :: k1, k2 type(string_t) :: prt_type select case (particle%spin_type) case (SCALAR); prt_type = "plain" case (SPINOR); prt_type = "fermion" case (VECTOR); prt_type = "boson" case (VECTORSPINOR); prt_type = "fermion" case (TENSOR); prt_type = "dbl_wiggly" case default; prt_type = "dashes" end select if (particle%pdg < 0) then !!! anti-particle k1 = i2; k2 = i1 else k1 = i1; k2 = i2 end if if (present (mapping)) then select case (mapping) case (S_CHANNEL) write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & & ",f=blue,lab=\sm\blue$" // & & char (particle%tex_name) // "$}" // & & "{v", k1, ",v", k2, "}" case (T_CHANNEL, U_CHANNEL) write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & & ",f=cyan,lab=\sm\cyan$" // & & char (particle%tex_name) // "$}" // & & "{v", k1, ",v", k2, "}" case (RADIATION) write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & & ",f=green,lab=\sm\green$" // & & char (particle%tex_name) // "$}" // & & "{v", k1, ",v", k2, "}" case (COLLINEAR) write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & & ",f=magenta,lab=\sm\magenta$" // & & char (particle%tex_name) // "$}" // & & "{v", k1, ",v", k2, "}" case (INFRARED) write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & & ",f=red,lab=\sm\red$" // & & char (particle%tex_name) // "$}" // & & "{v", k1, ",v", k2, "}" case default write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & & ",f=black}" // & & "{v", k1, ",v", k2, "}" end select else write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // & & "}" // & & "{v", k1, ",v", k2, "}" end if end subroutine line_write subroutine external_write (bincode, name, ext_str) integer(TC), intent(in) :: bincode type(string_t), intent(in) :: name type(string_t), intent(inout) :: ext_str character(len=20) :: str write (str, '(A2,I0)') ",v", bincode ext_str = ext_str // trim (str) write (u, '(A,I0,A,I0,A)') "\fmflabel{\sm$" & // char (name) & // "\,(", bincode, ")" & // "$}{v", bincode, "}" end subroutine external_write end subroutine kingraph_write_graph_format @ %def kingraph_write_graph_format @ Generate a [[feyngraph_set]] for several subprocesses. Mapping calculations are performed separately, but the final grove list is shared between the subsets [[fset]] of the [[feyngraph_set]]. <>= public :: feyngraph_set_generate <>= subroutine feyngraph_set_generate & (feyngraph_set, model, n_in, n_out, flv, phs_par, fatal_beam_decay, & u_in, vis_channels, use_dag) type(feyngraph_set_t), intent(out) :: feyngraph_set class(model_data_t), intent(in), target :: model integer, intent(in) :: n_in, n_out type(flavor_t), dimension(:,:), intent(in) :: flv type(phs_parameters_t), intent(in) :: phs_par logical, intent(in) :: fatal_beam_decay integer, intent(in) :: u_in logical, intent(in) :: vis_channels logical, optional, intent(in) :: use_dag type(grove_t), pointer :: grove integer :: i, j type(kingraph_t), pointer :: kingraph if (phase_space_vanishes (phs_par%sqrts, n_in, flv)) return if (present (use_dag)) feyngraph_set%use_dag = use_dag feyngraph_set%process_type = n_in feyngraph_set%n_in = n_in feyngraph_set%n_out = n_out allocate (feyngraph_set%flv (size (flv, 1), size (flv, 2))) do i = 1, size (flv, 2) do j = 1, size (flv, 1) call feyngraph_set%flv(j,i)%init (flv(j,i)%get_pdg (), model) end do end do allocate (feyngraph_set%particle (PRT_ARRAY_SIZE)) allocate (feyngraph_set%grove_list) allocate (feyngraph_set%fset (size (flv, 2))) do i = 1, size (feyngraph_set%fset) feyngraph_set%fset(i)%use_dag = feyngraph_set%use_dag allocate (feyngraph_set%fset(i)%flv(size (flv,1),1)) feyngraph_set%fset(i)%flv(:,1) = flv(:,i) feyngraph_set%fset(i)%particle => feyngraph_set%particle allocate (feyngraph_set%fset(i)%grove_list) call feyngraph_set_generate_single (feyngraph_set%fset(i), & model, n_in, n_out, phs_par, fatal_beam_decay, u_in) call feyngraph_set%grove_list%merge (feyngraph_set%fset(i)%grove_list, model, i) if (.not. vis_channels) call feyngraph_set%fset(i)%final() enddo call feyngraph_set%grove_list%rebuild () end subroutine feyngraph_set_generate @ %def feyngraph_set_generate @ Check whether the [[grove_list]] of the [[feyngraph_set]] contains any [[kingraphs]] which are valid, i.e. where the [[keep]] variable has the value [[.true.]]. This is necessary to write a non-empty phase-space file. The function is the pendant to [[cascade_set_is_valid]]. <>= public :: feyngraph_set_is_valid <>= function feyngraph_set_is_valid (feyngraph_set) result (flag) class (feyngraph_set_t), intent(in) :: feyngraph_set type (kingraph_t), pointer :: kingraph type (grove_t), pointer :: grove logical :: flag flag = .false. if (associated (feyngraph_set%grove_list)) then grove => feyngraph_set%grove_list%first do while (associated (grove)) kingraph => grove%first do while (associated (kingraph)) if (kingraph%keep) then flag = .true. return end if kingraph => kingraph%next enddo grove => grove%next enddo end if end function feyngraph_set_is_valid @ %def feyngraph_set_is_valid @ \subsection{Return the resonance histories for subtraction} The following procedures are copies of corresponding procedures in [[cascades]], which only have been adapted to the new types used in this module.\\ Extract the resonance set from a valid [[kingraph]] which is kept in the final grove list. <>= procedure :: extract_resonance_history => kingraph_extract_resonance_history <>= subroutine kingraph_extract_resonance_history & (kingraph, res_hist, model, n_out) class(kingraph_t), intent(in), target :: kingraph type(resonance_history_t), intent(out) :: res_hist class(model_data_t), intent(in), target :: model integer, intent(in) :: n_out type(resonance_info_t) :: resonance integer :: i, mom_id, pdg call msg_debug2 (D_PHASESPACE, "kingraph_extract_resonance_history") if (kingraph%grove_prop%n_resonances > 0) then if (associated (kingraph%root%daughter1) .or. & associated (kingraph%root%daughter2)) then call msg_debug2 (D_PHASESPACE, "kingraph has resonances, root has children") do i = 1, kingraph%tree%n_entries if (kingraph%tree%mapping(i) == S_CHANNEL) then mom_id = kingraph%tree%bc (i) pdg = kingraph%tree%pdg (i) call resonance%init (mom_id, pdg, model, n_out) if (debug2_active (D_PHASESPACE)) then print *, 'D: Adding resonance' call resonance%write () end if call res_hist%add_resonance (resonance) end if end do end if end if end subroutine kingraph_extract_resonance_history @ %def kingraph_extract_resonance_history @ Determine the number of valid [[kingraphs]] in [[grove_list]]. <>= public :: grove_list_get_n_trees <>= function grove_list_get_n_trees (grove_list) result (n) class (grove_list_t), intent (in) :: grove_list integer :: n type(kingraph_t), pointer :: kingraph type(grove_t), pointer :: grove call msg_debug (D_PHASESPACE, "grove_list_get_n_trees") n = 0 grove => grove_list%first do while (associated (grove)) kingraph => grove%first do while (associated (kingraph)) if (kingraph%keep) n = n + 1 kingraph => kingraph%grove_next enddo grove => grove%next enddo call msg_debug (D_PHASESPACE, "n", n) end function grove_list_get_n_trees @ %def grove_list_get_n_trees @ Extract the resonance histories from the [[feyngraph_set]], in complete analogy to [[cascade_set_get_resonance_histories]] <>= public :: feyngraph_set_get_resonance_histories <>= subroutine feyngraph_set_get_resonance_histories (feyngraph_set, n_filter, res_hists) type(feyngraph_set_t), intent(in), target :: feyngraph_set integer, intent(in), optional :: n_filter type(resonance_history_t), dimension(:), allocatable, intent(out) :: res_hists type(kingraph_t), pointer :: kingraph type(grove_t), pointer :: grove type(resonance_history_t) :: res_hist type(resonance_history_set_t) :: res_hist_set integer :: i_grove call msg_debug (D_PHASESPACE, "grove_list_get_resonance_histories") call res_hist_set%init (n_filter = n_filter) grove => feyngraph_set%grove_list%first i_grove = 0 do while (associated (grove)) i_grove = i_grove + 1 kingraph => grove%first do while (associated (kingraph)) if (kingraph%keep) then call msg_debug2 (D_PHASESPACE, "grove", i_grove) call kingraph%extract_resonance_history & (res_hist, feyngraph_set%model, feyngraph_set%n_out) call res_hist_set%enter (res_hist) end if kingraph => kingraph%grove_next end do end do call res_hist_set%freeze () call res_hist_set%to_array (res_hists) end subroutine feyngraph_set_get_resonance_histories @ %def feyngraph_set_get_resonance_histories <<[[cascades2_ut.f90]]>>= <> module cascades2_ut use unit_tests use cascades2_uti <> <> contains <> end module cascades2_ut @ %def cascades2_ut @ <<[[cascades2_uti.f90]]>>= <> module cascades2_uti <> <> use numeric_utils use cascades2 use flavors use phs_forests, only: phs_parameters_t use model_data <> <> contains <> end module cascades2_uti @ %def cascades2_uti @ API: driver for the unit tests below. <>= public :: cascades2_test <>= subroutine cascades2_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine cascades2_test @ %def cascades2_test @ <>= call test (cascades2_1, "cascades2_1", & "make phase-space", u, results) call test (cascades2_2, "cascades2_2", & "make phase-space (scattering)", u, results) <>= public :: cascades2_1 <>= subroutine cascades2_1 (u) integer, intent(in) :: u type (feyngraph_set_t) :: feyngraph_set type (model_data_t) :: model integer :: n_in = 1 integer :: n_out = 6 type(flavor_t), dimension(7,1) :: flv type (phs_parameters_t) :: phs_par logical :: fatal_beam_decay = .true. integer :: u_in = 8 write (u, "(A)") "* Test output: cascades2_1" write (u, "(A)") "* Purpose: create a test phs file (decay) with the forest" write (u, "(A)") "* output of O'Mega" write (u, "(A)") write (u, "(A)") "* Initializing" write (u, "(A)") call init_sm_full_test (model) call flv(1,1)%init (6, model) call flv(2,1)%init (5, model) call flv(3,1)%init (-11, model) call flv(4,1)%init (12, model) call flv(5,1)%init (21, model) call flv(6,1)%init (22, model) call flv(7,1)%init (21, model) phs_par%sqrts = 173.1_default phs_par%m_threshold_s = 50._default phs_par%m_threshold_t = 100._default phs_par%keep_nonresonant = .true. phs_par%off_shell = 2 open (unit=u_in, file="cascades2_1.fds", status='old', action='read') write (u, "(A)") write (u, "(A)") "* Generating phase-space parametrizations" write (u, "(A)") call feyngraph_set_generate (feyngraph_set, model, n_in, n_out, & flv, phs_par, fatal_beam_decay, u_in, use_dag = .false., & vis_channels = .false.) call feyngraph_set_write_process_bincode_format (feyngraph_set, u) call feyngraph_set_write_file_format (feyngraph_set, u) write (u, "(A)") "* Cleanup" write (u, "(A)") close (u_in) call feyngraph_set%final () call model%final () write (u, *) write (u, "(A)") "* Test output end: cascades2_1" end subroutine cascades2_1 @ %def cascades2_1 @ <>= public :: cascades2_2 <>= subroutine cascades2_2 (u) integer, intent(in) :: u type (feyngraph_set_t) :: feyngraph_set type (model_data_t) :: model integer :: n_in = 2 integer :: n_out = 5 type(flavor_t), dimension(7,1) :: flv type (phs_parameters_t) :: phs_par logical :: fatal_beam_decay = .true. integer :: u_in = 8 write (u, "(A)") "* Test output: cascades2_2" write (u, "(A)") "* Purpose: create a test phs file (scattering) with the" write (u, "(A)") "* parsable DAG output of O'Mega" write (u, "(A)") write (u, "(A)") "* Initializing" write (u, "(A)") call init_sm_full_test (model) call flv(1,1)%init (-11, model) call flv(2,1)%init (11, model) call flv(3,1)%init (-11, model) call flv(4,1)%init (12, model) call flv(5,1)%init (1, model) call flv(6,1)%init (-2, model) call flv(7,1)%init (22, model) phs_par%sqrts = 500._default phs_par%m_threshold_s = 50._default phs_par%m_threshold_t = 100._default phs_par%keep_nonresonant = .true. phs_par%off_shell = 2 phs_par%t_channel = 6 open (unit=u_in, file="cascades2_2.fds", & status='old', action='read') write (u, "(A)") write (u, "(A)") "* Generating phase-space parametrizations" write (u, "(A)") call feyngraph_set_generate (feyngraph_set, model, n_in, n_out, & flv, phs_par, fatal_beam_decay, u_in, use_dag = .true., & vis_channels = .false.) call feyngraph_set_write_process_bincode_format (feyngraph_set, u) call feyngraph_set_write_file_format (feyngraph_set, u) write (u, "(A)") "* Cleanup" write (u, "(A)") close (u_in) call feyngraph_set%final () call model%final () write (u, *) write (u, "(A)") "* Test output end: cascades2_2" end subroutine cascades2_2 @ %def cascades2_2 Index: trunk/src/process_integration/process_integration.nw =================================================================== --- trunk/src/process_integration/process_integration.nw (revision 8224) +++ trunk/src/process_integration/process_integration.nw (revision 8225) @@ -1,19156 +1,19157 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: integration and process objects and such %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Integration and Process Objects} \includemodulegraph{process_integration} This is the central part of the \whizard\ package. It provides the functionality for evaluating structure functions, kinematics and matrix elements, integration and event generation. It combines the various parts that deal with those tasks individually and organizes the data transfer between them. \begin{description} \item[subevt\_expr] This enables process observables as (abstract) expressions, to be evaluated for each process call. \item[parton\_states] A [[parton_state_t]] object represents an elementary partonic interaction. There are two versions: one for the isolated elementary process, one for the elementary process convoluted with the structure-function chain. The parton state is an effective state. It needs not coincide with the seed-kinematics state which is used in evaluating phase space. \item[process] Here, all pieces are combined for the purpose of evaluating the elementary processes. The whole algorithm is coded in terms of abstract data types as defined in the appropriate modules: [[prc_core]] for matrix-element evaluation, [[prc_core_def]] for the associated configuration and driver, [[sf_base]] for beams and structure-functions, [[phs_base]] for phase space, and [[mci_base]] for integration and event generation. \item[process\_config] \item[process\_counter] Very simple object for statistics \item[process\_mci] \item[pcm] \item[kinematics] \item[instances] While the above modules set up all static information, the instances have the changing event data. There are term and process instances but no component instances. \item[process\_stacks] Process stacks collect process objects. \end{description} We combine here hard interactions, phase space, and (for scatterings) structure functions and interfaces them to the integration module. The process object implements the combination of a fixed beam and structure-function setup with a number of elementary processes. The latter are called process components. The process object represents an entity which is supposedly observable. It should be meaningful to talk about the cross section of a process. The individual components of a process are, technically, processes themselves, but they may have unphysical cross sections which have to be added for a physical result. Process components may be exclusive tree-level elementary processes, dipole subtraction term, loop corrections, etc. The beam and structure function setup is common to all process components. Thus, there is only one instance of this part. The process may be a scattering process or a decay process. In the latter case, there are no structure functions, and the beam setup consists of a single particle. Otherwise, the two classes are treated on the same footing. Once a sampling point has been chosen, a process determines a set of partons with a correlated density matrix of quantum numbers. In general, each sampling point will generate, for each process component, one or more distinct parton configurations. This is the [[computed]] state. The computed state is the subject of the multi-channel integration algorithm. For NLO computations, it is necessary to project the computed states onto another set of parton configurations (e.g., by recombining certain pairs). This is the [[observed]] state. When computing partonic observables, the information is taken from the observed state. For the purpose of event generation, we will later select one parton configuration from the observed state and collapse the correlated quantum state. This configuration is then dressed by applying parton shower, decays and hadronization. The decay chain, in particular, combines a scattering process with possible subsequent decay processes on the parton level, which are full-fledged process objects themselves. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Process observables} We define an abstract [[subevt_expr_t]] object as an extension of the [[subevt_t]] type. The object contains a local variable list, variable instances (as targets for pointers in the variable list), and evaluation trees. The evaluation trees reference both the variables and the [[subevt]]. There are two instances of the abstract type: one for process instances, one for physical events. Both have a common logical expression [[selection]] which determines whether the object passes user-defined cuts. The intention is that we fill the [[subevt_t]] base object and compute the variables once we have evaluated a kinematical phase space point (or a complete event). We then evaluate the expressions and can use the results in further calculations. The [[process_expr_t]] extension contains furthermore scale and weight expressions. The [[event_expr_t]] extension contains a reweighting-factor expression and a logical expression for event analysis. In practice, we will link the variable list of the [[event_obs]] object to the variable list of the currently active [[process_obs]] object, such that the process variables are available to both objects. Event variables are meaningful only for physical events. Note that there are unit tests, but they are deferred to the [[expr_tests]] module. <<[[subevt_expr.f90]]>>= <> module subevt_expr <> <> use constants, only: zero, one use io_units use format_utils, only: write_separator use diagnostics use lorentz use subevents use variables use flavors use quantum_numbers use interactions use particles use expr_base <> <> <> <> contains <> end module subevt_expr @ %def subevt_expr @ \subsection{Abstract base type} <>= type, extends (subevt_t), abstract :: subevt_expr_t logical :: subevt_filled = .false. type(var_list_t) :: var_list real(default) :: sqrts_hat = 0 integer :: n_in = 0 integer :: n_out = 0 integer :: n_tot = 0 logical :: has_selection = .false. class(expr_t), allocatable :: selection logical :: colorize_subevt = .false. contains <> end type subevt_expr_t @ %def subevt_expr_t @ Output: Base and extended version. We already have a [[write]] routine for the [[subevt_t]] parent type. <>= procedure :: base_write => subevt_expr_write <>= subroutine subevt_expr_write (object, unit, pacified) class(subevt_expr_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacified integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Local variables:" call write_separator (u) call var_list_write (object%var_list, u, follow_link=.false., & pacified = pacified) call write_separator (u) if (object%subevt_filled) then call object%subevt_t%write (u, pacified = pacified) if (object%has_selection) then call write_separator (u) write (u, "(1x,A)") "Selection expression:" call write_separator (u) call object%selection%write (u) end if else write (u, "(1x,A)") "subevt: [undefined]" end if end subroutine subevt_expr_write @ %def subevt_expr_write @ Finalizer. <>= procedure (subevt_expr_final), deferred :: final procedure :: base_final => subevt_expr_final <>= subroutine subevt_expr_final (object) class(subevt_expr_t), intent(inout) :: object call object%var_list%final () if (object%has_selection) then call object%selection%final () end if end subroutine subevt_expr_final @ %def subevt_expr_final @ \subsection{Initialization} Initialization: define local variables and establish pointers. The common variables are [[sqrts]] (the nominal beam energy, fixed), [[sqrts_hat]] (the actual energy), [[n_in]], [[n_out]], and [[n_tot]] for the [[subevt]]. With the exception of [[sqrts]], all are implemented as pointers to subobjects. <>= procedure (subevt_expr_setup_vars), deferred :: setup_vars procedure :: base_setup_vars => subevt_expr_setup_vars <>= subroutine subevt_expr_setup_vars (expr, sqrts) class(subevt_expr_t), intent(inout), target :: expr real(default), intent(in) :: sqrts call expr%var_list%final () call var_list_append_real (expr%var_list, & var_str ("sqrts"), sqrts, & locked = .true., verbose = .false., intrinsic = .true.) call var_list_append_real_ptr (expr%var_list, & var_str ("sqrts_hat"), expr%sqrts_hat, & is_known = expr%subevt_filled, & locked = .true., verbose = .false., intrinsic = .true.) call var_list_append_int_ptr (expr%var_list, & var_str ("n_in"), expr%n_in, & is_known = expr%subevt_filled, & locked = .true., verbose = .false., intrinsic = .true.) call var_list_append_int_ptr (expr%var_list, & var_str ("n_out"), expr%n_out, & is_known = expr%subevt_filled, & locked = .true., verbose = .false., intrinsic = .true.) call var_list_append_int_ptr (expr%var_list, & var_str ("n_tot"), expr%n_tot, & is_known = expr%subevt_filled, & locked = .true., verbose = .false., intrinsic = .true.) end subroutine subevt_expr_setup_vars @ %def subevt_expr_setup_vars @ Append the subevent expr (its base-type core) itself to the variable list, if it is not yet present. <>= procedure :: setup_var_self => subevt_expr_setup_var_self <>= subroutine subevt_expr_setup_var_self (expr) class(subevt_expr_t), intent(inout), target :: expr if (.not. expr%var_list%contains (var_str ("@evt"))) then call var_list_append_subevt_ptr & (expr%var_list, & var_str ("@evt"), expr%subevt_t, & is_known = expr%subevt_filled, & locked = .true., verbose = .false., intrinsic=.true.) end if end subroutine subevt_expr_setup_var_self @ %def subevt_expr_setup_var_self @ Link a variable list to the local one. This could be done event by event, but before evaluating expressions. <>= procedure :: link_var_list => subevt_expr_link_var_list <>= subroutine subevt_expr_link_var_list (expr, var_list) class(subevt_expr_t), intent(inout) :: expr type(var_list_t), intent(in), target :: var_list call expr%var_list%link (var_list) end subroutine subevt_expr_link_var_list @ %def subevt_expr_link_var_list @ Compile the selection expression. If there is no expression, the build method won't 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 subevt_set_pdg_beam (expr%subevt_t, f_beam%get_pdg ()) call subevt_set_pdg_incoming (expr%subevt_t, f_in%get_pdg ()) call subevt_set_pdg_outgoing (expr%subevt_t, f_out%get_pdg ()) call subevt_set_p2_beam (expr%subevt_t, f_beam%get_mass () ** 2) call subevt_set_p2_incoming (expr%subevt_t, f_in%get_mass () ** 2) call subevt_set_p2_outgoing (expr%subevt_t, 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 (subevt, 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 (subevt, 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 (subevt, 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 (subevt, - int%get_momenta (j_beam)) call subevt_set_p_incoming (subevt, - int%get_momenta (j_in)) call subevt_set_p_outgoing (subevt, 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 & (subevt, - lt * int%get_momenta (j_beam)) call subevt_set_p_incoming & (subevt, - lt * int%get_momenta (j_in)) call subevt_set_p_outgoing & (subevt, 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 = subevt_get_sqrts_hat (expr%subevt_t) 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), intent(out) :: fac_scale real(default), 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 (force_scale) then fac_scale = scale_forced else if (expr%has_fac_scale) then call expr%fac_scale%evaluate () if (expr%fac_scale%is_known ()) then fac_scale = expr%fac_scale%get_real () else call msg_error ("Evaluate factorization scale expression: & &result undefined") fac_scale = zero end if else fac_scale = scale end if if (force_scale) then ren_scale = scale_forced else if (expr%has_ren_scale) then call expr%ren_scale%evaluate () if (expr%ren_scale%is_known ()) then ren_scale = expr%ren_scale%get_real () else call msg_error ("Evaluate renormalization scale expression: & &result undefined") ren_scale = zero end if else ren_scale = scale end if if (expr%has_weight) then call expr%weight%evaluate () if (expr%weight%is_known ()) then weight = expr%weight%get_real () else call msg_error ("Evaluate weight expression: result undefined") weight = zero end if else weight = one end if else weight = zero end if end subroutine parton_expr_evaluate @ %def parton_expr_evaluate @ Return the beam/incoming parton indices. <>= procedure :: get_beam_index => parton_expr_get_beam_index procedure :: get_in_index => parton_expr_get_in_index <>= subroutine parton_expr_get_beam_index (expr, i_beam) class(parton_expr_t), intent(in) :: expr integer, dimension(:), intent(out) :: i_beam i_beam = expr%i_beam end subroutine parton_expr_get_beam_index subroutine parton_expr_get_in_index (expr, i_in) class(parton_expr_t), intent(in) :: expr integer, dimension(:), intent(out) :: i_in i_in = expr%i_in end subroutine parton_expr_get_in_index @ %def parton_expr_get_beam_index @ %def parton_expr_get_in_index @ \subsection{Implementation for full events} This implementation contains the expressions that we can evaluate for the full event. It also contains data that pertain to the event, suitable for communication with external event formats. These data simultaneously serve as pointer targets for the variable lists hidden in the expressions (eval trees). Squared matrix element and weight values: when reading events from file, the [[ref]] value is the number in the file, while the [[prc]] value is the number that we calculate from the momenta in the file, possibly with different parameters. When generating events the first time, or if we do not recalculate, the numbers should coincide. Furthermore, the array of [[alt]] values is copied from an array of alternative event records. These values should represent calculated values. <>= public :: event_expr_t <>= type, extends (subevt_expr_t) :: event_expr_t logical :: has_reweight = .false. logical :: has_analysis = .false. class(expr_t), allocatable :: reweight class(expr_t), allocatable :: analysis logical :: has_id = .false. type(string_t) :: id logical :: has_num_id = .false. integer :: num_id = 0 logical :: has_index = .false. integer :: index = 0 logical :: has_sqme_ref = .false. real(default) :: sqme_ref = 0 logical :: has_sqme_prc = .false. real(default) :: sqme_prc = 0 logical :: has_weight_ref = .false. real(default) :: weight_ref = 0 logical :: has_weight_prc = .false. real(default) :: weight_prc = 0 logical :: has_excess_prc = .false. real(default) :: excess_prc = 0 integer :: n_alt = 0 logical :: has_sqme_alt = .false. real(default), dimension(:), allocatable :: sqme_alt logical :: has_weight_alt = .false. real(default), dimension(:), allocatable :: weight_alt contains <> end type event_expr_t @ %def event_expr_t @ Finalizer for the expressions. <>= procedure :: final => event_expr_final <>= subroutine event_expr_final (object) class(event_expr_t), intent(inout) :: object call object%base_final () if (object%has_reweight) then call object%reweight%final () end if if (object%has_analysis) then call object%analysis%final () end if end subroutine event_expr_final @ %def event_expr_final @ Output: continue writing the active expressions, after the common selection expression. Note: the [[prefix]] argument is declared in the [[write]] method of the [[subevt_t]] base type. Here, it is unused. <>= procedure :: write => event_expr_write <>= subroutine event_expr_write (object, unit, prefix, pacified) class(event_expr_t), intent(in) :: object integer, intent(in), optional :: unit character(*), intent(in), optional :: prefix logical, intent(in), optional :: pacified integer :: u u = given_output_unit (unit) call object%base_write (u, pacified = pacified) if (object%subevt_filled) then if (object%has_reweight) then call write_separator (u) write (u, "(1x,A)") "Reweighting expression:" call write_separator (u) call object%reweight%write (u) end if if (object%has_analysis) then call write_separator (u) write (u, "(1x,A)") "Analysis expression:" call write_separator (u) call object%analysis%write (u) end if end if end subroutine event_expr_write @ %def event_expr_write @ Initializer. This is required only for the [[sqme_alt]] and [[weight_alt]] arrays. <>= procedure :: init => event_expr_init <>= subroutine event_expr_init (expr, n_alt) class(event_expr_t), intent(out) :: expr integer, intent(in), optional :: n_alt if (present (n_alt)) then expr%n_alt = n_alt allocate (expr%sqme_alt (n_alt), source = 0._default) allocate (expr%weight_alt (n_alt), source = 0._default) end if end subroutine event_expr_init @ %def event_expr_init @ Define variables. We have the variables of the base type plus specific variables for full events. There is the event index. <>= procedure :: setup_vars => event_expr_setup_vars <>= subroutine event_expr_setup_vars (expr, sqrts) class(event_expr_t), intent(inout), target :: expr real(default), intent(in) :: sqrts call expr%base_setup_vars (sqrts) call var_list_append_string_ptr (expr%var_list, & var_str ("$process_id"), expr%id, & is_known = expr%has_id, & locked = .true., verbose = .false., intrinsic = .true.) call var_list_append_int_ptr (expr%var_list, & var_str ("process_num_id"), expr%num_id, & is_known = expr%has_num_id, & locked = .true., verbose = .false., intrinsic = .true.) call var_list_append_real_ptr (expr%var_list, & var_str ("sqme"), expr%sqme_prc, & is_known = expr%has_sqme_prc, & locked = .true., verbose = .false., intrinsic = .true.) call var_list_append_real_ptr (expr%var_list, & var_str ("sqme_ref"), expr%sqme_ref, & is_known = expr%has_sqme_ref, & locked = .true., verbose = .false., intrinsic = .true.) call var_list_append_int_ptr (expr%var_list, & var_str ("event_index"), expr%index, & is_known = expr%has_index, & locked = .true., verbose = .false., intrinsic = .true.) call var_list_append_real_ptr (expr%var_list, & var_str ("event_weight"), expr%weight_prc, & is_known = expr%has_weight_prc, & locked = .true., verbose = .false., intrinsic = .true.) call var_list_append_real_ptr (expr%var_list, & var_str ("event_weight_ref"), expr%weight_ref, & is_known = expr%has_weight_ref, & locked = .true., verbose = .false., intrinsic = .true.) call var_list_append_real_ptr (expr%var_list, & var_str ("event_excess"), expr%excess_prc, & is_known = expr%has_excess_prc, & locked = .true., verbose = .false., intrinsic = .true.) end subroutine event_expr_setup_vars @ %def event_expr_setup_vars @ Compile the analysis expression. If the pointer is disassociated, there is no expression. <>= procedure :: setup_analysis => event_expr_setup_analysis <>= subroutine event_expr_setup_analysis (expr, ef_analysis) class(event_expr_t), intent(inout), target :: expr class(expr_factory_t), intent(in) :: ef_analysis call ef_analysis%build (expr%analysis) if (allocated (expr%analysis)) then call expr%setup_var_self () call expr%analysis%setup_lexpr (expr%var_list) expr%has_analysis = .true. end if end subroutine event_expr_setup_analysis @ %def event_expr_setup_analysis @ Compile the reweight expression. <>= procedure :: setup_reweight => event_expr_setup_reweight <>= subroutine event_expr_setup_reweight (expr, ef_reweight) class(event_expr_t), intent(inout), target :: expr class(expr_factory_t), intent(in) :: ef_reweight call ef_reweight%build (expr%reweight) if (allocated (expr%reweight)) then call expr%setup_var_self () call expr%reweight%setup_expr (expr%var_list) expr%has_reweight = .true. end if end subroutine event_expr_setup_reweight @ %def event_expr_setup_reweight @ Store the string or numeric process ID. This should be done during initialization. <>= procedure :: set_process_id => event_expr_set_process_id procedure :: set_process_num_id => event_expr_set_process_num_id <>= subroutine event_expr_set_process_id (expr, id) class(event_expr_t), intent(inout) :: expr type(string_t), intent(in) :: id expr%id = id expr%has_id = .true. end subroutine event_expr_set_process_id subroutine event_expr_set_process_num_id (expr, num_id) class(event_expr_t), intent(inout) :: expr integer, intent(in) :: num_id expr%num_id = num_id expr%has_num_id = .true. end subroutine event_expr_set_process_num_id @ %def event_expr_set_process_id @ %def event_expr_set_process_num_id @ Reset / set the data that pertain to a particular event. The event index is reset unless explicitly told to keep it. <>= procedure :: reset_contents => event_expr_reset_contents procedure :: set => event_expr_set <>= subroutine event_expr_reset_contents (expr) class(event_expr_t), intent(inout) :: expr call expr%base_reset_contents () expr%has_sqme_ref = .false. expr%has_sqme_prc = .false. expr%has_sqme_alt = .false. expr%has_weight_ref = .false. expr%has_weight_prc = .false. expr%has_weight_alt = .false. expr%has_excess_prc = .false. end subroutine event_expr_reset_contents subroutine event_expr_set (expr, & weight_ref, weight_prc, weight_alt, & excess_prc, & sqme_ref, sqme_prc, sqme_alt) class(event_expr_t), intent(inout) :: expr real(default), intent(in), optional :: weight_ref, weight_prc real(default), intent(in), optional :: excess_prc real(default), intent(in), optional :: sqme_ref, sqme_prc real(default), dimension(:), intent(in), optional :: sqme_alt, weight_alt if (present (sqme_ref)) then expr%has_sqme_ref = .true. expr%sqme_ref = sqme_ref end if if (present (sqme_prc)) then expr%has_sqme_prc = .true. expr%sqme_prc = sqme_prc end if if (present (sqme_alt)) then expr%has_sqme_alt = .true. expr%sqme_alt = sqme_alt end if if (present (weight_ref)) then expr%has_weight_ref = .true. expr%weight_ref = weight_ref end if if (present (weight_prc)) then expr%has_weight_prc = .true. expr%weight_prc = weight_prc end if if (present (weight_alt)) then expr%has_weight_alt = .true. expr%weight_alt = weight_alt end if if (present (excess_prc)) then expr%has_excess_prc = .true. expr%excess_prc = excess_prc end if end subroutine event_expr_set @ %def event_expr_reset_contents event_expr_set @ Access the subevent index. <>= procedure :: has_event_index => event_expr_has_event_index procedure :: get_event_index => event_expr_get_event_index <>= function event_expr_has_event_index (expr) result (flag) class(event_expr_t), intent(in) :: expr logical :: flag flag = expr%has_index end function event_expr_has_event_index function event_expr_get_event_index (expr) result (index) class(event_expr_t), intent(in) :: expr integer :: index if (expr%has_index) then index = expr%index else index = 0 end if end function event_expr_get_event_index @ %def event_expr_has_event_index @ %def event_expr_get_event_index @ Set/increment the subevent index. Initialize it if necessary. <>= procedure :: set_event_index => event_expr_set_event_index procedure :: reset_event_index => event_expr_reset_event_index procedure :: increment_event_index => event_expr_increment_event_index <>= subroutine event_expr_set_event_index (expr, index) class(event_expr_t), intent(inout) :: expr integer, intent(in) :: index expr%index = index expr%has_index = .true. end subroutine event_expr_set_event_index subroutine event_expr_reset_event_index (expr) class(event_expr_t), intent(inout) :: expr expr%has_index = .false. end subroutine event_expr_reset_event_index subroutine event_expr_increment_event_index (expr, offset) class(event_expr_t), intent(inout) :: expr integer, intent(in), optional :: offset if (expr%has_index) then expr%index = expr%index + 1 else if (present (offset)) then call expr%set_event_index (offset + 1) else call expr%set_event_index (1) end if end subroutine event_expr_increment_event_index @ %def event_expr_set_event_index @ %def event_expr_increment_event_index @ Fill the event expression: take the particle data and kinematics from a [[particle_set]] object. We allow the particle content to change for each event. Therefore, we set the event variables each time. Also increment the event index; initialize it if necessary. <>= procedure :: fill_subevt => event_expr_fill_subevt <>= subroutine event_expr_fill_subevt (expr, particle_set) class(event_expr_t), intent(inout) :: expr type(particle_set_t), intent(in) :: particle_set call particle_set%to_subevt (expr%subevt_t, expr%colorize_subevt) expr%sqrts_hat = subevt_get_sqrts_hat (expr%subevt_t) expr%n_in = subevt_get_n_in (expr%subevt_t) expr%n_out = subevt_get_n_out (expr%subevt_t) 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. However, this causes memory corruption in gfortran 4.6.3. 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 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 fore 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 @ Setup 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 @ Setup 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} Setup 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. <>= procedure :: setup_connected_trace => connected_state_setup_connected_trace <>= subroutine connected_state_setup_connected_trace & (state, isolated, int, resonant, undo_helicities, & keep_fs_flavors, 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 :: extended_sf type(quantum_numbers_mask_t) :: mask type(interaction_t), pointer :: src_int, beam_int logical :: reduce, fs_flv_flag 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 = 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 @ Setup 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 @ Setup 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. <>= procedure :: setup_connected_flows => connected_state_setup_connected_flows <>= subroutine connected_state_setup_connected_flows & (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., .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 end if call state%flows%init_product (src_int, isolated%flows, mask, & qn_filter_conn = qn_filter_conn, & connections_are_resonant = resonant) state%has_flows = .true. end subroutine connected_state_setup_connected_flows @ %def connected_state_setup_connected_flows @ Determine and store the flavor content for the connected state. This queries the [[matrix]] evaluator component, which should hold the requested flavor information. <>= procedure :: setup_state_flv => connected_state_setup_state_flv <>= subroutine connected_state_setup_state_flv (state, n_out_hard) class(connected_state_t), intent(inout), target :: state integer, intent(in) :: n_out_hard call interaction_get_flv_content & (state%matrix%interaction_t, state%state_flv, n_out_hard) end subroutine connected_state_setup_state_flv @ %def connected_state_setup_state_flv @ Return the current flavor state object. <>= procedure :: get_state_flv => connected_state_get_state_flv <>= function connected_state_get_state_flv (state) result (state_flv) class(connected_state_t), intent(in) :: state type(state_flv_content_t) :: state_flv state_flv = state%state_flv end function connected_state_get_state_flv @ %def connected_state_get_state_flv @ \subsection{Cuts and expressions} Set up the [[subevt]] that corresponds to the connected interaction. The index arrays refer to the interaction. We assign the particles as follows: the beam particles are the first two (decay process: one) entries in the trace evaluator. The incoming partons are identified by their link to the outgoing partons of the structure-function chain. The outgoing partons are those of the trace evaluator, which include radiated partons during the structure-function chain. <>= procedure :: setup_subevt => connected_state_setup_subevt <>= subroutine connected_state_setup_subevt (state, sf_chain, f_beam, f_in, f_out) class(connected_state_t), intent(inout), target :: state type(sf_chain_instance_t), intent(in), target :: sf_chain type(flavor_t), dimension(:), intent(in) :: f_beam, f_in, f_out integer :: n_beam, n_in, n_out, n_vir, n_tot, i, j integer, dimension(:), allocatable :: i_beam, i_in, i_out integer :: sf_out_i type(interaction_t), pointer :: sf_int sf_int => sf_chain%get_out_int_ptr () n_beam = size (f_beam) n_in = size (f_in) n_out = size (f_out) n_vir = state%trace%get_n_vir () n_tot = state%trace%get_n_tot () allocate (i_beam (n_beam), i_in (n_in), i_out (n_out)) i_beam = [(i, i = 1, n_beam)] do j = 1, n_in sf_out_i = sf_chain%get_out_i (j) i_in(j) = interaction_find_link & (state%trace%interaction_t, sf_int, sf_out_i) end do i_out = [(i, i = n_vir + 1, n_tot)] call state%expr%setup_subevt (state%trace%interaction_t, & i_beam, i_in, i_out, f_beam, f_in, f_out) state%has_expr = .true. end subroutine connected_state_setup_subevt @ %def connected_state_setup_subevt @ Initialize the variable list specific for this state/term. We insert event variables ([[sqrts_hat]]) and link the process variable list. The variable list acquires pointers to subobjects of [[state]], which must therefore have a [[target]] attribute. <>= procedure :: setup_var_list => connected_state_setup_var_list <>= subroutine connected_state_setup_var_list (state, process_var_list, beam_data) class(connected_state_t), intent(inout), target :: state type(var_list_t), intent(in), target :: process_var_list type(beam_data_t), intent(in) :: beam_data call state%expr%setup_vars (beam_data%get_sqrts ()) call state%expr%link_var_list (process_var_list) end subroutine connected_state_setup_var_list @ %def connected_state_setup_var_list @ Allocate the cut expression etc. <>= procedure :: setup_cuts => connected_state_setup_cuts procedure :: setup_scale => connected_state_setup_scale procedure :: setup_fac_scale => connected_state_setup_fac_scale procedure :: setup_ren_scale => connected_state_setup_ren_scale procedure :: setup_weight => connected_state_setup_weight <>= subroutine connected_state_setup_cuts (state, ef_cuts) class(connected_state_t), intent(inout), target :: state class(expr_factory_t), intent(in) :: ef_cuts call state%expr%setup_selection (ef_cuts) end subroutine connected_state_setup_cuts subroutine connected_state_setup_scale (state, ef_scale) class(connected_state_t), intent(inout), target :: state class(expr_factory_t), intent(in) :: ef_scale call state%expr%setup_scale (ef_scale) end subroutine connected_state_setup_scale subroutine connected_state_setup_fac_scale (state, ef_fac_scale) class(connected_state_t), intent(inout), target :: state class(expr_factory_t), intent(in) :: ef_fac_scale call state%expr%setup_fac_scale (ef_fac_scale) end subroutine connected_state_setup_fac_scale subroutine connected_state_setup_ren_scale (state, ef_ren_scale) class(connected_state_t), intent(inout), target :: state class(expr_factory_t), intent(in) :: ef_ren_scale call state%expr%setup_ren_scale (ef_ren_scale) end subroutine connected_state_setup_ren_scale subroutine connected_state_setup_weight (state, ef_weight) class(connected_state_t), intent(inout), target :: state class(expr_factory_t), intent(in) :: ef_weight call state%expr%setup_weight (ef_weight) end subroutine connected_state_setup_weight @ %def connected_state_setup_expressions @ Reset the expression object: invalidate the subevt. <>= procedure :: reset_expressions => connected_state_reset_expressions <>= subroutine connected_state_reset_expressions (state) class(connected_state_t), intent(inout) :: state if (state%has_expr) call state%expr%reset_contents () end subroutine connected_state_reset_expressions @ %def connected_state_reset_expressions @ \subsection{Evaluation} Transfer momenta to the trace evaluator and fill the [[subevt]] with this effective kinematics, if applicable. Note: we may want to apply a boost for the [[subevt]]. <>= procedure :: receive_kinematics => parton_state_receive_kinematics <>= subroutine parton_state_receive_kinematics (state) class(parton_state_t), intent(inout), target :: state if (state%has_trace) then call state%trace%receive_momenta () select type (state) class is (connected_state_t) if (state%has_expr) then call state%expr%fill_subevt (state%trace%interaction_t) end if end select end if end subroutine parton_state_receive_kinematics @ %def parton_state_receive_kinematics @ Recover kinematics: We assume that the trace evaluator is filled with momenta. Send those momenta back to the sources, then fill the variables and subevent as above. The incoming momenta of the connected state are not connected to the isolated state but to the beam interaction. Therefore, the incoming momenta within the isolated state do not become defined, yet. Instead, we reconstruct the beam (and ISR) momentum configuration. <>= procedure :: send_kinematics => parton_state_send_kinematics <>= subroutine parton_state_send_kinematics (state) class(parton_state_t), intent(inout), target :: state if (state%has_trace) then call interaction_send_momenta (state%trace%interaction_t) 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, fac_scale, ren_scale, weight 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 !!! Don't 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} This object may hold process and method-specific data, and it should allocate the corresponding manager instance. The number of components determines the [[component_selected]] array. [[i_phs_config]] is a lookup table that returns the PHS configuration index for a given component index. [[i_core]] is a lookup table that returns the core-entry 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_instance), deferred :: allocate_instance <>= abstract interface subroutine pcm_allocate_instance (pcm, instance) import class(pcm_t), intent(in) :: pcm class(pcm_instance_t), intent(inout), allocatable :: instance end subroutine pcm_allocate_instance end interface @ %def pcm_allocate_instance @ <>= 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(in) :: 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 instance} This object deals with the actual (squared) matrix element values. <>= public :: pcm_instance_t <>= type, abstract :: pcm_instance_t class(pcm_t), pointer :: config => null () logical :: bad_point = .false. contains <> end type pcm_instance_t @ %def pcm_instance_t @ <>= procedure(pcm_instance_final), deferred :: final <>= abstract interface subroutine pcm_instance_final (pcm_instance) import class(pcm_instance_t), intent(inout) :: pcm_instance end subroutine pcm_instance_final end interface @ %def pcm_instance_final @ <>= procedure :: link_config => pcm_instance_link_config <>= subroutine pcm_instance_link_config (pcm_instance, config) class(pcm_instance_t), intent(inout) :: pcm_instance class(pcm_t), intent(in), target :: config pcm_instance%config => config end subroutine pcm_instance_link_config @ %def pcm_instance_link_config @ <>= procedure :: is_valid => pcm_instance_is_valid <>= function pcm_instance_is_valid (pcm_instance) result (valid) logical :: valid class(pcm_instance_t), intent(in) :: pcm_instance valid = .not. pcm_instance%bad_point end function pcm_instance_is_valid @ %def pcm_instance_is_valid @ <>= procedure :: set_bad_point => pcm_instance_set_bad_point <>= pure subroutine pcm_instance_set_bad_point (pcm_instance, bad_point) class(pcm_instance_t), intent(inout) :: pcm_instance logical, intent(in) :: bad_point pcm_instance%bad_point = pcm_instance%bad_point .or. bad_point end subroutine pcm_instance_set_bad_point @ %def pcm_instance_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 phs_wood, only: EXTENSION_DEFAULT, EXTENSION_DGLAP 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} A process object is the workspace for the process instance. After initialization, its contents are filled by integration passes which shape the integration grids and compute cross sections. Processes are set up initially from user-level configuration data. After calculating integrals and thus developing integration grid data, the program may use a process object or a copy of it for the purpose of generating events. 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 [[type]] determines whether we are considering a decay or a scattering process. The [[meta]] object describes the process and its environment. All contents become fixed when the object is initialized. The [[config]] object holds physical and technical configuration data that have been obtained during process initialization, and which are common to all process components. The individual process components are configured in the [[component]] objects. These objects contain more configuration parameters and workspace, as needed for the specific process variant. The [[term]] objects describe parton configurations which are technically used as phase-space points. Each process component may split into several terms with distinct kinematics and particle content. Furthermore, each term may project on a different physical state, e.g., by particle recombination. The [[term]] object provides the framework for this projection, for applying cuts, weight, and thus completing the process calculation. The [[beam_config]] object describes the incoming particles, either the decay mother or the scattering beams. It also contains the structure-function information. The [[mci_entry]] objects configure a MC input parameter set and integrator, each. The number of parameters depends on the process component and on the beam and structure-function setup. The [[pcm]] component is the process-component manager. This polymorphic object manages and hides the details of dealing with NLO processes where several components have to be combined in a non-trivial way. It also acts as an abstract factory for the corresponding object in [[process_instance]], which does the actual work for this matter. <>= 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: 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 + 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 (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: 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 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: 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/QED 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(in) :: process integer :: alpha_power, alphas_power integer :: openloops_phs_tolerance, openloops_stability_log logical :: use_cms, use_collier 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, & use_collier, & 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%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")) use_collier = & var_list%get_lval (var_str ("?openloops_use_collier")) 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 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 () 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%n_emitters 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_array_get_length (pdg_in) == 1) .and. & all (pdg_in(1,:) == pdg_in(1,i0)) .and. & all (pdg_in(2,:) == pdg_in(2,i0))) then pdg_scattering = pdg_array_get (pdg_in(:,i0), 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_array_get_length (pdg_in) == 1) & .and. all (pdg_in(1,:) == pdg_in(1,i0))) then pdg_decay = pdg_array_get (pdg_in(:,i0), 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 @ 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 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) select case (component%config%get_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 logical :: requires_dglap_random_number if (combined_integration) then requires_dglap_random_number = any (process%component%get_nlo_type () == NLO_DGLAP) select type (phs_config => component%phs_config) class is (phs_wood_config_t) if (requires_dglap_random_number) then call phs_config%set_extension_mode (EXTENSION_DGLAP) else call phs_config%set_extension_mode (EXTENSION_DEFAULT) end if 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 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.) <>= 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 (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 LO and the NLO result $\iota = I_{LO} / I_{NLO}$. 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 real(default) :: int_born, int_nlo int_nlo = zero int_born = process%mci_entry(1)%get_integral () do i_mci = 2, size (process%mci_entry) if (process%component_can_be_integrated (i_mci)) & int_nlo = int_nlo + process%mci_entry(i_mci)%get_integral () 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 sum_int_nlo = zero; err2 = zero int_born = process%mci_entry(1)%get_integral () err_born = process%mci_entry(1)%get_error () do i_mci = 2, size (process%mci_entry) if (process%component_can_be_integrated (i_mci)) then sum_int_nlo = sum_int_nlo + process%mci_entry(i_mci)%get_integral () err2 = err2 + process%mci_entry(i_mci)%get_error()**2 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_frame => process_lab_is_cm_frame <>= pure function process_lab_is_cm_frame (process) result (cm_frame) logical :: cm_frame class(process_t), intent(in) :: process cm_frame = process%beam_config%lab_is_cm_frame end function process_lab_is_cm_frame @ %def process_lab_is_cm_frame @ <>= 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 :: 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: should not depend explicitly on NLO data. <>= procedure :: get_md5sum_constants => process_get_md5sum_constants <>= function process_get_md5sum_constants (process, i_component, & type_string, nlo_type) result (this_md5sum) character(32) :: this_md5sum class(process_t), intent(in) :: process integer, intent(in) :: i_component type(string_t), intent(in) :: type_string integer, intent(in) :: nlo_type type(process_constants_t) :: data integer :: unit call process%env%fill_process_constants (process%meta%id, i_component, data) unit = data%fill_unit_for_md5sum (.false.) write (unit, '(A)') char(type_string) select case (nlo_type) case (NLO_MISMATCH) write (unit, '(I0)') NLO_SUBTRACTION case default write (unit, '(I0)') nlo_type end select rewind (unit) this_md5sum = md5sum (unit) close (unit) end function process_get_md5sum_constants @ %def process_get_md5sum_constants @ Return the set of outgoing flavors that are associated with a particular term. We deduce this from the effective interaction. <>= procedure :: get_term_flv_out => process_get_term_flv_out <>= subroutine process_get_term_flv_out (process, i_term, flv) class(process_t), intent(in), target :: process integer, intent(in) :: i_term type(flavor_t), dimension(:,:), allocatable, intent(out) :: flv type(interaction_t), pointer :: int int => process%term(i_term)%int_eff if (.not. associated (int)) int => process%term(i_term)%int call interaction_get_flv_out (int, flv) 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 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(2) :: 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 @ Return true if lab and c.m.\ frame coincide for this process. <>= procedure :: cm_frame => process_cm_frame <>= function process_cm_frame (process) result (flag) class(process_t), intent(in), target :: process logical :: flag type(beam_data_t), pointer :: beam_data beam_data => process%beam_config%data flag = beam_data%cm_frame () end function process_cm_frame @ %def process_cm_frame @ 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: 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 :: 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 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 doesn't 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_frame]] 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_frame = .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_frame 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_frame = beam_config%data%cm_frame () 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_frame = beam_config%data%cm_frame () 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, & cm_frame = beam_config%lab_is_cm_frame .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 a 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 \-o -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 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 = 16 * 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 n_sub = n_sub + n_beam_structure_int 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 logical :: combined_integration = .false. integer :: real_partition_type = REAL_FULL integer :: associated_real_component = 0 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 call msg_debug (D_PROCESS_INTEGRATION, "process_mci_entry_create_component_list") if (mci_entry%combined_integration) then n = get_n_components (mci_entry%real_partition_type) allocate (i_list (n)) call msg_debug (D_PROCESS_INTEGRATION, & "mci_entry%real_partition_type", mci_entry%real_partition_type) 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 (damping_type) result (n_components) integer :: n_components integer, intent(in) :: damping_type select case (damping_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 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 @ <>= procedure :: set_associated_real_component & => process_mci_entry_set_associated_real_component <>= subroutine process_mci_entry_set_associated_real_component (mci_entry, i) class(process_mci_entry_t), intent(inout) :: mci_entry integer, intent(in) :: i mci_entry%associated_real_component = i end subroutine process_mci_entry_set_associated_real_component @ %def process_mci_entry_set_associated_real_component @ 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 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_instance => pcm_default_allocate_instance <>= subroutine pcm_default_allocate_instance (pcm, instance) class(pcm_default_t), intent(in) :: pcm class(pcm_instance_t), intent(inout), allocatable :: instance allocate (pcm_instance_default_t :: instance) end subroutine pcm_default_allocate_instance @ %def pcm_default_allocate_instance @ 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_instance_t) :: pcm_instance_default_t contains <> end type pcm_instance_default_t @ %def pcm_instance_default_t @ <>= procedure :: final => pcm_instance_default_final <>= subroutine pcm_instance_default_final (pcm_instance) class(pcm_instance_default_t), intent(inout) :: pcm_instance end subroutine pcm_instance_default_final @ %def pcm_instance_default_final @ \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 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(in) :: 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. 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')) pcm%use_real_partition = & var_list%get_lval (var_str ("?nlo_use_real_partition")) 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: 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: 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 (first_real_component) then pcm%i_phs_config(i) = 2 if (pcm%use_real_partition) first_real_component = .false. else pcm%i_phs_config(i) = 1 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 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 :: i call pcm%handle_threshold_core (core_entry) call pcm%setup_region_data & (core_entry, component(pcm%i_real)%phs_config, model) 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(in) :: 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) 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: 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) 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 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) 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: 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_instance => pcm_nlo_allocate_instance <>= subroutine pcm_nlo_allocate_instance (pcm, instance) class(pcm_nlo_t), intent(in) :: pcm class(pcm_instance_t), intent(inout), allocatable :: instance allocate (pcm_instance_nlo_t :: instance) end subroutine pcm_nlo_allocate_instance @ %def pcm_nlo_allocate_instance @ <>= 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_instance, generator, & sqrts, mode, singular_jacobian) class(pcm_nlo_t), intent(in) :: pcm type(phs_fks_generator_t), intent(inout) :: generator type(pcm_instance_nlo_t), intent(in), target :: pcm_instance 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_instance%isr_kinematics, & pcm_instance%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 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_instance_nlo_t <>= type, extends (pcm_instance_t) :: pcm_instance_nlo_t logical :: use_internal_color_correlation = .true. 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_instance_nlo_t @ %def pcm_instance_nlo_t @ <>= procedure :: set_radiation_event => pcm_instance_nlo_set_radiation_event procedure :: set_subtraction_event => pcm_instance_nlo_set_subtraction_event <>= subroutine pcm_instance_nlo_set_radiation_event (pcm_instance) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance pcm_instance%real_sub%radiation_event = .true. pcm_instance%real_sub%subtraction_event = .false. end subroutine pcm_instance_nlo_set_radiation_event subroutine pcm_instance_nlo_set_subtraction_event (pcm_instance) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance pcm_instance%real_sub%radiation_event = .false. pcm_instance%real_sub%subtraction_event = .true. end subroutine pcm_instance_nlo_set_subtraction_event @ %def pcm_instance_nlo_set_radiation_event @ %def pcm_instance_nlo_set_subtraction_event <>= procedure :: disable_subtraction => pcm_instance_nlo_disable_subtraction <>= subroutine pcm_instance_nlo_disable_subtraction (pcm_instance) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance pcm_instance%real_sub%subtraction_deactivated = .true. end subroutine pcm_instance_nlo_disable_subtraction @ %def pcm_instance_nlo_disable_subtraction @ <>= procedure :: init_config => pcm_instance_nlo_init_config <>= subroutine pcm_instance_nlo_init_config (pcm_instance, active_components, & nlo_types, sqrts, i_real_fin, model) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance logical, intent(in), dimension(:) :: active_components integer, intent(in), dimension(:) :: nlo_types real(default), intent(in) :: sqrts integer, intent(in) :: i_real_fin class(model_data_t), intent(in) :: model integer :: i_component call msg_debug (D_PROCESS_INTEGRATION, "pcm_instance_nlo_init_config") call pcm_instance%init_real_and_isr_kinematics (sqrts) select type (pcm => pcm_instance%config) 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_instance%setup_real_component & (pcm%settings%fks_template%subtraction_disabled) end if case (NLO_VIRTUAL) call pcm_instance%init_virtual (model) case (NLO_MISMATCH) call pcm_instance%init_soft_mismatch () case (NLO_DGLAP) call pcm_instance%init_dglap_remnant () end select end if end do end select end subroutine pcm_instance_nlo_init_config @ %def pcm_instance_nlo_init_config @ <>= procedure :: setup_real_component => pcm_instance_nlo_setup_real_component <>= subroutine pcm_instance_nlo_setup_real_component (pcm_instance, & subtraction_disabled) class(pcm_instance_nlo_t), intent(inout), target :: pcm_instance logical, intent(in) :: subtraction_disabled call pcm_instance%init_real_subtraction () if (subtraction_disabled) call pcm_instance%disable_subtraction () end subroutine pcm_instance_nlo_setup_real_component @ %def pcm_instance_nlo_setup_real_component @ <>= procedure :: init_real_and_isr_kinematics => & pcm_instance_nlo_init_real_and_isr_kinematics <>= subroutine pcm_instance_nlo_init_real_and_isr_kinematics (pcm_instance, sqrts) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance real(default) :: sqrts integer :: n_contr allocate (pcm_instance%real_kinematics) allocate (pcm_instance%isr_kinematics) select type (config => pcm_instance%config) type is (pcm_nlo_t) associate (region_data => config%region_data) if (allocated (region_data%alr_contributors)) then n_contr = size (region_data%alr_contributors) else if (config%settings%factorization_mode == FACTORIZATION_THRESHOLD) then n_contr = 2 else n_contr = 1 end if call pcm_instance%real_kinematics%init & (region_data%n_legs_real, region_data%n_phs, & region_data%n_regions, n_contr) if (config%settings%factorization_mode == FACTORIZATION_THRESHOLD) & call pcm_instance%real_kinematics%init_onshell & (region_data%n_legs_real, region_data%n_phs) pcm_instance%isr_kinematics%n_in = region_data%n_in end associate end select pcm_instance%isr_kinematics%beam_energy = sqrts / two end subroutine pcm_instance_nlo_init_real_and_isr_kinematics @ %def pcm_instance_nlo_init_real_and_isr_kinematics @ <>= procedure :: set_real_and_isr_kinematics => & pcm_instance_nlo_set_real_and_isr_kinematics <>= subroutine pcm_instance_nlo_set_real_and_isr_kinematics (pcm_instance, phs_identifiers, sqrts) class(pcm_instance_nlo_t), intent(inout), target :: pcm_instance type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers real(default), intent(in) :: sqrts call pcm_instance%real_sub%set_real_kinematics & (pcm_instance%real_kinematics) call pcm_instance%real_sub%set_isr_kinematics & (pcm_instance%isr_kinematics) end subroutine pcm_instance_nlo_set_real_and_isr_kinematics @ %def pcm_instance_nlo_set_real_and_isr_kinematics @ <>= procedure :: init_real_subtraction => pcm_instance_nlo_init_real_subtraction <>= subroutine pcm_instance_nlo_init_real_subtraction (pcm_instance) class(pcm_instance_nlo_t), intent(inout), target :: pcm_instance select type (config => pcm_instance%config) type is (pcm_nlo_t) associate (region_data => config%region_data) call pcm_instance%real_sub%init (region_data, config%settings) if (allocated (config%settings%selected_alr)) then associate (selected_alr => config%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_instance%real_sub%selected_alr (size (selected_alr))) pcm_instance%real_sub%selected_alr = selected_alr end if end associate end if end associate end select end subroutine pcm_instance_nlo_init_real_subtraction @ %def pcm_instance_nlo_init_real_subtraction @ <>= procedure :: set_momenta_and_scales_virtual => & pcm_instance_nlo_set_momenta_and_scales_virtual <>= subroutine pcm_instance_nlo_set_momenta_and_scales_virtual (pcm_instance, p, & ren_scale, fac_scale) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance type(vector4_t), intent(in), dimension(:) :: p real(default), intent(in) :: ren_scale, fac_scale select type (config => pcm_instance%config) type is (pcm_nlo_t) associate (virtual => pcm_instance%virtual) call virtual%set_ren_scale (p, ren_scale) call virtual%set_fac_scale (p, fac_scale) call virtual%set_ellis_sexton_scale () end associate end select end subroutine pcm_instance_nlo_set_momenta_and_scales_virtual @ %def pcm_instance_nlo_set_momenta_and_scales_virtual @ <>= procedure :: set_fac_scale => pcm_instance_nlo_set_fac_scale <>= subroutine pcm_instance_nlo_set_fac_scale (pcm_instance, fac_scale) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance real(default), intent(in) :: fac_scale pcm_instance%isr_kinematics%fac_scale = fac_scale end subroutine pcm_instance_nlo_set_fac_scale @ %def pcm_instance_nlo_set_fac_scale @ <>= procedure :: set_momenta => pcm_instance_nlo_set_momenta <>= subroutine pcm_instance_nlo_set_momenta (pcm_instance, p_born, p_real, i_phs, cms) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance 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_instance%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 = p_born kinematics%p_real_cms%phs_point(i_phs)%p = 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 = p_born kinematics%p_real_lab%phs_point(i_phs)%p = p_real end if end associate end subroutine pcm_instance_nlo_set_momenta @ %def pcm_instance_nlo_set_momenta @ <>= procedure :: get_momenta => pcm_instance_nlo_get_momenta <>= function pcm_instance_nlo_get_momenta (pcm_instance, i_phs, born_phsp, cms) result (p) type(vector4_t), dimension(:), allocatable :: p class(pcm_instance_nlo_t), intent(in) :: pcm_instance 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 (config => pcm_instance%config) type is (pcm_nlo_t) if (born_phsp) then if (yorn) then allocate (p (1 : config%region_data%n_legs_born), & source = pcm_instance%real_kinematics%p_born_cms%phs_point(1)%p) else allocate (p (1 : config%region_data%n_legs_born), & source = pcm_instance%real_kinematics%p_born_lab%phs_point(1)%p) end if else if (yorn) then allocate (p (1 : config%region_data%n_legs_real), & source = pcm_instance%real_kinematics%p_real_cms%phs_point(i_phs)%p) else allocate (p ( 1 : config%region_data%n_legs_real), & source = pcm_instance%real_kinematics%p_real_lab%phs_point(i_phs)%p) end if end if end select end function pcm_instance_nlo_get_momenta @ %def pcm_instance_nlo_get_momenta @ <>= procedure :: get_xi_max => pcm_instance_nlo_get_xi_max <>= function pcm_instance_nlo_get_xi_max (pcm_instance, alr) result (xi_max) real(default) :: xi_max class(pcm_instance_nlo_t), intent(in) :: pcm_instance integer, intent(in) :: alr integer :: i_phs i_phs = pcm_instance%real_kinematics%alr_to_i_phs (alr) xi_max = pcm_instance%real_kinematics%xi_max (i_phs) end function pcm_instance_nlo_get_xi_max @ %def pcm_instance_nlo_get_xi_max @ <>= procedure :: get_n_born => pcm_instance_nlo_get_n_born <>= function pcm_instance_nlo_get_n_born (pcm_instance) result (n_born) integer :: n_born class(pcm_instance_nlo_t), intent(in) :: pcm_instance select type (config => pcm_instance%config) type is (pcm_nlo_t) n_born = config%region_data%n_legs_born end select end function pcm_instance_nlo_get_n_born @ %def pcm_instance_nlo_get_n_born @ <>= procedure :: get_n_real => pcm_instance_nlo_get_n_real <>= function pcm_instance_nlo_get_n_real (pcm_instance) result (n_real) integer :: n_real class(pcm_instance_nlo_t), intent(in) :: pcm_instance select type (config => pcm_instance%config) type is (pcm_nlo_t) n_real = config%region_data%n_legs_real end select end function pcm_instance_nlo_get_n_real @ %def pcm_instance_nlo_get_n_real @ <>= procedure :: get_n_regions => pcm_instance_nlo_get_n_regions <>= function pcm_instance_nlo_get_n_regions (pcm_instance) result (n_regions) integer :: n_regions class(pcm_instance_nlo_t), intent(in) :: pcm_instance select type (config => pcm_instance%config) type is (pcm_nlo_t) n_regions = config%region_data%n_regions end select end function pcm_instance_nlo_get_n_regions @ %def pcm_instance_nlo_get_n_regions @ <>= procedure :: set_x_rad => pcm_instance_nlo_set_x_rad <>= subroutine pcm_instance_nlo_set_x_rad (pcm_instance, x_tot) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance real(default), intent(in), dimension(:) :: x_tot integer :: n_par n_par = size (x_tot) if (n_par < 3) then pcm_instance%real_kinematics%x_rad = zero else pcm_instance%real_kinematics%x_rad = x_tot (n_par - 2 : n_par) end if end subroutine pcm_instance_nlo_set_x_rad @ %def pcm_instance_nlo_set_x_rad @ <>= procedure :: init_virtual => pcm_instance_nlo_init_virtual <>= subroutine pcm_instance_nlo_init_virtual (pcm_instance, model) class(pcm_instance_nlo_t), intent(inout), target :: pcm_instance class(model_data_t), intent(in) :: model type(nlo_settings_t), pointer :: settings select type (config => pcm_instance%config) type is (pcm_nlo_t) associate (region_data => config%region_data) settings => config%settings call pcm_instance%virtual%init (region_data%get_flv_states_born (), & region_data%n_in, settings, & region_data%regions(1)%nlo_correction_type, model, config%has_pdfs) end associate end select end subroutine pcm_instance_nlo_init_virtual @ %def pcm_instance_nlo_init_virtual @ <>= procedure :: disable_virtual_subtraction => pcm_instance_nlo_disable_virtual_subtraction <>= subroutine pcm_instance_nlo_disable_virtual_subtraction (pcm_instance) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance end subroutine pcm_instance_nlo_disable_virtual_subtraction @ %def pcm_instance_nlo_disable_virtual_subtraction @ <>= procedure :: compute_sqme_virt => pcm_instance_nlo_compute_sqme_virt <>= subroutine pcm_instance_nlo_compute_sqme_virt (pcm_instance, p, & alpha_coupling, separate_alrs, sqme_virt) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance type(vector4_t), intent(in), dimension(:) :: p real(default), intent(in) :: alpha_coupling logical, intent(in) :: separate_alrs real(default), dimension(:), allocatable, intent(inout) :: sqme_virt type(vector4_t), dimension(:), allocatable :: pp associate (virtual => pcm_instance%virtual) allocate (pp (size (p))) if (virtual%settings%factorization_mode == FACTORIZATION_THRESHOLD) then pp = pcm_instance%real_kinematics%p_born_onshell%get_momenta (1) else pp = p end if select type (config => pcm_instance%config) type is (pcm_nlo_t) if (separate_alrs) then allocate (sqme_virt (config%get_n_flv_born ())) else allocate (sqme_virt (1)) end if sqme_virt = zero call virtual%evaluate (config%region_data, & alpha_coupling, pp, separate_alrs, sqme_virt) end select end associate end subroutine pcm_instance_nlo_compute_sqme_virt @ %def pcm_instance_nlo_compute_sqme_virt @ <>= procedure :: compute_sqme_mismatch => pcm_instance_nlo_compute_sqme_mismatch <>= subroutine pcm_instance_nlo_compute_sqme_mismatch (pcm_instance, & alpha_s, separate_alrs, sqme_mism) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance real(default), intent(in) :: alpha_s logical, intent(in) :: separate_alrs real(default), dimension(:), allocatable, intent(inout) :: sqme_mism select type (config => pcm_instance%config) type is (pcm_nlo_t) if (separate_alrs) then allocate (sqme_mism (config%get_n_flv_born ())) else allocate (sqme_mism (1)) end if sqme_mism = zero sqme_mism = pcm_instance%soft_mismatch%evaluate (alpha_s) end select end subroutine pcm_instance_nlo_compute_sqme_mismatch @ %def pcm_instance_nlo_compute_sqme_mismatch @ <>= procedure :: compute_sqme_dglap_remnant => pcm_instance_nlo_compute_sqme_dglap_remnant <>= subroutine pcm_instance_nlo_compute_sqme_dglap_remnant (pcm_instance, & alpha_s, separate_alrs, sqme_dglap) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance real(default), intent(in) :: alpha_s logical, intent(in) :: separate_alrs real(default), dimension(:), allocatable, intent(inout) :: sqme_dglap select type (config => pcm_instance%config) type is (pcm_nlo_t) if (separate_alrs) then allocate (sqme_dglap (config%get_n_flv_born ())) else allocate (sqme_dglap (1)) end if end select sqme_dglap = zero call pcm_instance%dglap_remnant%evaluate (alpha_s, separate_alrs, sqme_dglap) end subroutine pcm_instance_nlo_compute_sqme_dglap_remnant @ %def pcm_instance_nlo_compute_sqme_dglap_remnant @ <>= procedure :: set_fixed_order_event_mode => pcm_instance_nlo_set_fixed_order_event_mode <>= subroutine pcm_instance_nlo_set_fixed_order_event_mode (pcm_instance) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance pcm_instance%real_sub%purpose = FIXED_ORDER_EVENTS end subroutine pcm_instance_nlo_set_fixed_order_event_mode <>= procedure :: set_powheg_mode => pcm_instance_nlo_set_powheg_mode <>= subroutine pcm_instance_nlo_set_powheg_mode (pcm_instance) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance pcm_instance%real_sub%purpose = POWHEG end subroutine pcm_instance_nlo_set_powheg_mode @ %def pcm_instance_nlo_set_fixed_order_event_mode @ %def pcm_instance_nlo_set_powheg_mode @ <>= procedure :: init_soft_mismatch => pcm_instance_nlo_init_soft_mismatch <>= subroutine pcm_instance_nlo_init_soft_mismatch (pcm_instance) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance select type (config => pcm_instance%config) type is (pcm_nlo_t) call pcm_instance%soft_mismatch%init (config%region_data, & pcm_instance%real_kinematics, config%settings%factorization_mode) end select end subroutine pcm_instance_nlo_init_soft_mismatch @ %def pcm_instance_nlo_init_soft_mismatch @ <>= procedure :: init_dglap_remnant => pcm_instance_nlo_init_dglap_remnant <>= subroutine pcm_instance_nlo_init_dglap_remnant (pcm_instance) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance select type (config => pcm_instance%config) type is (pcm_nlo_t) call pcm_instance%dglap_remnant%init ( & config%settings, & config%region_data%n_flv_born, & pcm_instance%isr_kinematics, & config%region_data%get_flv_states_born (), config%get_n_alr ()) end select end subroutine pcm_instance_nlo_init_dglap_remnant @ %def pcm_instance_nlo_init_dglap_remnant @ <>= procedure :: is_fixed_order_nlo_events & => pcm_instance_nlo_is_fixed_order_nlo_events <>= function pcm_instance_nlo_is_fixed_order_nlo_events (pcm_instance) result (is_nlo) logical :: is_nlo class(pcm_instance_nlo_t), intent(in) :: pcm_instance is_nlo = pcm_instance%real_sub%purpose == FIXED_ORDER_EVENTS end function pcm_instance_nlo_is_fixed_order_nlo_events @ %def pcm_instance_nlo_is_fixed_order_nlo_events @ <>= procedure :: final => pcm_instance_nlo_final <>= subroutine pcm_instance_nlo_final (pcm_instance) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance call pcm_instance%real_sub%final () call pcm_instance%virtual%final () call pcm_instance%soft_mismatch%final () call pcm_instance%dglap_remnant%final () if (associated (pcm_instance%real_kinematics)) then call pcm_instance%real_kinematics%final () nullify (pcm_instance%real_kinematics) end if if (associated (pcm_instance%isr_kinematics)) then nullify (pcm_instance%isr_kinematics) end if end subroutine pcm_instance_nlo_final @ %def pcm_instance_nlo_final @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \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 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, only: pcm_instance_nlo_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 @ 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 @ 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) call phs%generate_radiation_variables & (r_in(phs%n_r_born + 1 : phs%n_r_born + 3), k%threshold) call phs%compute_cms_energy () end select end subroutine kinematics_evaluate_radiation_kinematics @ %def kinematics_evaluate_radiation_kinematics @ <>= 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 (phs%q_defined) then call phs%get_born_momenta (p) 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. if (k%only_cm_frame) then if (.not. k%lab_is_cm_frame()) & call k%boost_to_cm_frame (p) end if else k%phs_factor = 0 success = .false. end if end select end subroutine kinematics_compute_selected_channel @ %def kinematics_compute_selected_channel @ 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 @ 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, sf_rescale) class(kinematics_t), intent(inout) :: k real(default), intent(in) :: fac_scale 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, 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_frame => kinematics_lab_is_cm_frame <>= function kinematics_lab_is_cm_frame (k) result (cm_frame) logical :: cm_frame class(kinematics_t), intent(in) :: k cm_frame = k%phs%config%cm_frame end function kinematics_lab_is_cm_frame @ %def kinematics_lab_is_cm_frame @ Boost to center-of-mass frame <>= procedure :: boost_to_cm_frame => kinematics_boost_to_cm_frame <>= subroutine kinematics_boost_to_cm_frame (k, p) class(kinematics_t), intent(in) :: k type(vector4_t), intent(inout), dimension(:) :: p p = inverse (k%phs%lt_cm_to_lab) * p end subroutine kinematics_boost_to_cm_frame @ %def kinematics_boost_to_cm_frame @ <>= 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_instance, nlo_type) class(kinematics_t), intent(inout) :: k type(pcm_instance_nlo_t), intent(inout) :: pcm_instance integer, intent(in) :: nlo_type real(default) :: sqrts, mtop type(lorentz_transformation_t) :: L_to_cms type(vector4_t), dimension(:), allocatable :: p_tot integer :: n_tot n_tot = k%phs%get_n_tot () allocate (p_tot (size (pcm_instance%real_kinematics%p_born_cms%phs_point(1)%p))) select type (phs => k%phs) type is (phs_fks_t) p_tot = pcm_instance%real_kinematics%p_born_cms%phs_point(1)%p 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_instance%real_kinematics%p_born_cms%set_momenta (1, p_tot) associate (p_onshell => pcm_instance%real_kinematics%p_born_onshell%phs_point(1)%p) call threshold_projection_born (mtop, L_to_cms, p_tot, p_onshell) if (debug2_active (D_THRESHOLD)) then print *, 'On-shell projected Born: ' call vector4_write_set (p_onshell) end if end associate 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%is_cm_frame () .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 isr_collinear 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 [[k_term]] object is the instance of the kinematics setup (structure-function chain, phase space, etc.) that applies specifically to this term. In ordinary cases, it consists of straight pointers to the seed kinematics. 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. Once the term has passed cuts, we calculate the various scale and weight expressions. <>= type :: term_instance_t type(process_term_t), pointer :: config => null () logical :: active = .false. type(kinematics_t) :: k_term 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) :: fac_scale = 0 real(default) :: ren_scale = 0 real(default), allocatable :: alpha_qcd_forced real(default) :: weight = 1 type(vector4_t), dimension(:), allocatable :: p_seed type(vector4_t), dimension(:), allocatable :: p_hard class(pcm_instance_t), pointer :: pcm_instance => null () integer :: nlo_type = BORN integer, dimension(:), allocatable :: same_kinematics type(qn_index_map_t) :: connected_qn_index type(qn_index_map_t) :: hard_qn_index contains <> end type term_instance_t @ %def term_instance_t @ <>= procedure :: write => term_instance_write <>= subroutine term_instance_write (term, unit, show_eff_state, testflag) class(term_instance_t), intent(in) :: term integer, intent(in), optional :: unit logical, intent(in), optional :: show_eff_state logical, intent(in), optional :: testflag 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%fac_scale write (u, "(3x,A,ES19.12)") "renormalization scale = ", term%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 call term%k_term%write (u) 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%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%k_term%final () call term%connected%final () call term%isolated%final () call term%int_hard%final () term%pcm_instance => null () end subroutine term_instance_final @ %def term_instance_final @ For initialization, we make use of defined assignment for the [[interaction_t]] type. This creates a deep copy. 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 :: init => term_instance_init <>= subroutine term_instance_init (term, process, i_term, real_finite) class(term_instance_t), intent(inout), target :: term type(process_t), intent(in), target:: process integer, intent(in) :: i_term 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 :: n_in, n_vir, n_out, n_tot, n_sub 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) 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 => term%k_term%sf_chain%get_out_int_ptr () n_in = term%int_hard%get_n_in () do j = 1, n_in i = term%k_term%sf_chain%get_out_i (j) call term%int_hard%set_source_link (j, sf_chain_int, i) end do call term%isolated%init (term%k_term%sf_chain, term%int_hard) allocate (mask_in (n_in)) mask_in = term%k_term%sf_chain%get_out_mask () select type (phs => term%k_term%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_beam_structure_int 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, & 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) select type (core) class is (prc_external_t) select type (pcm_instance => term%pcm_instance) type is (pcm_instance_nlo_t) associate (is_born => .not. (term%nlo_type == NLO_REAL .and. .not. term%is_subtraction ())) ! Does connected%trace never have any helicity qn? call setup_qn_index (term%connected_qn_index, term%connected%trace, pcm_instance, & n_sub = n_sub, is_born = is_born, is_polarized = .false.) call setup_qn_index (term%hard_qn_index, term%int_hard, pcm_instance, & n_sub = n_sub, is_born = is_born, is_polarized = core%includes_polarization ()) end associate class default call term%connected_qn_index%init (term%connected%trace) call term%hard_qn_index%init (term%int_hard) end select class default call term%connected_qn_index%init (term%connected%trace) call term%hard_qn_index%init (term%int_hard) end select 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 + end subroutine reduce_interaction <> end subroutine term_instance_init @ %def term_instance_init @ Setup index mapping from state matrix to index pair [[i_flv]], [[i_sub]]. <>= subroutine setup_qn_index (qn_index, int, pcm_instance, n_sub, is_born, is_polarized) type(qn_index_map_t), intent(out) :: qn_index class(interaction_t), intent(in) :: int class(pcm_instance_t), intent(in) :: pcm_instance integer, intent(in) :: n_sub logical, intent(in) :: is_born logical, intent(in) :: is_polarized integer :: i type(quantum_numbers_t), dimension(:, :), allocatable :: qn_config type(quantum_numbers_t), dimension(:, :), allocatable :: qn_hel select type (config => pcm_instance%config) type is (pcm_nlo_t) qn_config = config%get_qn (is_born) end select if (is_polarized) then ! term%config%data from higher scope call setup_qn_hel (int, term%config%data, qn_hel) call qn_index%init (int, qn_config, n_sub, qn_hel) call qn_index%set_helicity_flip (.true.) else call qn_index%init (int, qn_config, n_sub) end if end subroutine setup_qn_index @ %def setup_qn_index @ Setup beam polarisation quantum numbers, iff 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 a 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. <>= subroutine setup_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_qn_hel @ %def setup_qn_hel @ <>= procedure :: init_from_process => term_instance_init_from_process <>= subroutine term_instance_init_from_process (term_instance, & process, i, pcm_instance, sf_chain) class(term_instance_t), intent(inout), target :: term_instance type(process_t), intent(in), target :: process integer, intent(in) :: i class(pcm_instance_t), intent(in), target :: pcm_instance type(sf_chain_t), intent(in), target :: sf_chain 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 term_instance%pcm_instance => pcm_instance term_instance%nlo_type = 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_kinematics (sf_chain, & process%get_beam_config_ptr (), & process%get_phs_config (i_component), & requires_extended_sf) call term_instance%init (process, i, & real_finite = process%component_is_real_finite (i_component)) select type (phs => term_instance%k_term%phs) type is (phs_fks_t) call term_instance%set_emitter (process%get_pcm_ptr ()) call term_instance%setup_fks_kinematics (process%get_var_list_ptr (), & process%get_beam_config_ptr ()) end select call term_instance%set_threshold (process%get_pcm_ptr ()) call term_instance%setup_expressions (process%get_meta (), process%get_config ()) end if end subroutine term_instance_init_from_process @ %def term_instance_init_from_process @ Initialize the seed-kinematics configuration. All subobjects are allocated explicitly. <>= procedure :: setup_kinematics => term_instance_setup_kinematics <>= subroutine term_instance_setup_kinematics (term, sf_chain, & beam_config, phs_config, extended_sf) class(term_instance_t), intent(inout) :: term 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 logical, intent(in) :: extended_sf select type (config => term%pcm_instance%config) type is (pcm_nlo_t) call term%k_term%init_sf_chain (sf_chain, beam_config, & extended_sf = config%has_pdfs .and. extended_sf) class default call term%k_term%init_sf_chain (sf_chain, beam_config) end select !!! Add one for additional Born matrix element call term%k_term%init_phs (phs_config) call term%k_term%set_nlo_info (term%nlo_type) select type (phs => term%k_term%phs) type is (phs_fks_t) call phs%allocate_momenta (phs_config, & .not. (term%nlo_type == NLO_REAL)) select type (config => term%pcm_instance%config) type is (pcm_nlo_t) call config%region_data%init_phs_identifiers (phs%phs_identifiers) !!! The triple select type pyramid of doom select type (pcm_instance => term%pcm_instance) type is (pcm_instance_nlo_t) if (allocated (pcm_instance%real_kinematics%alr_to_i_phs)) & call config%region_data%set_alr_to_i_phs (phs%phs_identifiers, & pcm_instance%real_kinematics%alr_to_i_phs) end select end select end select end subroutine term_instance_setup_kinematics @ %def term_instance_setup_kinematics @ <>= procedure :: setup_fks_kinematics => term_instance_setup_fks_kinematics <>= subroutine term_instance_setup_fks_kinematics (term, var_list, beam_config) class(term_instance_t), intent(inout), target :: term 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 => term%k_term%phs) type is (phs_fks_t) select type (config => term%pcm_instance%config) type is (pcm_nlo_t) select type (pcm_instance => term%pcm_instance) type is (pcm_instance_nlo_t) call config%setup_phs_generator (pcm_instance, & phs%generator, phs%config%sqrts, mode, singular_jacobian) if (beam_config%has_structure_function ()) then pcm_instance%isr_kinematics%isr_mode = SQRTS_VAR else pcm_instance%isr_kinematics%isr_mode = SQRTS_FIXED end if call msg_debug (D_PHASESPACE, "isr_mode: ", pcm_instance%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 (config => term%pcm_instance%config) type is (pcm_nlo_t) associate (settings => config%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 @ Setup 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, mci_work, phs_channel, success) class(term_instance_t), intent(inout), target :: term type(mci_work_t), intent(in) :: mci_work integer, intent(in) :: phs_channel logical, intent(out) :: success call term%k_term%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_radiation_kinematics => term_instance_evaluate_radiation_kinematics <>= subroutine term_instance_evaluate_radiation_kinematics (term, x) class(term_instance_t), intent(inout) :: term real(default), dimension(:), intent(in) :: x select type (phs => term%k_term%phs) type is (phs_fks_t) if (phs%mode == PHS_MODE_ADDITIONAL_PARTICLE) & call term%k_term%evaluate_radiation_kinematics (x) end select end subroutine term_instance_evaluate_radiation_kinematics @ %def term_instance_evaluate_radiation_kinematics @ <>= procedure :: compute_xi_ref_momenta => term_instance_compute_xi_ref_momenta <>= subroutine term_instance_compute_xi_ref_momenta (term) class(term_instance_t), intent(inout) :: term select type (pcm => term%pcm_instance%config) type is (pcm_nlo_t) call term%k_term%compute_xi_ref_momenta (pcm%region_data, term%nlo_type) end select end subroutine term_instance_compute_xi_ref_momenta @ %def term_instance_compute_xi_ref_momenta @ <>= procedure :: generate_fsr_in => term_instance_generate_fsr_in <>= subroutine term_instance_generate_fsr_in (term) class(term_instance_t), intent(inout) :: term select type (phs => term%k_term%phs) type is (phs_fks_t) call phs%generate_fsr_in () end select end subroutine term_instance_generate_fsr_in @ %def term_instance_generate_fsr_in @ <>= procedure :: evaluate_projections => term_instance_evaluate_projections <>= subroutine term_instance_evaluate_projections (term) class(term_instance_t), intent(inout) :: term if (term%k_term%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_instance => term%pcm_instance) type is (pcm_instance_nlo_t) call term%k_term%threshold_projection (pcm_instance, term%nlo_type) end select end if end subroutine term_instance_evaluate_projections @ %def term_instance_evaluate_projections @ <>= procedure :: redo_sf_chain => term_instance_redo_sf_chain <>= subroutine term_instance_redo_sf_chain (term, mci_work, phs_channel) class(term_instance_t), intent(inout) :: term 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 () associate (k => term%k_term) sf_channel = k%phs%config%get_sf_channel (phs_channel) call k%sf_chain%compute_kinematics (sf_channel, x) deallocate (x) end associate end if end subroutine term_instance_redo_sf_chain @ %def term_instance_redo_sf_chain @ Inverse: recover missing parts of the kinematics, given a complete set of seed momenta. Select a channel and reconstruct the MC parameter set. <>= procedure :: recover_mcpar => term_instance_recover_mcpar <>= subroutine term_instance_recover_mcpar (term, mci_work, phs_channel) class(term_instance_t), intent(inout), target :: term type(mci_work_t), intent(inout) :: mci_work integer, intent(in) :: phs_channel call term%k_term%recover_mcpar (mci_work, phs_channel, term%p_seed) end subroutine term_instance_recover_mcpar @ %def term_instance_recover_mcpar @ Part of [[recover_mcpar]], separately accessible. Reconstruct all kinematics data in the structure-function chain instance. <>= procedure :: recover_sfchain => term_instance_recover_sfchain <>= subroutine term_instance_recover_sfchain (term, channel) class(term_instance_t), intent(inout), target :: term integer, intent(in) :: channel call term%k_term%recover_sfchain (channel, term%p_seed) end subroutine term_instance_recover_sfchain @ %def term_instance_recover_sfchain @ 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, skip_term, success) class(term_instance_t), intent(inout) :: term integer, intent(in), optional :: skip_term 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 (term%nlo_type == NLO_REAL .and. term%k_term%emitter >= 0) then call term%k_term%evaluate_radiation (term%p_seed, p, success) select type (config => term%pcm_instance%config) type is (pcm_nlo_t) if (config%dalitz_plot%active) then if (term%k_term%emitter > term%k_term%n_in) then if (p(term%k_term%emitter)**2 > tiny_07) & call config%register_dalitz_plot (term%k_term%emitter, p) end if end if end select else if (is_subtraction_component (term%k_term%emitter, term%nlo_type)) then call term%k_term%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) 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) class(term_instance_t), intent(inout) :: term integer :: n_in n_in = term%k_term%n_in call term%k_term%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.) term%p_seed(n_in + 1 : ) = int_eff%get_momenta (outgoing = .true.) 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. <>= 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. <>= 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 @ <>= procedure :: apply_real_partition => term_instance_apply_real_partition <>= subroutine term_instance_apply_real_partition (term, process) class(term_instance_t), intent(inout) :: term type(process_t), intent(in) :: process real(default) :: f, sqme integer :: i_component integer :: i_amp, n_amps 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. term%k_term%emitter < 0 if (is_subtraction) return 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 sqme = real (term%connected%trace%get_matrix_element ( & term%connected_qn_index%get_index (i_amp, i_sub = 0))) call msg_debug2 (D_PROCESS_INTEGRATION, "term_instance_apply_real_partition") select type (pcm => term%pcm_instance%config) 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) call msg_debug2 (D_PROCESS_INTEGRATION, "Real finite") sqme = sqme * (one - f) case (COMP_REAL_SING) call msg_debug2 (D_PROCESS_INTEGRATION, "Real singular") sqme = sqme * f end select end select end select call msg_debug2 (D_PROCESS_INTEGRATION, "apply_damping: sqme", sqme) call term%connected%trace%set_matrix_element (i_amp, cmplx (sqme, zero, default)) end do end if end subroutine term_instance_apply_real_partition @ %def term_instance_apply_real_partition @ <>= procedure :: get_lorentz_transformation => term_instance_get_lorentz_transformation <>= function term_instance_get_lorentz_transformation (term) result (lt) type(lorentz_transformation_t) :: lt class(term_instance_t), intent(in) :: term lt = term%k_term%phs%get_lorentz_transformation () end function term_instance_get_lorentz_transformation @ %def term_instance_get_lorentz_transformation @ <>= 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, pcm) class(term_instance_t), intent(inout) :: term class(pcm_t), intent(in) :: pcm integer :: i_phs logical :: set_emitter select type (pcm) type is (pcm_nlo_t) !!! Without resonances, i_alr = i_phs i_phs = term%config%i_term term%k_term%i_phs = term%config%i_term select type (phs => term%k_term%phs) type is (phs_fks_t) set_emitter = i_phs <= pcm%region_data%n_phs .and. term%nlo_type == NLO_REAL if (set_emitter) then term%k_term%emitter = phs%phs_identifiers(i_phs)%emitter select type (pcm => term%pcm_instance%config) type is (pcm_nlo_t) if (allocated (pcm%region_data%i_phs_to_i_con)) & term%k_term%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 @ <>= procedure :: set_threshold => term_instance_set_threshold <>= subroutine term_instance_set_threshold (term, pcm) class(term_instance_t), intent(inout) :: term class(pcm_t), intent(in) :: pcm select type (pcm) type is (pcm_nlo_t) term%k_term%threshold = pcm%settings%factorization_mode == FACTORIZATION_THRESHOLD class default term%k_term%threshold = .false. end select end subroutine term_instance_set_threshold @ %def term_instance_set_threshold @ 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 quantum numbers mask of the incoming particle <>= procedure :: setup_event_data => term_instance_setup_event_data <>= subroutine term_instance_setup_event_data (term, core, model) class(term_instance_t), intent(inout), target :: term class(prc_core_t), intent(in) :: core class(model_data_t), intent(in), target :: model integer :: n_in type(quantum_numbers_mask_t), dimension(:), allocatable :: mask_in n_in = term%int_hard%get_n_in () allocate (mask_in (n_in)) mask_in = term%k_term%sf_chain%get_out_mask () call setup_isolated (term%isolated, core, model, mask_in, term%config%col) call setup_connected (term%connected, term%isolated, term%nlo_type) 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 call isolated%setup_square_matrix (core, model, mask, color) call isolated%setup_square_flows (core, model, mask) end subroutine setup_isolated subroutine setup_connected (connected, isolated, nlo_type) type(connected_state_t), intent(inout), target :: connected type(isolated_state_t), intent(in), target :: isolated integer :: nlo_type 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 don't 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 connected%setup_connected_flows (isolated) 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_instance => term%pcm_instance) type is (pcm_instance_nlo_t) select type (config => pcm_instance%config) type is (pcm_nlo_t) call msg_debug2 (D_SUBTRACTION, & "term_instance_evaluate_color_correlations: " // & "use_internal_color_correlations:", & config%settings%use_internal_color_correlations) call msg_debug2 (D_SUBTRACTION, "fac_scale", term%fac_scale) do i_flv_born = 1, config%region_data%n_flv_born select case (term%nlo_type) case (NLO_REAL) call transfer_me_array_to_bij (config, i_flv_born, & pcm_instance%real_sub%sqme_born (i_flv_born), & pcm_instance%real_sub%sqme_born_color_c (:, :, i_flv_born)) case (NLO_MISMATCH) call transfer_me_array_to_bij (config, i_flv_born, & pcm_instance%soft_mismatch%sqme_born (i_flv_born), & pcm_instance%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 (config, i_flv_born, & -one, pcm_instance%virtual%sqme_color_c (:, :, 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 integer :: i_color_c, i_sub, n_pdf_off, virt_off, n_offset real(default), dimension(:), allocatable :: sqme 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 n_offset = 0 if (term%nlo_type == NLO_VIRTUAL) then n_offset = 1 else if (pcm%has_pdfs .and. term%is_subtraction ()) then n_offset = n_beam_structure_int 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_qn_index%get_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_qn_index%get_index (i_flv, i_sub = 0)), default), & pcm%region_data%get_flv_states_born (i_flv), & sqme_color_c) 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_instance => term%pcm_instance) type is (pcm_instance_nlo_t) select type (config => pcm_instance%config) type is (pcm_nlo_t) do i_flv_born = 1, config%region_data%n_flv_born select case (term%nlo_type) case (NLO_REAL) call transfer_me_array_to_bij (config, i_flv_born, & pcm_instance%real_sub%sqme_born (i_flv_born), & pcm_instance%real_sub%sqme_born_charge_c (:, :, i_flv_born)) case (NLO_MISMATCH) call transfer_me_array_to_bij (config, i_flv_born, & pcm_instance%soft_mismatch%sqme_born (i_flv_born), & pcm_instance%soft_mismatch%sqme_born_charge_c (:, :, i_flv_born)) case (NLO_VIRTUAL) call transfer_me_array_to_bij (config, i_flv_born, & -one, pcm_instance%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 integer, 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) = sign (1, flv_born%flst(1:flv_born%n_in)) sigma(flv_born%n_in + 1: ) = -sign (1, flv_born%flst(flv_born%n_in + 1: )) 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_hel, i_sub, i_emitter, emitter integer :: n_flv, n_sub_color, n_sub_spin, n_offset real(default), dimension(0:3, 0:3) :: sqme_spin_c real(default), dimension(:), allocatable :: sqme_spin_c_all real(default), dimension(:), allocatable :: sqme_spin_c_arr call msg_debug2 (D_PROCESS_INTEGRATION, & "term_instance_evaluate_spin_correlations") select type (pcm_instance => term%pcm_instance) type is (pcm_instance_nlo_t) if (pcm_instance%real_sub%requires_spin_correlations () & .and. term%nlo_type == NLO_REAL) then select type (core) type is (prc_openloops_t) select type (config => pcm_instance%config) type is (pcm_nlo_t) n_flv = term%connected_qn_index%get_n_flv () n_sub_color = term%get_n_sub_color () n_sub_spin = term%get_n_sub_spin () n_offset = 0; if(config%has_pdfs) n_offset = n_beam_structure_int allocate (sqme_spin_c_arr(16)) 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_qn_index%get_index (i_flv, & i_sub = i_sub + n_offset + n_sub_color)), default) end do do i_emitter = 1, config%region_data%n_emitters emitter = config%region_data%emitters(i_emitter) if (emitter > 0) then call split_array (sqme_spin_c_all, sqme_spin_c_arr) sqme_spin_c = reshape (sqme_spin_c_arr, (/4,4/)) pcm_instance%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 @ Compute collinear ISR from interactions, real component and DLGAP remnant are handled accordingly. <>= procedure :: compute_sqme_coll_isr => term_instance_compute_sqme_coll_isr <>= subroutine term_instance_compute_sqme_coll_isr (term) class(term_instance_t), intent(in) :: term integer :: i_flv integer, parameter :: BEAM_PLUS = 1, BEAM_MINUS = 2, & PDF = 1, PDF_SINGLET = 2 select type (pcm_instance => term%pcm_instance) type is (pcm_instance_nlo_t) select type (pcm => term%pcm_instance%config) type is (pcm_nlo_t) associate (me => term%connected%trace%get_matrix_element ()) do i_flv = 1, pcm%region_data%n_flv_born call set_sqme_coll_isr (BEAM_PLUS, PDF, i_flv, & real(me(term%connected_qn_index%get_index (i_flv, i_sub = 1)))) call set_sqme_coll_isr (BEAM_MINUS, PDF, i_flv, & real(me(term%connected_qn_index%get_index (i_flv, i_sub = 2)))) if (pcm%settings%nlo_correction_type == "QCD" .or. & pcm%settings%nlo_correction_type == "Full") then call set_sqme_coll_isr (BEAM_PLUS, PDF_SINGLET, i_flv, & real(me(term%connected_qn_index%get_index (i_flv, i_sub = 3)))) call set_sqme_coll_isr (BEAM_MINUS, PDF_SINGLET, i_flv, & real(me(term%connected_qn_index%get_index (i_flv, i_sub = 4)))) end if end do end associate if (debug2_active (D_BEAMS)) then call msg_debug2 (D_BEAMS, "term_instance_compute_sqme_coll_isr") if (term%nlo_type == NLO_REAL) then print *, "nlo_type: REAL" print *, "n_flv: ", pcm%region_data%n_flv_born print *, "i_flv: ", i_flv print *, "Beam 1: " print *, " quarks: ", pcm_instance%real_sub%sqme_coll_isr (BEAM_PLUS, PDF, :) print *, " gluon: ", pcm_instance%real_sub%sqme_coll_isr (BEAM_PLUS, PDF_SINGLET, :) print *, "Beam 2: " print *, " quarks: ", pcm_instance%real_sub%sqme_coll_isr (BEAM_MINUS, PDF, :) print *, " gluon: ", pcm_instance%real_sub%sqme_coll_isr (BEAM_MINUS, PDF_SINGLET, :) else if (term%nlo_type == NLO_DGLAP) then print *, "nlo_type: DGLAP" print *, "n_flv: ", pcm%region_data%n_flv_born print *, "i_flv: ", i_flv print *, "Beam 1: " print *, " quarks: ", pcm_instance%dglap_remnant%sqme_coll_isr (BEAM_PLUS, PDF, :) print *, " gluon: ", pcm_instance%dglap_remnant%sqme_coll_isr (BEAM_PLUS, PDF_SINGLET, :) print *, "Beam 2: " print *, " quarks: ", pcm_instance%dglap_remnant%sqme_coll_isr (BEAM_MINUS, PDF, :) print *, " gluon: ", pcm_instance%dglap_remnant%sqme_coll_isr (BEAM_MINUS, PDF_SINGLET, :) end if end if end select end select contains subroutine set_sqme_coll_isr (i_beam, i_type, i_flv, me) integer, intent(in) :: i_beam, i_type, i_flv real(default), intent(in) :: me select type (pcm_instance => term%pcm_instance) type is (pcm_instance_nlo_t) select case (term%nlo_type) case (NLO_REAL) pcm_instance%real_sub%sqme_coll_isr (i_beam, i_type, i_flv) = me case (NLO_DGLAP) pcm_instance%dglap_remnant%sqme_coll_isr (i_beam, i_type, i_flv) = me end select end select end subroutine set_sqme_coll_isr end subroutine term_instance_compute_sqme_coll_isr @ %def term_instance_compute_sqme_coll_isr @ <>= procedure :: apply_fks => term_instance_apply_fks <>= subroutine term_instance_apply_fks (term, alpha_s_sub, alpha_qed_sub) class(term_instance_t), intent(inout) :: term 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_instance => term%pcm_instance) type is (pcm_instance_nlo_t) select type (config => pcm_instance%config) type is (pcm_nlo_t) if (term%connected%has_matrix) then allocate (sqme (config%get_n_alr ())) else allocate (sqme (1)) end if sqme = zero select type (phs => term%k_term%phs) type is (phs_fks_t) call pcm_instance%set_real_and_isr_kinematics & (phs%phs_identifiers, term%k_term%phs%get_sqrts ()) if (term%k_term%emitter < 0) then call pcm_instance%set_subtraction_event () do i_phs = 1, config%region_data%n_phs emitter = phs%phs_identifiers(i_phs)%emitter call pcm_instance%real_sub%compute (emitter, & i_phs, alpha_s_sub, alpha_qed_sub, term%connected%has_matrix, sqme) end do else call pcm_instance%set_radiation_event () emitter = term%k_term%emitter; i_phs = term%k_term%i_phs do i = 1, term%connected_qn_index%get_n_flv () pcm_instance%real_sub%sqme_real_non_sub (i, i_phs) = & real (term%connected%trace%get_matrix_element ( & term%connected_qn_index%get_index (i))) end do call pcm_instance%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 (config => term%pcm_instance%config) type is (pcm_nlo_t) is_subtraction = term%k_term%emitter < 0 if (term%connected%has_matrix) & call refill_evaluator (cmplx (sqme, 0, default), & config%get_qn (is_subtraction), & config%region_data%get_flavor_indices (is_subtraction), & term%connected%matrix) if (term%connected%has_flows) & call refill_evaluator (cmplx (sqme, 0, default), & config%get_qn (is_subtraction), & config%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) :: 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%ren_scale print *, 'fac_scale: ', term%fac_scale end if select type (config => term%pcm_instance%config) type is (pcm_nlo_t) select type (pcm_instance => term%pcm_instance) type is (pcm_instance_nlo_t) associate (nlo_corr_type => config%region_data%regions(1)%nlo_correction_type) if (nlo_corr_type == "QCD") then alpha_coupling = alpha_s if (debug2_active (D_VIRTUAL)) print *, 'alpha_s: ', alpha_coupling else if (nlo_corr_type == "QED") then alpha_coupling = alpha_qed if (debug2_active (D_VIRTUAL)) print *, 'alpha_qed: ', alpha_coupling end if end associate allocate (p_born (config%region_data%n_legs_born)) if (config%settings%factorization_mode == FACTORIZATION_THRESHOLD) then p_born = pcm_instance%real_kinematics%p_born_onshell%get_momenta(1) else p_born = term%int_hard%get_momenta () end if call pcm_instance%set_momenta_and_scales_virtual & (p_born, term%ren_scale, term%fac_scale) select type (pcm_instance => term%pcm_instance) type is (pcm_instance_nlo_t) associate (virtual => pcm_instance%virtual) do i_flv = 1, term%connected_qn_index%get_n_flv () virtual%sqme_born(i_flv) = & real (term%connected%trace%get_matrix_element ( & term%connected_qn_index%get_index (i_flv, i_sub = 0))) virtual%sqme_virt_fin(i_flv) = & real (term%connected%trace%get_matrix_element ( & term%connected_qn_index%get_index (i_flv, i_sub = 1))) end do end associate end select call pcm_instance%compute_sqme_virt (term%p_hard, alpha_coupling, & term%connected%has_matrix, sqme_virt) call term%connected%trace%set_only_matrix_element & (1, cmplx (sum(sqme_virt) * term%weight, 0, default)) if (term%connected%has_matrix) then call refill_evaluator (cmplx (sqme_virt * term%weight, 0, default), & config%get_qn (.true.), & config%region_data%get_flavor_indices (.true.), & term%connected%matrix) end if end select end select end subroutine term_instance_evaluate_sqme_virt @ %def term_instance_evaluate_sqme_virt @ <>= 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_instance => term%pcm_instance) type is (pcm_instance_nlo_t) call pcm_instance%compute_sqme_mismatch & (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 (config => term%pcm_instance%config) type is (pcm_nlo_t) call refill_evaluator (cmplx (sqme_mism * term%weight, 0, default), & config%get_qn (.true.), config%region_data%get_flavor_indices (.true.), & term%connected%matrix) 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) class(term_instance_t), intent(inout) :: term real(default), intent(in) :: alpha_s 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.") call msg_debug2 (D_PROCESS_INTEGRATION, "term_instance_evaluate_sqme_dglap") select type (pcm_instance => term%pcm_instance) type is (pcm_instance_nlo_t) if (debug2_active (D_PROCESS_INTEGRATION)) then associate (n_flv => pcm_instance%dglap_remnant%n_flv) print *, "size(sqme_born) = ", size (pcm_instance%dglap_remnant%sqme_born) call term%connected%trace%write () do i_flv = 1, n_flv print *, "i_flv = ", i_flv, ", n_flv = ", n_flv print *, "sqme_born(i_flv) = ", pcm_instance%dglap_remnant%sqme_born(i_flv) end do end associate end if call pcm_instance%compute_sqme_dglap_remnant (alpha_s, & term%connected%has_matrix, sqme_dglap) 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 (config => term%pcm_instance%config) type is (pcm_nlo_t) call refill_evaluator (cmplx (sqme_dglap * term%weight, 0, default), & config%get_qn (.true.), & config%region_data%get_flavor_indices (.true.), & term%connected%matrix) 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. (If we have an algorithm that uses rarrangement, it should evaluate [[k_term]] explicitly.) 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) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(in), pointer :: core call msg_debug2 (D_PROCESS_INTEGRATION, & "term_instance_evaluate_interaction") term%p_hard = term%int_hard%get_momenta () select type (core) class is (prc_external_t) call term%evaluate_interaction_userdef (core) 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 integer :: i 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), & term%fac_scale, term%ren_scale, term%alpha_qcd_forced, & term%core_state) end do select type (pcm_instance => term%pcm_instance) type is (pcm_instance_nlo_t) call pcm_instance%set_fac_scale (term%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) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(inout) :: core 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%ren_scale) if (allocated (core_state%threshold_data)) & call evaluate_threshold_parameters (core_state, core, term%k_term%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%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_instance => term%pcm_instance) type is (pcm_instance_nlo_t) call pcm_instance%set_fac_scale (term%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 => term%pcm_instance) type is (pcm_instance_nlo_t) if (term%k_term%emitter >= 0) then call core%set_offshell_momenta & (pcm%real_kinematics%p_real_cms%get_momenta(term%config%i_term)) leg = thr_leg (term%k_term%emitter) call core%set_leg (leg) call core%set_onshell_momenta & (pcm%real_kinematics%p_real_onshell(leg)%get_momenta(term%config%i_term)) else call core%set_leg (0) call core%set_offshell_momenta & (pcm%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_beam_structure_int]] copies of these matrix elements as the first [[n_beam_structure_int]] subtractions. The next $n_{\text{born}}\times n_{sub}$ are color-correlated born matrix elements. <>= 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(16) :: 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_spin_c, i_emitter integer :: emitter logical :: bad_point, bp 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%hard_qn_index%get_n_flv () n_hel = term%hard_qn_index%get_n_hel () n_sub_color = term%get_n_sub_color () n_sub_spin = term%get_n_sub_spin () do i_flv = 1, n_flv do i_hel = 1, n_hel select type (core) class is (prc_external_t) call core%update_alpha_s (term%core_state, term%fac_scale) call core%compute_sqme (i_flv, i_hel, term%p_hard, term%ren_scale, & sqme, bad_point) call term%pcm_instance%set_bad_point (bad_point) associate (i_int => term%hard_qn_index%get_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_instance%config%has_pdfs .and. & (term%is_subtraction () .or. term%nlo_type == NLO_DGLAP)) then n_pdf_off = n_pdf_off + n_beam_structure_int do i_sub = 1, n_pdf_off term%amp(term%hard_qn_index%get_index (i_flv, i_hel, i_sub)) = & term%amp(term%hard_qn_index%get_index (i_flv, i_hel, i_sub = 0)) 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%ren_scale, sqme_color_c, bad_point) call term%pcm_instance%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%ren_scale, sqme_color_c, bad_point) call term%pcm_instance%set_bad_point (bad_point) end select do i_sub = 1, n_sub_color i_color_c = term%hard_qn_index%get_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 (config => term%pcm_instance%config) type is (pcm_nlo_t) do i_emitter = 1, config%region_data%n_emitters emitter = config%region_data%emitters(i_emitter) if (emitter > 0) then call core%compute_sqme_spin_c & (i_flv, & i_hel, & emitter, & term%p_hard, & term%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%hard_qn_index%get_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 end do end do end subroutine term_instance_evaluate_interaction_userdef_tree @ %def term_instance_evaluate_interaction_userdef_tree @ <>= 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 real(default), dimension(4) :: sqme_virt real(default), dimension(:), allocatable :: sqme_color_c logical :: bad_point 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%hard_qn_index%get_n_flv () n_hel = term%hard_qn_index%get_n_hel () n_sub = term%hard_qn_index%get_n_sub () i_virt = 1 do i_flv = 1, n_flv do i_hel = 1, n_hel select type (core) class is (prc_external_t) call core%compute_sqme_virt (i_flv, i_hel, term%p_hard, & term%ren_scale, sqme_virt, bad_point) call term%pcm_instance%set_bad_point (bad_point) end select associate (i_born => term%hard_qn_index%get_index (i_flv, i_hel = i_hel, i_sub = 0), & i_loop => term%hard_qn_index%get_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 (config => term%pcm_instance%config) 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%ren_scale, & sqme_color_c, bad_point) call term%pcm_instance%set_bad_point (bad_point) do i_sub = 1 + i_virt, n_sub i_color_c = term%hard_qn_index%get_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%ren_scale, sqme_color_c, bad_point) call term%pcm_instance%set_bad_point (bad_point) do i_sub = 1 + i_virt, n_sub i_color_c = term%hard_qn_index%get_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 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 [[k_term]] 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) class(term_instance_t), intent(inout) :: term class(sf_rescale_t), allocatable :: func call term%k_term%evaluate_sf_chain (term%fac_scale) call term%evaluate_scaled_sf_chains () call term%isolated%evaluate_sf_chain (term%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, we have an emitter in the initial state, rescale the kinematics for it using [[sf_rescale_real_t]]. References: arXiv:0709.2092, (2.35)-(2.42). <>= procedure :: evaluate_scaled_sf_chains => term_instance_evaluate_scaled_sf_chains <>= subroutine term_instance_evaluate_scaled_sf_chains (term) class(term_instance_t), intent(inout) :: term class(sf_rescale_t), allocatable :: func integer :: i_sub if (.not. term%pcm_instance%config%has_pdfs) return if (term%nlo_type == NLO_REAL) then if (term%is_subtraction ()) then allocate (sf_rescale_collinear_t :: func) select type (pcm => term%pcm_instance) type is (pcm_instance_nlo_t) select type (func) type is (sf_rescale_collinear_t) call func%set (pcm%real_kinematics%xi_tilde) call func%set_gluons (.true.) end select end select call term%k_term%sf_chain%evaluate (term%fac_scale, func) deallocate (func) else if (term%k_term%emitter >= 0 .and. term%k_term%emitter <= term%k_term%n_in) then allocate (sf_rescale_real_t :: func) select type (pcm => term%pcm_instance) type is (pcm_instance_nlo_t) select type (func) type is (sf_rescale_real_t) call func%set (pcm%real_kinematics%xi_tilde * & pcm%real_kinematics%xi_max (term%k_term%i_phs), & pcm%real_kinematics%y (term%k_term%i_phs)) ! TODO sbrass Obviously, it is completely irrelevant, ! TODO sbrass which beam is treated for hadronic beams. It becomes ! TODO sbrass problematic when handling "e, p"-beams. call func%restrict_to_beam (term%k_term%emitter) end select end select call term%k_term%sf_chain%evaluate (term%fac_scale, func) deallocate (func) else call term%k_term%sf_chain%evaluate (term%fac_scale) end if else if (term%nlo_type == NLO_DGLAP) then allocate (sf_rescale_dglap_t :: func) select type (pcm => term%pcm_instance) type is (pcm_instance_nlo_t) select type (func) type is (sf_rescale_dglap_t) call func%set (pcm%isr_kinematics%z) call func%set_gluons (.true.) end select end select call term%k_term%sf_chain%evaluate (term%fac_scale, func) deallocate (func) 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: <>= procedure :: get_fac_scale => term_instance_get_fac_scale <>= function term_instance_get_fac_scale (term) result (fac_scale) class(term_instance_t), intent(in) :: term real(default) :: fac_scale fac_scale = term%fac_scale end function term_instance_get_fac_scale @ %def term_instance_get_fac_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 @ <>= procedure :: reset_phs_identifiers => term_instance_reset_phs_identifiers <>= subroutine term_instance_reset_phs_identifiers (term) class(term_instance_t), intent(inout) :: term select type (phs => term%k_term%phs) type is (phs_fks_t) phs%phs_identifiers%evaluated = .false. end select end subroutine term_instance_reset_phs_identifiers @ %def term_instance_reset_phs_identifiers @ 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_boost_to_lab => term_instance_get_boost_to_lab <>= function term_instance_get_boost_to_lab (term) result (lt) type(lorentz_transformation_t) :: lt class(term_instance_t), intent(in) :: term lt = term%k_term%phs%get_lorentz_transformation () end function term_instance_get_boost_to_lab @ %def term_instance_get_boost_to_lab @ <>= procedure :: get_boost_to_cms => term_instance_get_boost_to_cms <>= function term_instance_get_boost_to_cms (term) result (lt) type(lorentz_transformation_t) :: lt class(term_instance_t), intent(in) :: term lt = inverse (term%k_term%phs%get_lorentz_transformation ()) end function term_instance_get_boost_to_cms @ %def term_instance_get_boost_to_cms @ <>= 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} 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 [[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 [[component]] subobjects determine the state of each component. The [[term]] subobjects are workspace for evaluating kinematics, matrix elements, cuts etc. 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 () 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(term_instance_t), dimension(:), allocatable :: term type(mci_work_t), dimension(:), allocatable :: mci_work class(pcm_instance_t), allocatable :: pcm 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 evalutaed 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, & 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) :: term type(var_list_t), pointer :: var_list integer :: i_born, i_real, i_real_fin call msg_debug (D_PROCESS_INTEGRATION, "process_instance_init") instance%process => process 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_instance (instance%pcm) call instance%pcm%link_config (pcm) 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_instance each time. i_real_fin = process%get_associated_real_fin (1) if (.not. pcm%initialized) then ! i_born = pcm%get_i_core_nlo_type (BORN) i_born = pcm%get_i_core (pcm%i_born) ! i_real = pcm%get_i_core_nlo_type (NLO_REAL, include_sub = .false.) ! i_real = pcm%get_i_core_nlo_type (NLO_REAL) i_real = pcm%get_i_core (pcm%i_real) term = process%get_term_ptr (process%get_i_term (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_instance => instance%pcm) type is (pcm_instance_nlo_t) call pcm_instance%init_config (process%component_can_be_integrated (), & process%get_nlo_type_component (), process%get_sqrts (), i_real_fin, & process%get_model_ptr ()) end select end select allocate (instance%term (process%get_n_terms ())) do i = 1, process%get_n_terms () call instance%term(i)%init_from_process (process, i, instance%pcm, & instance%sf_chain) 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%term)) then do i = 1, size (instance%term) call instance%term(i)%final () end do deallocate (instance%term) end if call instance%pcm%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) :: 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%term%k_term%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%term(i)%k_term%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%term(j)%k_term%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) if (i_term_same /= i_term) then instance%term(i_term_same)%p_seed = instance%term(i_term)%p_seed associate (phs => instance%term(i_term_same)%k_term%phs) call phs%set_lorentz_transformation & (instance%term(i_term)%k_term%phs%get_lorentz_transformation ()) select type (phs) type is (phs_fks_t) call phs%set_momenta (instance%term(i_term_same)%p_seed) call phs%set_reference_frames (.false.) end select end associate end if instance%term(i_term_same)%k_term%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%term(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)) if (associated (term%config)) then core => instance%process%get_core_term (i) call term%setup_event_data (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_frame ()) then if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then call instance%term(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, skip_term) class(process_instance_t), intent(inout) :: instance 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 (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) if (instance%term(i_term(j))%k_term%new_seed) then call instance%term(i_term(j))%compute_seed_kinematics & (instance%mci_work(instance%i_mci), channel, success) call instance%transfer_same_kinematics (i_term(j)) end if if (.not. success) exit call instance%term(i_term(j))%evaluate_projections () call instance%term(i_term(j))%evaluate_radiation_kinematics & (instance%mci_work(instance%i_mci)%get_x_process ()) call instance%term(i_term(j))%generate_fsr_in () call instance%term(i_term(j))%compute_xi_ref_momenta () 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 => instance%pcm) class is (pcm_instance_nlo_t) call pcm%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 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%term(i_term)%recover_mcpar & (instance%mci_work(instance%i_mci), channel) 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%term(i_term)%recover_sfchain (channel) 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, skip_term) class(process_instance_t), intent(inout) :: instance integer, intent(in), optional :: skip_term integer :: i logical :: success success = .true. if (instance%evaluation_status >= STAT_SEED_KINEMATICS) then do i = 1, size (instance%term) if (instance%term(i)%active) then call instance%term(i)%compute_hard_kinematics (skip_term, success) if (.not. success) exit !!! Ren scale is zero when this is commented out! Understand! if (instance%term(i)%nlo_type == NLO_REAL) & call instance%term(i)%redo_sf_chain (instance%mci_work(instance%i_mci), & instance%selected_channel) end if 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 if (instance%evaluation_status >= STAT_EFF_KINEMATICS) & call instance%term(i_term)%recover_seed_kinematics () 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 sucessful, 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 () 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 (config => instance%pcm%config) 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 (config%settings%cut_all_sqmes) & passed_real = passed_real .and. instance%term(i)%passed if (config%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 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%term(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 an 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) class(process_instance_t), intent(inout) :: instance 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 () call msg_debug2 (D_PROCESS_INTEGRATION, "process_instance_evaluate_trace") 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)) 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 ! if (instance%pcm%config%is_nlo ()) & ! core_sub => instance%process%get_subtraction_core () call term%evaluate_interaction (core) call term%evaluate_trace () i_real_fin = instance%process%get_associated_real_fin (1) if (instance%process%uses_real_partition ()) & call term%apply_real_partition (instance%process) if (term%config%i_component /= i_real_fin) then if ((term%nlo_type == NLO_REAL .and. term%k_term%emitter < 0) & .or. term%nlo_type == NLO_MISMATCH & .or. term%nlo_type == NLO_DGLAP) & call term%set_born_sqmes (core) if (term%nlo_type > BORN) then if (.not. (term%nlo_type == NLO_REAL .and. term%k_term%emitter >= 0)) then select type (config => term%pcm_instance%config) type is (pcm_nlo_t) if (char (config%settings%nlo_correction_type) == "QCD" .or. & char (config%settings%nlo_correction_type) == "Full") & call term%evaluate_color_correlations (core_sub) if (char (config%settings%nlo_correction_type) == "QED" .or. & char (config%settings%nlo_correction_type) == "Full") & call term%evaluate_charge_correlations (core_sub) end select end if if (term%is_subtraction ()) then call term%evaluate_spin_correlations (core_sub) end if if ((term%is_subtraction () .or. term%nlo_type == NLO_DGLAP) & .and. term%pcm_instance%config%has_pdfs) & call term%compute_sqme_coll_isr () end if alpha_s = core%get_alpha_s (term%core_state) if (associated (instance%process%get_model_ptr ())) then model => instance%process%get_model_ptr () if (associated (model%get_par_data_ptr (var_str ('alpha_em_i')))) & alpha_qed = one / model%get_real (var_str ('alpha_em_i')) model => null () end if select case (term%nlo_type) case (NLO_REAL) call term%apply_fks (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) 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%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_instance => term%pcm_instance) type is (pcm_instance_nlo_t) do i_flv = 1, term%connected_qn_index%get_n_flv () ii_flv = term%connected_qn_index%get_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_instance%real_sub%sqme_born(i_flv) = sqme case (NLO_MISMATCH) pcm_instance%soft_mismatch%sqme_born(i_flv) = sqme case (NLO_DGLAP) pcm_instance%dglap_remnant%sqme_born(i_flv) = sqme end select end do end select end subroutine term_instance_set_born_sqmes @ <>= 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 (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_instance => instance%pcm) type is (pcm_instance_nlo_t) if (allocated (pcm_instance%i_mci_to_real_component)) then call msg_warning ("i_mci_to_real_component already allocated - replace it") deallocate (pcm_instance%i_mci_to_real_component) end if allocate (pcm_instance%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_instance%i_mci_to_real_component (i_mci) = & component%config%get_associated_real () case (COMP_REAL_FIN) pcm_instance%i_mci_to_real_component (i_mci) = & component%config%get_associated_real_fin () case (COMP_REAL_SING) pcm_instance%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 .and. term%passed) 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 keep the event nevertheless if (instance%keep_failed_events ()) then !!! Force factorization scale, otherwise writing to event output fails 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. 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 call msg_debug2 (D_PROCESS_INTEGRATION, "process_instance_compute_sqme_rad") select type (pcm => instance%pcm) type is (pcm_instance_nlo_t) associate (term => instance%term(i_term)) core => instance%process%get_core_term (i_term) if (is_subtraction) then call pcm%set_subtraction_event () else call pcm%set_radiation_event () end if call term%int_hard%set_momenta (pcm%get_momenta & (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) call term%evaluate_trace () pcm%real_sub%sqme_born (1) = & real (term%connected%trace%get_matrix_element (1)) if (term%is_subtraction ()) then select type (config => term%pcm_instance%config) type is (pcm_nlo_t) if (char (config%settings%nlo_correction_type) == "QCD" .or. & char (config%settings%nlo_correction_type) == "Full") & call term%evaluate_color_correlations (core) if (char (config%settings%nlo_correction_type) == "QED" .or. & char (config%settings%nlo_correction_type) == "Full") & call term%evaluate_charge_correlations (core) end select call term%evaluate_spin_correlations (core) if (term%pcm_instance%config%has_pdfs) & call term%compute_sqme_coll_isr () else if (term%nlo_type == NLO_DGLAP) then call term%compute_sqme_coll_isr () end if i_real_fin = instance%process%get_associated_real_fin (1) if (term%config%i_component /= i_real_fin) & call term%apply_fks (core%get_alpha_s (term%core_state), 0._default) 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 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) if (recover_phs) then call instance%recover_mcpar (i_term) call instance%recover_beam_momenta (i_term) call instance%compute_seed_kinematics (i_term) call instance%compute_hard_kinematics (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 () 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%term(i_term_base)%k_term) 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%term(i)%k_term%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)) 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 & (instance%mci_work(i_component), 1, success) call instance%term(i_term)%evaluate_radiation_kinematics & (instance%mci_work(instance%i_mci)%get_x_process ()) call instance%term(i_term)%compute_hard_kinematics (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 => instance%pcm) type is (pcm_instance_nlo_t) i_real = pcm%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(2) :: 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) 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 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)) 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%term(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%term(i_term)%get_boost_to_cms () end function process_instance_get_boost_to_cms @ %def process_instance_get_boost_to_cms @ <>= procedure :: is_cm_frame => process_instance_is_cm_frame <>= function process_instance_is_cm_frame (instance, i_term) result (cm_frame) logical :: cm_frame class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term cm_frame = instance%term(i_term)%k_term%phs%is_cm_frame () end function process_instance_is_cm_frame @ %def protcess_instance_is_cm_frame @ 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%term) call pacify (instance%term(i)%k_term%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%term(1)%k_term%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%term(1)%k_term%phs_factor write (u, "(A)") write (u, "(A)") "* Cleanup" call process_instance%final () deallocate (process_instance) call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_16" end subroutine processes_16 @ %def processes_16 @ MCI record prepared for midpoint integrator. <>= subroutine dispatch_mci_test_midpoint (mci, var_list, process_id, is_nlo) class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo allocate (mci_midpoint_t :: mci) end subroutine dispatch_mci_test_midpoint @ %def dispatch_mci_test_midpoint @ \subsubsection{Decay Process Evaluation} Initialize an evaluate a decay process for a moving particle. <>= call test (processes_17, "processes_17", & "decay of moving particle", & u, results) <>= public :: processes_17 <>= subroutine processes_17 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template type(process_instance_t), allocatable, target :: process_instance type(particle_set_t) :: pset type(flavor_t) :: flv_beam real(default) :: m, p, E write (u, "(A)") "* Test output: processes_17" write (u, "(A)") "* Purpose: initialize a decay process object" write (u, "(A)") write (u, "(A)") "* Build and load a test library with one process" write (u, "(A)") libname = "processes17" procname = libname call os_data%init () call prc_test_create_library (libname, lib, scattering = .false., & decay = .true.) write (u, "(A)") "* Initialize a process object" write (u, "(A)") call model%init_test () call model%set_par (var_str ("ff"), 0.4_default) call model%set_par (var_str ("mf"), & model%get_real (var_str ("ff")) * model%get_real (var_str ("ms"))) allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_single_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Prepare a trivial beam setup" write (u, "(A)") call process%setup_beams_decay (rest_frame = .false., i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_empty) write (u, "(A)") "* Complete process initialization" write (u, "(A)") call process%setup_terms () call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Create a process instance" write (u, "(A)") call reset_interaction_counter (3) allocate (process_instance) call process_instance%init (process) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Set parent momentum and random numbers" write (u, "(A)") call process_instance%choose_mci (1) call process_instance%set_mcpar ([0._default, 0._default]) call flv_beam%init (25, process%get_model_ptr ()) m = flv_beam%get_mass () p = 3 * m / 4 E = sqrt (m**2 + p**2) call process_instance%set_beam_momenta ([vector4_moving (E, p, 3)]) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Set up hard kinematics" write (u, "(A)") call process_instance%select_channel (1) call process_instance%compute_seed_kinematics () call process_instance%compute_hard_kinematics () write (u, "(A)") "* Evaluate matrix element and square" write (u, "(A)") call process_instance%compute_eff_kinematics () call process_instance%evaluate_expressions () call process_instance%compute_other_channels () call process_instance%evaluate_trace () call process_instance%write (u) call process_instance%get_trace (pset, 1) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Particle content:" write (u, "(A)") call write_separator (u) call pset%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Recover process instance" write (u, "(A)") call reset_interaction_counter (3) allocate (process_instance) call process_instance%init (process) call process_instance%choose_mci (1) call process_instance%set_trace (pset, 1, check_match = .false.) call process_instance%recover (1, 1, .true., .true.) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call pset%final () call process_instance%final () deallocate (process_instance) call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_17" end subroutine processes_17 @ %def processes_17 @ \subsubsection{Resonances in Phase Space} This test demonstrates the extraction of the resonance-history set from the generated phase space. We need a nontrivial process, but no matrix element. This is provided by the [[prc_template]] method, using the [[SM]] model. We also need the [[phs_wood]] method, otherwise we would not have resonances in the phase space configuration. <>= call test (processes_18, "processes_18", & "extract resonance history set", & u, results) <>= public :: processes_18 <>= subroutine processes_18 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(string_t) :: model_name type(os_data_t) :: os_data class(model_data_t), pointer :: model class(vars_t), pointer :: vars type(process_t), pointer :: process type(resonance_history_set_t) :: res_set integer :: i write (u, "(A)") "* Test output: processes_18" write (u, "(A)") "* Purpose: extra resonance histories" write (u, "(A)") write (u, "(A)") "* Build and load a test library with one process" write (u, "(A)") libname = "processes_18_lib" procname = "processes_18_p" call os_data%init () call syntax_phs_forest_init () model_name = "SM" model => null () call prepare_model (model, model_name, vars) write (u, "(A)") "* Initialize a process library with one process" write (u, "(A)") select type (model) class is (model_t) call prepare_resonance_test_library (lib, libname, procname, model, os_data, u) end select write (u, "(A)") write (u, "(A)") "* Initialize a process object with phase space" allocate (process) select type (model) class is (model_t) call prepare_resonance_test_process (process, lib, procname, model, os_data) end select write (u, "(A)") write (u, "(A)") "* Extract resonance history set" write (u, "(A)") call process%extract_resonance_history_set (res_set) call res_set%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call process%final () deallocate (process) call model%final () deallocate (model) call syntax_phs_forest_final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_18" end subroutine processes_18 @ %def processes_18 @ Auxiliary subroutine that constructs the process library for the above test. <>= subroutine prepare_resonance_test_library & (lib, libname, procname, model, os_data, u) type(process_library_t), target, intent(out) :: lib type(string_t), intent(in) :: libname type(string_t), intent(in) :: procname type(model_t), intent(in), target :: model type(os_data_t), intent(in) :: os_data integer, intent(in) :: u type(string_t), dimension(:), allocatable :: prt_in, prt_out class(prc_core_def_t), allocatable :: def type(process_def_entry_t), pointer :: entry call lib%init (libname) allocate (prt_in (2), prt_out (3)) prt_in = [var_str ("e+"), var_str ("e-")] prt_out = [var_str ("d"), var_str ("ubar"), var_str ("W+")] allocate (template_me_def_t :: def) select type (def) type is (template_me_def_t) call def%init (model, prt_in, prt_out, unity = .false.) end select allocate (entry) call entry%init (procname, & model_name = model%get_name (), & n_in = 2, n_components = 1) call entry%import_component (1, n_out = size (prt_out), & prt_in = new_prt_spec (prt_in), & prt_out = new_prt_spec (prt_out), & method = var_str ("template"), & variant = def) call entry%write (u) call lib%append (entry) call lib%configure (os_data) call lib%write_makefile (os_data, force = .true., verbose = .false.) call lib%clean (os_data, distclean = .false.) call lib%write_driver (force = .true.) call lib%load (os_data) end subroutine prepare_resonance_test_library @ %def prepare_resonance_test_library @ We want a test process which has been initialized up to the point where we can evaluate the matrix element. This is in fact rather complicated. We copy the steps from [[integration_setup_process]] in the [[integrate]] module, which is not available at this point. <>= subroutine prepare_resonance_test_process & (process, lib, procname, model, os_data) class(process_t), intent(out), target :: process type(process_library_t), intent(in), target :: lib type(string_t), intent(in) :: procname type(model_t), intent(in), target :: model type(os_data_t), intent(in) :: os_data class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts call process%init (procname, lib, os_data, model) allocate (phs_wood_config_t :: phs_config_template) call process%init_components (phs_config_template) call process%setup_test_cores (type_string = var_str ("template")) sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_none) call process%setup_terms () end subroutine prepare_resonance_test_process @ %def prepare_resonance_test_process @ MCI record prepared for the none (dummy) integrator. <>= subroutine dispatch_mci_none (mci, var_list, process_id, is_nlo) class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo allocate (mci_none_t :: mci) end subroutine dispatch_mci_none @ %def dispatch_mci_none @ \subsubsection{Add after evaluate hook(s)} Initialize a process and process instance, add a trivial process hook, choose a sampling point and fill the process instance. We use the same trivial process as for the previous test. All momentum and state dependence is trivial, so we just test basic functionality. <>= type, extends(process_instance_hook_t) :: process_instance_hook_test_t integer :: unit character(len=15) :: name contains procedure :: init => process_instance_hook_test_init procedure :: final => process_instance_hook_test_final procedure :: evaluate => process_instance_hook_test_evaluate end type process_instance_hook_test_t @ <>= subroutine process_instance_hook_test_init (hook, var_list, instance) class(process_instance_hook_test_t), intent(inout), target :: hook type(var_list_t), intent(in) :: var_list class(process_instance_t), intent(in), target :: instance end subroutine process_instance_hook_test_init subroutine process_instance_hook_test_final (hook) class(process_instance_hook_test_t), intent(inout) :: hook end subroutine process_instance_hook_test_final subroutine process_instance_hook_test_evaluate (hook, instance) class(process_instance_hook_test_t), intent(inout) :: hook class(process_instance_t), intent(in), target :: instance write (hook%unit, "(A)") "Execute hook:" write (hook%unit, "(2X,A,1X,A,I0,A)") hook%name, "(", len (trim (hook%name)), ")" end subroutine process_instance_hook_test_evaluate @ <>= call test (processes_19, "processes_19", & "add trivial hooks to a process instance ", & u, results) <>= public :: processes_19 <>= subroutine processes_19 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data class(model_data_t), pointer :: model type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts type(process_instance_t) :: process_instance class(process_instance_hook_t), allocatable, target :: process_instance_hook, process_instance_hook2 type(particle_set_t) :: pset write (u, "(A)") "* Test output: processes_19" write (u, "(A)") "* Purpose: allocate process instance & &and add an after evaluate hook" write (u, "(A)") write (u, "(A)") write (u, "(A)") "* Allocate a process instance" write (u, "(A)") call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Allocate hook and add to process instance" write (u, "(A)") allocate (process_instance_hook_test_t :: process_instance_hook) call process_instance%append_after_hook (process_instance_hook) allocate (process_instance_hook_test_t :: process_instance_hook2) call process_instance%append_after_hook (process_instance_hook2) select type (process_instance_hook) type is (process_instance_hook_test_t) process_instance_hook%unit = u process_instance_hook%name = "Hook 1" end select select type (process_instance_hook2) type is (process_instance_hook_test_t) process_instance_hook2%unit = u process_instance_hook2%name = "Hook 2" end select write (u, "(A)") "* Evaluate matrix element and square" write (u, "(A)") call process_instance%evaluate_after_hook () write (u, "(A)") write (u, "(A)") "* Cleanup" call process_instance_hook%final () deallocate (process_instance_hook) write (u, "(A)") write (u, "(A)") "* Test output end: processes_19" end subroutine processes_19 @ %def processes_19 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Process Stacks} For storing and handling multiple processes, we define process stacks. These are ordinary stacks where new process entries are pushed onto the top. We allow for multiple entries with identical process ID, but distinct run ID. The implementation is essentially identical to the [[prclib_stacks]] module above. Unfortunately, Fortran supports no generic programming, so we do not make use of this fact. When searching for a specific process ID, we will get (a pointer to) the topmost process entry with that ID on the stack, which was entered last. Usually, this is the best version of the process (in terms of integral, etc.) Thus the stack terminology makes sense. <<[[process_stacks.f90]]>>= <> module process_stacks <> <> use io_units use format_utils, only: write_separator use diagnostics use os_interface use sm_qcd use model_data use rng_base use variables use observables use process_libraries use process <> <> <> contains <> end module process_stacks @ %def process_stacks @ \subsection{The process entry type} A process entry is a process object, augmented by a pointer to the next entry. We do not need specific methods, all relevant methods are inherited. On higher level, processes should be prepared as process entry objects. <>= public :: process_entry_t <>= type, extends (process_t) :: process_entry_t type(process_entry_t), pointer :: next => null () end type process_entry_t @ %def process_entry_t @ \subsection{The process stack type} For easy conversion and lookup it is useful to store the filling number in the object. The content is stored as a linked list. The [[var_list]] component stores process-specific results, so they can be retrieved as (pseudo) variables. The process stack can be linked to another one. This allows us to work with stacks of local scope. <>= public :: process_stack_t <>= type :: process_stack_t integer :: n = 0 type(process_entry_t), pointer :: first => null () type(var_list_t), pointer :: var_list => null () type(process_stack_t), pointer :: next => null () contains <> end type process_stack_t @ %def process_stack_t @ Finalize partly: deallocate the process stack and variable list entries, but keep the variable list as an empty object. This way, the variable list links are kept. <>= procedure :: clear => process_stack_clear <>= subroutine process_stack_clear (stack) class(process_stack_t), intent(inout) :: stack type(process_entry_t), pointer :: process if (associated (stack%var_list)) then call stack%var_list%final () end if do while (associated (stack%first)) process => stack%first stack%first => process%next call process%final () deallocate (process) end do stack%n = 0 end subroutine process_stack_clear @ %def process_stack_clear @ Finalizer. Clear and deallocate the variable list. <>= procedure :: final => process_stack_final <>= subroutine process_stack_final (object) class(process_stack_t), intent(inout) :: object call object%clear () if (associated (object%var_list)) then deallocate (object%var_list) end if end subroutine process_stack_final @ %def process_stack_final @ Output. The processes on the stack will be ordered LIFO, i.e., backwards. <>= procedure :: write => process_stack_write <>= recursive subroutine process_stack_write (object, unit, pacify) class(process_stack_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify type(process_entry_t), pointer :: process integer :: u u = given_output_unit (unit) call write_separator (u, 2) select case (object%n) case (0) write (u, "(1x,A)") "Process stack: [empty]" call write_separator (u, 2) case default write (u, "(1x,A)") "Process stack:" process => object%first do while (associated (process)) call process%write (.false., u, pacify = pacify) process => process%next end do end select if (associated (object%next)) then write (u, "(1x,A)") "[Processes from context environment:]" call object%next%write (u, pacify) end if end subroutine process_stack_write @ %def process_stack_write @ The variable list is printed by a separate routine, since it should be linked to the global variable list, anyway. <>= procedure :: write_var_list => process_stack_write_var_list <>= subroutine process_stack_write_var_list (object, unit) class(process_stack_t), intent(in) :: object integer, intent(in), optional :: unit if (associated (object%var_list)) then call var_list_write (object%var_list, unit) end if end subroutine process_stack_write_var_list @ %def process_stack_write_var_list @ Short output. Since this is a stack, the default output ordering for each stack will be last-in, first-out. To enable first-in, first-out, which is more likely to be requested, there is an optional [[fifo]] argument. <>= procedure :: show => process_stack_show <>= recursive subroutine process_stack_show (object, unit, fifo) class(process_stack_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: fifo type(process_entry_t), pointer :: process logical :: reverse integer :: u, i, j u = given_output_unit (unit) reverse = .false.; if (present (fifo)) reverse = fifo select case (object%n) case (0) case default if (.not. reverse) then process => object%first do while (associated (process)) call process%show (u, verbose=.false.) process => process%next end do else do i = 1, object%n process => object%first do j = 1, object%n - i process => process%next end do call process%show (u, verbose=.false.) end do end if end select if (associated (object%next)) call object%next%show () end subroutine process_stack_show @ %def process_stack_show @ \subsection{Link} Link the current process stack to a global one. <>= procedure :: link => process_stack_link <>= subroutine process_stack_link (local_stack, global_stack) class(process_stack_t), intent(inout) :: local_stack type(process_stack_t), intent(in), target :: global_stack local_stack%next => global_stack end subroutine process_stack_link @ %def process_stack_link @ Initialize the process variable list and link the main variable list to it. <>= procedure :: init_var_list => process_stack_init_var_list <>= subroutine process_stack_init_var_list (stack, var_list) class(process_stack_t), intent(inout) :: stack type(var_list_t), intent(inout), optional :: var_list allocate (stack%var_list) if (present (var_list)) call var_list%link (stack%var_list) end subroutine process_stack_init_var_list @ %def process_stack_init_var_list @ Link the process variable list to a global variable list. <>= procedure :: link_var_list => process_stack_link_var_list <>= subroutine process_stack_link_var_list (stack, var_list) class(process_stack_t), intent(inout) :: stack type(var_list_t), intent(in), target :: var_list call stack%var_list%link (var_list) end subroutine process_stack_link_var_list @ %def process_stack_link_var_list @ \subsection{Push} We take a process pointer and push it onto the stack. The previous pointer is nullified. Subsequently, the process is `owned' by the stack and will be finalized when the stack is deleted. <>= procedure :: push => process_stack_push <>= subroutine process_stack_push (stack, process) class(process_stack_t), intent(inout) :: stack type(process_entry_t), intent(inout), pointer :: process process%next => stack%first stack%first => process process => null () stack%n = stack%n + 1 end subroutine process_stack_push @ %def process_stack_push @ Inverse: Remove the last process pointer in the list and return it. <>= procedure :: pop_last => process_stack_pop_last <>= subroutine process_stack_pop_last (stack, process) class(process_stack_t), intent(inout) :: stack type(process_entry_t), intent(inout), pointer :: process type(process_entry_t), pointer :: previous integer :: i select case (stack%n) case (:0) process => null () case (1) process => stack%first stack%first => null () stack%n = 0 case (2:) process => stack%first do i = 2, stack%n previous => process process => process%next end do previous%next => null () stack%n = stack%n - 1 end select end subroutine process_stack_pop_last @ %def process_stack_pop_last @ Initialize process variables for a given process ID, without setting values. <>= procedure :: init_result_vars => process_stack_init_result_vars <>= subroutine process_stack_init_result_vars (stack, id) class(process_stack_t), intent(inout) :: stack type(string_t), intent(in) :: id call var_list_init_num_id (stack%var_list, id) call var_list_init_process_results (stack%var_list, id) end subroutine process_stack_init_result_vars @ %def process_stack_init_result_vars @ Fill process variables with values. This is executed after the integration pass. Note: We set only integral and error. With multiple MCI records possible, the results for [[n_calls]], [[chi2]] etc. are not necessarily unique. (We might set the efficiency, though.) <>= procedure :: fill_result_vars => process_stack_fill_result_vars <>= subroutine process_stack_fill_result_vars (stack, id) class(process_stack_t), intent(inout) :: stack type(string_t), intent(in) :: id type(process_t), pointer :: process process => stack%get_process_ptr (id) if (associated (process)) then call var_list_init_num_id (stack%var_list, id, process%get_num_id ()) if (process%has_integral ()) then call var_list_init_process_results (stack%var_list, id, & integral = process%get_integral (), & error = process%get_error ()) end if else call msg_bug ("process_stack_fill_result_vars: unknown process ID") end if end subroutine process_stack_fill_result_vars @ %def process_stack_fill_result_vars @ If one of the result variables has a local image in [[var_list_local]], update the value there as well. <>= procedure :: update_result_vars => process_stack_update_result_vars <>= subroutine process_stack_update_result_vars (stack, id, var_list_local) class(process_stack_t), intent(inout) :: stack type(string_t), intent(in) :: id type(var_list_t), intent(inout) :: var_list_local call update ("integral(" // id // ")") call update ("error(" // id // ")") contains subroutine update (var_name) type(string_t), intent(in) :: var_name real(default) :: value if (var_list_local%contains (var_name, follow_link = .false.)) then value = stack%var_list%get_rval (var_name) call var_list_local%set_real (var_name, value, is_known = .true.) end if end subroutine update end subroutine process_stack_update_result_vars @ %def process_stack_update_result_vars @ \subsection{Data Access} Tell if a process exists. <>= procedure :: exists => process_stack_exists <>= function process_stack_exists (stack, id) result (flag) class(process_stack_t), intent(in) :: stack type(string_t), intent(in) :: id logical :: flag type(process_t), pointer :: process process => stack%get_process_ptr (id) flag = associated (process) end function process_stack_exists @ %def process_stack_exists @ Return a pointer to a process with specific ID. Look also at a linked stack, if necessary. <>= procedure :: get_process_ptr => process_stack_get_process_ptr <>= recursive function process_stack_get_process_ptr (stack, id) result (ptr) class(process_stack_t), intent(in) :: stack type(string_t), intent(in) :: id type(process_t), pointer :: ptr type(process_entry_t), pointer :: entry ptr => null () entry => stack%first do while (associated (entry)) if (entry%get_id () == id) then ptr => entry%process_t return end if entry => entry%next end do if (associated (stack%next)) ptr => stack%next%get_process_ptr (id) end function process_stack_get_process_ptr @ %def process_stack_get_process_ptr @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[process_stacks_ut.f90]]>>= <> module process_stacks_ut use unit_tests use process_stacks_uti <> <> contains <> end module process_stacks_ut @ %def process_stacks_ut @ <<[[process_stacks_uti.f90]]>>= <> module process_stacks_uti <> use os_interface use sm_qcd use models use model_data use variables, only: var_list_t use process_libraries use rng_base use prc_test, only: prc_test_create_library use process, only: process_t use instances, only: process_instance_t use processes_ut, only: prepare_test_process use process_stacks use rng_base_ut, only: rng_test_factory_t <> <> contains <> end module process_stacks_uti @ %def process_stacks_uti @ API: driver for the unit tests below. <>= public :: process_stacks_test <>= subroutine process_stacks_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine process_stacks_test @ %def process_stacks_test @ \subsubsection{Write an empty process stack} The most trivial test is to write an uninitialized process stack. <>= call test (process_stacks_1, "process_stacks_1", & "write an empty process stack", & u, results) <>= public :: process_stacks_1 <>= subroutine process_stacks_1 (u) integer, intent(in) :: u type(process_stack_t) :: stack write (u, "(A)") "* Test output: process_stacks_1" write (u, "(A)") "* Purpose: display an empty process stack" write (u, "(A)") call stack%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: process_stacks_1" end subroutine process_stacks_1 @ %def process_stacks_1 @ \subsubsection{Fill a process stack} Fill a process stack with two (identical) processes. <>= call test (process_stacks_2, "process_stacks_2", & "fill a process stack", & u, results) <>= public :: process_stacks_2 <>= subroutine process_stacks_2 (u) integer, intent(in) :: u type(process_stack_t) :: stack type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(var_list_t) :: var_list type(process_entry_t), pointer :: process => null () write (u, "(A)") "* Test output: process_stacks_2" write (u, "(A)") "* Purpose: fill a process stack" write (u, "(A)") write (u, "(A)") "* Build, initialize and store two test processes" write (u, "(A)") libname = "process_stacks2" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call model%init_test () call var_list%append_string (var_str ("$run_id")) call var_list%append_log (var_str ("?alphas_is_fixed"), .true.) call var_list%append_int (var_str ("seed"), 0) allocate (process) call var_list%set_string & (var_str ("$run_id"), var_str ("run1"), is_known=.true.) call process%init (procname, lib, os_data, model, var_list) call stack%push (process) allocate (process) call var_list%set_string & (var_str ("$run_id"), var_str ("run2"), is_known=.true.) call process%init (procname, lib, os_data, model, var_list) call stack%push (process) call stack%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call stack%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: process_stacks_2" end subroutine process_stacks_2 @ %def process_stacks_2 @ \subsubsection{Fill a process stack} Fill a process stack with two (identical) processes. <>= call test (process_stacks_3, "process_stacks_3", & "process variables", & u, results) <>= public :: process_stacks_3 <>= subroutine process_stacks_3 (u) integer, intent(in) :: u type(process_stack_t) :: stack type(model_t), target :: model type(string_t) :: procname type(process_entry_t), pointer :: process => null () type(process_instance_t), target :: process_instance write (u, "(A)") "* Test output: process_stacks_3" write (u, "(A)") "* Purpose: setup process variables" write (u, "(A)") write (u, "(A)") "* Initialize process variables" write (u, "(A)") procname = "processes_test" call model%init_test () write (u, "(A)") "* Initialize process variables" write (u, "(A)") call stack%init_var_list () call stack%init_result_vars (procname) call stack%write_var_list (u) write (u, "(A)") write (u, "(A)") "* Build and integrate a test process" write (u, "(A)") allocate (process) call prepare_test_process (process%process_t, process_instance, model) call process_instance%integrate (1, 1, 1000) call process_instance%final () call process%final_integration (1) call stack%push (process) write (u, "(A)") "* Fill process variables" write (u, "(A)") call stack%fill_result_vars (procname) call stack%write_var_list (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call stack%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: process_stacks_3" end subroutine process_stacks_3 @ %def process_stacks_3 @ \subsubsection{Linked a process stack} Fill two process stack, linked to each other. <>= call test (process_stacks_4, "process_stacks_4", & "linked stacks", & u, results) <>= public :: process_stacks_4 <>= subroutine process_stacks_4 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(process_stack_t), target :: stack1, stack2 type(model_t), target :: model type(string_t) :: libname type(string_t) :: procname1, procname2 type(os_data_t) :: os_data type(process_entry_t), pointer :: process => null () write (u, "(A)") "* Test output: process_stacks_4" write (u, "(A)") "* Purpose: link process stacks" write (u, "(A)") write (u, "(A)") "* Initialize process variables" write (u, "(A)") libname = "process_stacks_4_lib" procname1 = "process_stacks_4a" procname2 = "process_stacks_4b" call os_data%init () write (u, "(A)") "* Initialize first process" write (u, "(A)") call prc_test_create_library (procname1, lib) call model%init_test () allocate (process) call process%init (procname1, lib, os_data, model) call stack1%push (process) write (u, "(A)") "* Initialize second process" write (u, "(A)") call stack2%link (stack1) call prc_test_create_library (procname2, lib) allocate (process) call process%init (procname2, lib, os_data, model) call stack2%push (process) write (u, "(A)") "* Show linked stacks" write (u, "(A)") call stack2%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call stack2%final () call stack1%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: process_stacks_4" end subroutine process_stacks_4 @ %def process_stacks_4 @